unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / advice / advice.factor

diff --git a/advice/advice.factor b/advice/advice.factor
new file mode 100644 (file)
index 0000000..8e22609
--- /dev/null
+++ b/advice/advice.factor
@@ -0,0 +1,69 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations
+summary ;
+IN: advice
+
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+    advised word-prop ;
+
+DEFER: make-advised
+
+<PRIVATE
+: init-around-co ( quot -- coroutine )
+    \ coreset suffix cocreate ;
+PRIVATE>
+
+: advise ( quot name word loc --  )
+    dup around eq? [ [ init-around-co ] 3dip ] when
+    over advised? [ over make-advised ] unless
+    word-prop set-at ;
+    
+: advise-before ( quot name word --  ) before advise ;
+    
+: advise-after ( quot name word --  ) after advise ;
+
+: advise-around ( quot name word --  ) around advise ;
+
+: get-advice ( word type -- seq )
+    word-prop values ;
+
+: call-before ( word --  )
+    before get-advice [ call ] each ;
+
+: call-after ( word --  )
+    after get-advice [ call ] each ;
+
+: call-around ( main word --  )
+    t in-advice? [
+        around get-advice tuck 
+        [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+    ] with-variable ;
+
+: remove-advice ( name word loc --  )
+    word-prop delete-at ;
+
+ERROR: ad-do-it-error ;
+
+M: ad-do-it-error summary
+    drop "ad-do-it should only be called inside 'around' advice" ;
+
+: ad-do-it ( input -- result )
+    in-advice? get [ ad-do-it-error ] unless coyield ;
+    
+: make-advised ( word -- )
+    [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+    [ { before after around } [ <linked-hash> swap set-word-prop ] with each ] 
+    [ t advised set-word-prop ] tri ;
+
+: unadvise ( word --  )
+    [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+SYNTAX: ADVISE: ! word adname location => word adname quot loc
+    scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
+    
+SYNTAX: UNADVISE:    
+    scan-word suffix! \ unadvise suffix! ;