unmaintained/advice/advice.factor

   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
   8 SYMBOLS: before after around advised in-advice? ;
   9
  10 : advised? ( word -- ? )
  11     advised word-prop ;
  12
  13 DEFER: make-advised
  14
  15 <PRIVATE
  16 : init-around-co ( quot -- coroutine )
  17     \ coreset suffix cocreate ;
  18 PRIVATE>
  19
  20 : advise ( quot name word loc --  )
  21     dup around eq? [ [ init-around-co ] 3dip ] when
  22     over advised? [ over make-advised ] unless
  23     word-prop set-at ;
  24
  25 : advise-before ( quot name word --  ) before advise ;
  26
  27 : advise-after ( quot name word --  ) after advise ;
  28
  29 : advise-around ( quot name word --  ) around advise ;
  30
  31 : get-advice ( word type -- seq )
  32     word-prop values ;
  33
  34 : call-before ( word --  )
  35     before get-advice [ call ] each ;
  36
  37 : call-after ( word --  )
  38     after get-advice [ call ] each ;
  39
  40 : call-around ( main word --  )
  41     t in-advice? [
  42         around get-advice tuck
  43         [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
  44     ] with-variable ;
  45
  46 : remove-advice ( name word loc --  )
  47     word-prop delete-at ;
  48
  49 ERROR: ad-do-it-error ;
  50
  51 M: ad-do-it-error summary
  52     drop "ad-do-it should only be called inside 'around' advice" ;
  53
  54 : ad-do-it ( input -- result )
  55     in-advice? get [ ad-do-it-error ] unless coyield ;
  56
  57 : make-advised ( word -- )
  58     [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
  59     [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
  60     [ t advised set-word-prop ] tri ;
  61
  62 : unadvise ( word --  )
  63     [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
  64
  65 SYNTAX: ADVISE: ! word adname location => word adname quot loc
  66     scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
  67
  68 SYNTAX: UNADVISE:
  69     scan-word suffix! \ unadvise suffix! ;