unmaintained/bake/bake.factor

   1
   2 USING: kernel parser namespaces sequences quotations arrays vectors splitting
   3        strings words math generalizations
   4        macros combinators.conditional newfx ;
   5
   6 IN: bake
   7
   8 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   9
  10 SYMBOL: ,
  11 SYMBOL: @
  12
  13 : comma? ( obj -- ? ) , = ;
  14 : atsym? ( obj -- ? ) @ = ;
  15
  16 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  17
  18 DEFER: [bake]
  19
  20 : broil-element ( obj -- quot )
  21     {
  22       { [ comma?    ] [ drop [ >r ]          ] }
  23       { [ f =       ] [ [ >r ] prefix-on     ] }
  24       { [ integer?  ] [ [ >r ] prefix-on     ] }
  25       { [ string?   ] [ [ >r ] prefix-on     ] }
  26       { [ sequence? ] [ [bake] [ >r ] append ] }
  27       { [ word?     ] [ literalize [ >r ] prefix-on ] }
  28       { [ drop t    ] [ [ >r ] prefix-on     ] }
  29     }
  30   1cond ;
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 : constructor ( seq -- quot )
  35     {
  36       { [ array? ]     [ length [ narray ] prefix-on ] }
  37 !      { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
  38       { [ quotation? ] [ length [ narray >quotation ] prefix-on ] }
  39       { [ vector? ]    [ length [ narray >vector    ] prefix-on ] }
  40     }
  41   1cond ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : [broil] ( seq -- quot )
  46     [ reverse [ broil-element ] map concat ]
  47     [ length  [ drop [ r> ]   ] map concat ]
  48     [ constructor ]
  49   tri append append
  50   >quotation ;
  51
  52 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  53
  54 SYMBOL: saved-sequence
  55
  56 : [connector] ( -- quot )
  57   saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
  58
  59 : [starter] ( -- quot )
  60   saved-sequence get
  61     {
  62       { [ quotation? ] [ drop [  [ ] ] ] }
  63       { [ array?     ] [ drop [  { } ] ] }
  64       { [ vector?    ] [ drop [ V{ } ] ] }
  65     }
  66   1cond ;
  67
  68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 : [simmer] ( seq -- quot )
  71
  72   dup saved-sequence set
  73
  74   { @ } split reverse
  75     [ [ [bake] [connector] append [ >r ] append ] map concat ]
  76     [ length [ drop [ r> ] [connector] append   ] map concat ]
  77   bi
  78
  79   >r 1 invert-index pluck r> ! remove the last append/compose
  80
  81   [starter] prepend
  82
  83   append ;
  84
  85 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  86
  87 : [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
  88
  89 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  90
  91 MACRO: bake ( seq -- quot ) [bake] ;
  92
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 :  `{ \ } [ >array     ] parse-literal \ bake parsed ; parsing
  96 : `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
  97 :  `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing