extra/bake/bake.factor

   1
   2 USING: kernel parser namespaces quotations vectors strings
   3 sequences assocs tuples math combinators ;
   4
   5 IN: bake
   6
   7 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   8
   9 TUPLE: insert-quot expr ;
  10
  11 C: <insert-quot> insert-quot
  12
  13 : ,[ \ ] [ >quotation <insert-quot> ] parse-literal ; parsing
  14
  15 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  16
  17 TUPLE: splice-quot expr ;
  18
  19 C: <splice-quot> splice-quot
  20
  21 : %[ \ ] [ >quotation <splice-quot> ] parse-literal ; parsing
  22
  23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  24
  25 SYMBOL: exemplar
  26
  27 : reset-building ( -- ) 1024 <vector> building set ;
  28
  29 : save-exemplar ( seq -- seq ) dup exemplar set ;
  30
  31 : finish-baking ( -- seq ) building get exemplar get like ;
  32
  33 DEFER: bake
  34
  35 : bake-item ( item -- )
  36   { { [ dup \ , = ]        [ drop , ] }
  37     { [ dup \ % = ]        [ drop % ] }
  38     { [ dup insert-quot? ] [ insert-quot-expr call , ] }
  39     { [ dup splice-quot? ] [ splice-quot-expr call % ] }
  40     { [ dup integer? ]     [ , ] }
  41     { [ dup string? ]      [ , ] }
  42     { [ dup tuple? ]       [ tuple>array bake >tuple , ] }
  43     { [ dup assoc? ]       [ [ >alist bake ] keep assoc-like , ] }
  44     { [ dup sequence? ]    [ bake , ] }
  45     { [ t ]                [ , ] } }
  46   cond ;
  47
  48 : bake-items ( seq -- ) [ bake-item ] each ;
  49
  50 : bake ( seq -- seq )
  51   [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
  52