basis/fry/fry.factor

   1 ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences combinators parser splitting math
   4 quotations arrays namespaces qualified ;
   5 QUALIFIED: namespaces
   6 IN: fry
   7
   8 : , ( -- * ) "Only valid inside a fry" throw ;
   9 : @ ( -- * ) "Only valid inside a fry" throw ;
  10 : _ ( -- * ) "Only valid inside a fry" throw ;
  11
  12 DEFER: (shallow-fry)
  13 DEFER: shallow-fry
  14
  15 : ((shallow-fry)) ( accum quot adder -- result )
  16     >r shallow-fry r>
  17     append swap [
  18         [ prepose ] curry append
  19     ] unless-empty ; inline
  20
  21 : (shallow-fry) ( accum quot -- result )
  22     [
  23         1quotation
  24     ] [
  25         unclip {
  26             { \ , [ [ curry ] ((shallow-fry)) ] }
  27             { \ @ [ [ compose ] ((shallow-fry)) ] }
  28
  29             ! to avoid confusion, remove if fry goes core
  30             { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
  31
  32             [ swap >r suffix r> (shallow-fry) ]
  33         } case
  34     ] if-empty ;
  35
  36 : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
  37
  38 : deep-fry ( quot -- quot )
  39     { _ } last-split1 dup [
  40       shallow-fry [ >r ] rot
  41       deep-fry    [ [ dip ] curry r> compose ] 4array concat
  42     ] [
  43         drop shallow-fry
  44     ] if ;
  45
  46 : fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
  47
  48 : count-inputs ( quot -- n )
  49     [
  50         {
  51             { [ dup callable?      ] [ count-inputs ] }
  52             { [ dup fry-specifier? ] [ drop 1       ] }
  53                                      [ drop 0       ]
  54         } cond
  55     ] map sum ;
  56
  57 : fry ( quot -- quot' )
  58     [
  59         [
  60             dup callable? [
  61                 [ count-inputs \ , <repetition> % ] [ fry % ] bi
  62             ] [ namespaces:, ] if
  63         ] each
  64     ] [ ] make deep-fry ;
  65
  66 : '[ \ ] parse-until fry over push-all ; parsing