Working on implementation of 'around' advice
parent
585afbf24e
commit
0f9ccaa352
|
@ -1,10 +1,23 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences symbols fry words assocs tools.annotations ;
|
||||
USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
|
||||
IN: advice
|
||||
|
||||
SYMBOLS: before after around ;
|
||||
|
||||
: advise ( quot name word loc -- )
|
||||
word-prop set-at ;
|
||||
|
||||
: advise-before ( quot name word -- )
|
||||
before advise ;
|
||||
|
||||
: advise-after ( quot name word -- )
|
||||
after advise ;
|
||||
|
||||
: advise-around ( quot name word -- )
|
||||
[ \ coterminate suffix cocreate ] 2dip
|
||||
around advise ;
|
||||
|
||||
: get-advice ( word type -- seq )
|
||||
word-prop values ;
|
||||
|
||||
|
@ -13,17 +26,19 @@ SYMBOLS: before after around ;
|
|||
|
||||
: call-after ( word -- )
|
||||
after get-advice [ call ] each ;
|
||||
|
||||
: advise-before ( quot name word -- )
|
||||
before word-prop set-at ;
|
||||
|
||||
: advise-after ( quot name word -- )
|
||||
after word-prop set-at ;
|
||||
|
||||
: call-around ( main word -- )
|
||||
around get-advice [ [ coresume ] each ] dip call
|
||||
around get-advice reverse [ coresume ] each ;
|
||||
|
||||
: remove-advice ( name word loc -- )
|
||||
word-prop delete-at ;
|
||||
|
||||
: ad-do-it ( input -- result )
|
||||
coyield ;
|
||||
|
||||
|
||||
: make-advised ( word -- )
|
||||
[ dup [ over '[ _ call-before @ _ call-after ] ] annotate ]
|
||||
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
|
||||
[ { before after around } [ H{ } clone swap set-word-prop ] with each ] bi ;
|
||||
|
Loading…
Reference in New Issue