/unmaintained/advice/advice.factor

http://github.com/abeaumont/factor · Factor · 69 lines · 47 code · 20 blank · 2 comment · 5 complexity · d98d482dbe2a9117eb4270a2f0ae562e MD5 · raw file

  1. ! Copyright (C) 2008 James Cash
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: kernel sequences fry words assocs linked-assocs tools.annotations
  4. coroutines lexer parser quotations arrays namespaces continuations
  5. summary ;
  6. IN: advice
  7. SYMBOLS: before after around advised in-advice? ;
  8. : advised? ( word -- ? )
  9. advised word-prop ;
  10. DEFER: make-advised
  11. <PRIVATE
  12. : init-around-co ( quot -- coroutine )
  13. \ coreset suffix cocreate ;
  14. PRIVATE>
  15. : advise ( quot name word loc -- )
  16. dup around eq? [ [ init-around-co ] 3dip ] when
  17. over advised? [ over make-advised ] unless
  18. word-prop set-at ;
  19. : advise-before ( quot name word -- ) before advise ;
  20. : advise-after ( quot name word -- ) after advise ;
  21. : advise-around ( quot name word -- ) around advise ;
  22. : get-advice ( word type -- seq )
  23. word-prop values ;
  24. : call-before ( word -- )
  25. before get-advice [ call ] each ;
  26. : call-after ( word -- )
  27. after get-advice [ call ] each ;
  28. : call-around ( main word -- )
  29. t in-advice? [
  30. around get-advice tuck
  31. [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
  32. ] with-variable ;
  33. : remove-advice ( name word loc -- )
  34. word-prop delete-at ;
  35. ERROR: ad-do-it-error ;
  36. M: ad-do-it-error summary
  37. drop "ad-do-it should only be called inside 'around' advice" ;
  38. : ad-do-it ( input -- result )
  39. in-advice? get [ ad-do-it-error ] unless coyield ;
  40. : make-advised ( word -- )
  41. [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
  42. [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
  43. [ t advised set-word-prop ] tri ;
  44. : unadvise ( word -- )
  45. [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
  46. SYNTAX: ADVISE: ! word adname location => word adname quot loc
  47. scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
  48. SYNTAX: UNADVISE:
  49. scan-word suffix! \ unadvise suffix! ;