/unmaintained/advice/advice.factor

 1! Copyright (C) 2008 James Cash
 2! See http://factorcode.org/license.txt for BSD license.
 3USING: kernel sequences fry words assocs linked-assocs tools.annotations
 4coroutines lexer parser quotations arrays namespaces continuations
 5summary ;
 6IN: advice
 7
 8SYMBOLS: before after around advised in-advice? ;
 9
10: advised? ( word -- ? )
11    advised word-prop ;
12
13DEFER: make-advised
14
15<PRIVATE
16: init-around-co ( quot -- coroutine )
17    \ coreset suffix cocreate ;
18PRIVATE>
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
49ERROR: ad-do-it-error ;
50
51M: 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
65SYNTAX: ADVISE: ! word adname location => word adname quot loc
66    scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
67    
68SYNTAX: UNADVISE:    
69    scan-word suffix! \ unadvise suffix! ;