+++ /dev/null
-IN: advice
-USING: help.markup help.syntax tools.annotations words coroutines ;
-
-HELP: make-advised
-{ $values { "word" "a word to annotate in preparation of advising" } }
-{ $description "Prepares a word for being advised. This is done by: "
- { $list
- { "Annotating it to call the appropriate words before, around, and after the original body " }
- { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
- { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
- }
-}
-{ $see-also advised? annotate } ;
-
-HELP: advised?
-{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
-{ $description "Determines whether or not the given word has any advice on it." } ;
-
-HELP: ad-do-it
-{ $values { "input" "an object" } { "result" "an object" } }
-{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
-{ $see-also coyield } ;
-
-ARTICLE: "advice" "Advice"
-"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
-
-ABOUT: "advice"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences io io.streams.string math tools.test advice math.parser
-parser namespaces multiline eval words assocs ;
-IN: advice.tests
-
-[
- [ ad-do-it ] must-fail
-
- : foo ( -- str ) "foo" ;
- \ foo make-advised
-
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo
- ] unit-test
-
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo
- ] unit-test
-
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo
- ] unit-test
-
- : bar ( a -- b ) 1 + ;
- \ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
-
- : add ( a b -- c ) + ;
- \ add make-advised
-
- { 10 } [
- [ [ 2 * ] bi@ ] "double-args" \ add advise-before
- 2 3 add
- ] unit-test
-
- { 21 } [
- [ 3 * ad-do-it 1- ] "around1" \ add advise-around
- 2 3 add
- ] unit-test
-
-! { 9 } [
-! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-! 2 3 add
-! ] unit-test
-
-! { { "around1" "around2" } } [
-! \ add around word-prop keys
-! ] unit-test
-
- { 5 f } [
- \ add unadvise
- 2 3 add \ add advised?
- ] unit-test
-
-! : quux ( a b -- c ) * ;
-
-! { f t 3+3/4 } [
-! <" USING: advice kernel math ;
-! IN: advice.tests
-! \ quux advised?
-! ADVISE: quux halve before [ 2 / ] bi@ ;
-! \ quux advised?
-! 3 5 quux"> eval
-! ] unit-test
-
-! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
-! <" USING: advice kernel math math.parser io io.streams.string ;
-! IN: advice.tests
-! ADVISE: quux log around
-! 2dup [ number>string write " " write ] bi@
-! ad-do-it
-! dup number>string write ;
-! [ 3 5 quux ] with-string-writer"> eval
-! ] unit-test
-
-] with-scope
+++ /dev/null
-! 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 parsed \ unadvise parsed ;
+++ /dev/null
-James Cash
+++ /dev/null
-Implmentation of advice/aspects
+++ /dev/null
-extensions
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words coroutines ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+HELP: ad-do-it
+{ $values { "input" "an object" } { "result" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
+IN: advice.tests
+
+[
+ [ ad-do-it ] must-fail
+
+ : foo ( -- str ) "foo" ;
+ \ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
+
+ : bar ( a -- b ) 1 + ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
+
+] with-scope
--- /dev/null
+! 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 parsed \ unadvise parsed ;
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+extensions
projects / factor.git / commitdiff