diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 987122f05c..da48cd2755 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,61 +1,65 @@ -USING: kernel parser namespaces quotations arrays vectors strings - sequences assocs classes.tuple math combinators ; +USING: kernel parser combinators sequences splitting quotations arrays macros + arrays.lib combinators.cleave newfx dns.util ; IN: bake ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: insert-quot expr ; - -C: insert-quot - -: ,[ \ ] [ >quotation ] parse-literal ; parsing +MACRO: 1cond ( tbl -- ) + [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map + [ cond ] prefix-on ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: splice-quot expr ; +SYMBOL: , +SYMBOL: @ -C: splice-quot - -: %[ \ ] [ >quotation ] parse-literal ; parsing +: comma? ( obj -- ? ) , = ; +: atsym? ( obj -- ? ) @ = ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ,u ( seq -- seq ) unclip building get push ; +DEFER: [bake-array] + +: broil-element ( obj -- quot ) + { + { [ comma? ] [ drop [ >r ] ] } + { [ array? ] [ [bake-array] [ >r ] append ] } + { [ drop t ] [ [ >r ] prefix-on ] } + } + 1cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: exemplar - -: reset-building ( -- ) 1024 building set ; - -: save-exemplar ( seq -- seq ) dup exemplar set ; - -: finish-baking ( -- seq ) building get exemplar get like ; - -DEFER: bake - -: bake-item ( item -- ) - { { [ dup \ , = ] [ drop , ] } - { [ dup \ % = ] [ drop % ] } - { [ dup \ ,u = ] [ drop ,u ] } - { [ dup insert-quot? ] [ insert-quot-expr call , ] } - { [ dup splice-quot? ] [ splice-quot-expr call % ] } - { [ dup integer? ] [ , ] } - { [ dup string? ] [ , ] } - { [ dup tuple? ] [ tuple>array bake >tuple , ] } - { [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] } - { [ dup sequence? ] [ bake , ] } - { [ t ] [ , ] } } - cond ; - -: bake-items ( seq -- ) [ bake-item ] each ; - -: bake ( seq -- seq ) - [ reset-building save-exemplar bake-items finish-baking ] with-scope ; +: [broil] ( array -- quot ) + [ reverse [ broil-element ] map concat ] + [ length [ drop [ r> ] ] map concat ] + [ length [ narray ] prefix-on ] + tri append append + >quotation ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing +: [simmer] ( array -- quot ) + { @ } split reverse + [ [ [bake-array] [ append ] append [ >r ] append ] map concat ] + [ length [ drop [ r> append ] ] map concat ] + bi + + >r 2 head* [ >r ] append r> ! remove the last append + + [ { } ] swap append + + append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ; + +MACRO: bake-array ( array -- quot ) [bake-array] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing \ No newline at end of file