extra/advice/advice.factor

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