"======="
">>>>>>>"
"'["
+ "'{"
+ "'H{"
+ "'HS{"
"_"
"@"
"MACRO:"
--- /dev/null
+Slava Pestov
+Eduardo Cavazos
--- /dev/null
+USING: help.markup help.syntax quotations kernel ;
+IN: fry
+
+HELP: _
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: @
+{ $description "Fry specifier. Splices a quotation into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: fry
+{ $values { "quot" quotation } { "quot'" quotation } }
+{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
+{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
+ { $code "[ X ] fry call" "'[ X ]" }
+}
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: '[
+{ $syntax "'[ code... ]" }
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link POSTPONE: _ } " and " { $link POSTPONE: @ } "." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: >r/r>-in-fry-error
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
+
+ARTICLE: "fry.examples" "Examples of fried quotations"
+"The easiest way to understand fried quotations is to look at some examples."
+$nl
+"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
+{ $code "{ 10 20 30 } '[ . ] each" }
+"Occurrences of " { $link POSTPONE: _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
+{ $code
+ "{ 10 20 30 } 5 '[ _ + ] map"
+ "{ 10 20 30 } 5 [ + ] curry map"
+ "{ 10 20 30 } [ 5 + ] map"
+}
+"Occurrences of " { $link POSTPONE: _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
+{ $code
+ "{ 10 20 30 } 5 '[ 3 _ / ] map"
+ "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
+ "{ 10 20 30 } [ 3 5 / ] map"
+}
+"Occurrences of " { $link POSTPONE: @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"
+{ $code
+ "{ 10 20 30 } [ sq ] '[ @ . ] each"
+ "{ 10 20 30 } [ sq ] [ call . ] curry each"
+ "{ 10 20 30 } [ sq ] [ . ] compose each"
+ "{ 10 20 30 } [ sq . ] each"
+}
+"The " { $link POSTPONE: _ } " and " { $link POSTPONE: @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
+{ $code
+ "{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
+ "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
+ "{ 8 13 14 27 } [ even? dup 5 ? ] map"
+}
+"The following is a no-op:"
+{ $code "'[ @ ]" }
+"Here are some built-in combinators rewritten in terms of fried quotations:"
+{ $table
+ { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
+ { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
+ { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
+} ;
+
+ARTICLE: "fry.philosophy" "Fried quotation philosophy"
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
+{ $code
+ "'[ [ _ key? ] all? ] filter"
+ "[ [ key? ] curry all? ] curry filter"
+}
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
+{ $code
+ "'[ 3 _ + 4 _ / ]"
+ "[| a b | 3 a + 4 b / ]"
+} ;
+
+ARTICLE: "fry" "Fried quotations"
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
+$nl
+"Fried quotations are started by a special parsing word:"
+{ $subsections POSTPONE: '[ }
+"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
+{ $subsections
+ POSTPONE: _
+ POSTPONE: @
+}
+"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
+{ $subsections
+ "fry.examples"
+ "fry.philosophy"
+}
+"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link POSTPONE: _ } " and " { $link POSTPONE: @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
+$nl
+"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
+{ $subsections fry }
+"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
+
+ABOUT: "fry"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry tools.test math prettyprint kernel io arrays
+sequences eval accessors ;
+IN: fry.tests
+
+SYMBOLS: a b c d e f g h ;
+
+{ [ ] } [ '[ ] ] unit-test
+{ [ + ] } [ '[ + ] ] unit-test
+{ [ 1 ] } [ 1 '[ _ ] ] unit-test
+{ [ 1 ] } [ [ 1 ] '[ @ ] ] unit-test
+{ [ 1 2 ] } [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test
+
+{ [ 1 2 a ] } [ 1 2 '[ _ _ a ] ] unit-test
+{ [ 1 2 ] } [ 1 2 '[ _ _ ] ] unit-test
+{ [ a 1 2 ] } [ 1 2 '[ a _ _ ] ] unit-test
+{ [ 1 2 a ] } [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test
+{ [ 1 a 2 b ] } [ 1 2 '[ _ a _ b ] ] unit-test
+{ [ 1 a 2 b ] } [ 1 [ 2 ] '[ _ a @ b ] ] unit-test
+{ [ a 1 b ] } [ 1 '[ a _ b ] ] unit-test
+
+{ [ a 1 b ] } [ [ 1 ] '[ a @ b ] ] unit-test
+{ [ a 1 2 ] } [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test
+
+{ [ a [ 1 ] b ] } [ 1 '[ a [ _ ] b ] ] unit-test
+{ [ a 1 b [ c 2 d ] e 3 f ] } [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test
+{ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] } [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test
+{ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] } [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test
+
+{ [ 3 + ] } [ 3 '[ _ + ] ] unit-test
+
+{ [ 1 3 + ] } [ 1 3 '[ _ _ + ] ] unit-test
+
+{ [ 1 + ] } [ 1 [ + ] '[ _ @ ] ] unit-test
+
+{ [ 1 + . ] } [ 1 [ + ] '[ _ @ . ] ] unit-test
+
+{ [ + - ] } [ [ + ] [ - ] '[ @ @ ] ] unit-test
+
+{ [ "a" write "b" print ] }
+[ "a" "b" '[ _ write _ print ] ] unit-test
+
+{ 1/2 } [
+ 1 '[ [ _ ] dip / ] 2 swap call
+] unit-test
+
+{ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } } [
+ 1 '[ [ _ ] 2dip 3array ]
+ { "a" "b" "c" } { "A" "B" "C" } rot 2map
+] unit-test
+
+{ { { 1 "a" } { 1 "b" } { 1 "c" } } } [
+ '[ [ 1 ] dip 2array ]
+ { "a" "b" "c" } swap map
+] unit-test
+
+{ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } } [
+ 1 2 '[ [ _ ] dip _ 3array ]
+ { "a" "b" "c" } swap map
+] unit-test
+
+: funny-dip ( obj quot -- ) '[ [ @ ] dip ] call ; inline
+
+{ "hi" 3 } [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+{ { 1 2 3 } } [
+ 3 1 '[ _ <iota> [ _ + ] map ] call
+] unit-test
+
+{ { 1 { 2 { 3 } } } } [
+ 1 2 3 '[ _ [ _ [ _ 1array ] call 2array ] call 2array ] call
+] unit-test
+
+{ 1 1 } [ '[ [ [ _ ] ] ] ] must-infer-as
+
+{ { { { 3 } } } } [
+ 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
+] unit-test
+
+{ { { { 3 } } } } [
+ 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
+[ error>> >r/r>-in-fry-error? ] must-fail-with
+
+{ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } } [
+ 1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
+] unit-test
+
+{ { 1 [ 2 { 3 4 } ] } } [ 1 2 3 4 '{ _ [ _ { _ _ } ] } ] unit-test
+{ H{ { 1 1 } { 2 2 } { 3 4 } } } [ 1 2 3 4 'H{ { 1 _ } { _ 2 } { _ _ } } ] unit-test
+{ HS{ 1 [ 2 { 3 } ] } } [ 1 2 3 'HS{ _ [ _ { _ } ] } ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes combinators generic kernel
+locals.backend math quotations sequences sequences.private sets
+splitting vectors words ;
+IN: fry
+
+ERROR: not-in-a-fry ;
+
+SYMBOL: in-fry?
+
+ERROR: >r/r>-in-fry-error ;
+
+GENERIC: fry ( object -- quot )
+
+<PRIVATE
+
+: check-fry ( quot -- quot )
+ dup { load-local load-locals get-local drop-locals } intersect
+ [ >r/r>-in-fry-error ] unless-empty ;
+
+PREDICATE: fry-specifier < word { POSTPONE: _ POSTPONE: @ } member-eq? ;
+
+GENERIC: count-inputs ( quot -- n )
+
+M: sequence count-inputs [ count-inputs ] map-sum ;
+M: fry-specifier count-inputs drop 1 ;
+M: object count-inputs drop 0 ;
+
+MIXIN: fried
+PREDICATE: fried-sequence < sequence count-inputs 0 > ;
+INSTANCE: fried-sequence fried
+
+: (ncurry) ( quot n -- quot )
+ {
+ { 0 [ ] }
+ { 1 [ \ curry suffix! ] }
+ { 2 [ \ 2curry suffix! ] }
+ { 3 [ \ 3curry suffix! ] }
+ [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
+ } case ;
+
+: wrap-non-callable ( obj -- quot )
+ dup callable? [ ] [ [ call ] curry ] if ; inline
+
+: [ncurry] ( n -- quot )
+ [ V{ } clone ] dip (ncurry) >quotation ;
+
+: [ndip] ( quot n -- quot' )
+ {
+ { 0 [ wrap-non-callable ] }
+ { 1 [ \ dip [ ] 2sequence ] }
+ { 2 [ \ 2dip [ ] 2sequence ] }
+ { 3 [ \ 3dip [ ] 2sequence ] }
+ [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
+ } case ;
+
+: (make-curry) ( tail quot -- quot' )
+ swap [ncurry] curry [ compose ] compose ;
+
+: make-compose ( consecutive quot -- consecutive quot' )
+ [
+ [ [ ] ]
+ [ [ncurry] ] if-zero
+ ] [
+ [ [ compose ] ]
+ [ [ compose compose ] curry ] if-empty
+ ] bi* compose
+ 0 swap ;
+
+: make-curry ( consecutive quot -- consecutive' quot' )
+ [ 1 + ] dip
+ [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
+
+: convert-curry ( consecutive quot -- consecutive' quot' )
+ [ [ ] make-curry ] [
+ dup first \ @ =
+ [ rest >quotation make-compose ]
+ [ >quotation make-curry ] if
+ ] if-empty ;
+
+: prune-curries ( seq -- seq' )
+ dup [ empty? not ] find
+ [ [ 1 + tail ] dip but-last prefix ]
+ [ 2drop { } ] if* ;
+
+: convert-curries ( seq -- tail seq' )
+ unclip-slice [ 0 swap [ convert-curry ] map ] dip
+ [ prune-curries ] [ >quotation 1quotation prefix ] if-empty ;
+
+: mark-composes ( quot -- quot' )
+ [
+ dup \ @ = [
+ drop [ POSTPONE: _ POSTPONE: @ ]
+ ] [
+ 1quotation
+ ] if
+ ] map concat ; inline
+
+: shallow-fry ( quot -- quot' )
+ check-fry mark-composes
+ { POSTPONE: _ } split convert-curries
+ [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
+ [ shallow-spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
+
+TUPLE: dredge-fry-state
+ { in-quot sequence read-only }
+ { prequot vector read-only }
+ { quot vector read-only } ;
+
+: <dredge-fry> ( quot -- dredge-fry )
+ V{ } clone V{ } clone dredge-fry-state boa ; inline
+
+: in-quot-slices ( n i state -- head tail )
+ in-quot>> [ <slice> ] [ nipd swap 1 + tail-slice ] 3bi ; inline
+
+: push-head-slice ( head state -- )
+ quot>> [ push-all ] [ \ _ swap push ] bi ; inline
+
+: push-subquot ( tail elt state -- )
+ [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
+
+DEFER: dredge-fry
+
+: dredge-fry-subquot ( n state i elt -- )
+ rot {
+ [ nip in-quot-slices ] ! head tail i elt state
+ [ [ 2drop swap ] dip push-head-slice ]
+ [ nipd push-subquot ]
+ [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
+ } 3cleave ; inline recursive
+
+: dredge-fry-simple ( n state -- )
+ [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
+
+: dredge-fry ( n dredge-fry -- )
+ 2dup in-quot>> [ fried? ] find-from
+ [ dredge-fry-subquot ]
+ [ drop dredge-fry-simple ] if* ; inline recursive
+
+! We can't use n*quot, narray and firstn from generalizations because
+! they're macros, and macros use memoize!
+: (n*quot) ( n quot -- quotquot )
+ <repetition> [ ] concat-as ;
+
+: [nsequence] ( length exemplar -- quot )
+ [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
+ [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
+ [ nip ] 3append ;
+
+PRIVATE>
+
+M: callable fry
+ [ [ [ ] ] ] [
+ <dredge-fry>
+ [ 0 swap dredge-fry ]
+ [ prequot>> >quotation ]
+ [ quot>> >quotation shallow-fry ] tri append
+ ] if-empty ;
+
+M: sequence fry
+ [ 0 swap new-sequence ] keep
+ [ 1quotation ] [
+ <dredge-fry>
+ [ 0 swap dredge-fry ]
+ [ prequot>> >quotation ]
+ [ quot>> >quotation shallow-fry ]
+ tri rot [ like ] curry 3append
+ ] if-empty ;
--- /dev/null
+Syntax for pictured partial application and composition
--- /dev/null
+extensions
hashtables hashtables.identity io.pathnames kernel lexer
locals.errors locals.parser macros math memoize namespaces
parser quotations sbufs sequences slots source-files splitting
-strings strings.parser strings.parser.private vectors vocabs
-vocabs.parser words words.alias words.constant words.symbol ;
+strings strings.parser vectors vocabs.parser words words.alias
+words.constant words.symbol ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
t in-fry? [ parse-quotation ] with-variable fry append!
] define-core-syntax
+ "'{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry append!
+ ] define-core-syntax
+
+ "'HS{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry
+ [ >hash-set ] compose append!
+ ] define-core-syntax
+
+ "'H{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry
+ [ parse-hashtable ] compose append!
+ ] define-core-syntax
+
"_" [
- in-fry? get [ \ syntax:_ suffix! ] [ not-in-a-fry ] if
+ in-fry? get [ \ _ suffix! ] [ not-in-a-fry ] if
] define-core-syntax
"@" [
- in-fry? get [ \ syntax:@ suffix! ] [ not-in-a-fry ] if
+ in-fry? get [ \ @ suffix! ] [ not-in-a-fry ] if
] define-core-syntax
"MACRO:" [ (:) define-macro ] define-core-syntax
projects / factor.git / commitdiff