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
8 SYMBOLS: before after around advised in-advice? ;
10 : advised? ( word -- ? )
16 : init-around-co ( quot -- coroutine )
17 \ coreset suffix cocreate ;
20 : advise ( quot name word loc -- )
21 dup around eq? [ [ init-around-co ] 3dip ] when
22 over advised? [ over make-advised ] unless
25 : advise-before ( quot name word -- ) before advise ;
27 : advise-after ( quot name word -- ) after advise ;
29 : advise-around ( quot name word -- ) around advise ;
31 : get-advice ( word type -- seq )
34 : call-before ( word -- )
35 before get-advice [ call ] each ;
37 : call-after ( word -- )
38 after get-advice [ call ] each ;
40 : call-around ( main word -- )
42 around get-advice tuck
43 [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
46 : remove-advice ( name word loc -- )
49 ERROR: ad-do-it-error ;
51 M: ad-do-it-error summary
52 drop "ad-do-it should only be called inside 'around' advice" ;
54 : ad-do-it ( input -- result )
55 in-advice? get [ ad-do-it-error ] unless coyield ;
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 ;
62 : unadvise ( word -- )
63 [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
65 SYNTAX: ADVISE: ! word adname location => word adname quot loc
66 scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
69 scan-word suffix! \ unadvise suffix! ;