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 make qualified words ;
   5 QUALIFIED: make
   6 IN: fry
   7
   8 : , ( -- * ) "Only valid inside a fry" throw ;
   9 : @ ( -- * ) "Only valid inside a fry" throw ;
  10
  11 <PRIVATE
  12
  13 DEFER: (shallow-fry)
  14 DEFER: shallow-fry
  15
  16 : ((shallow-fry)) ( accum quot adder -- result )
  17     >r shallow-fry r>
  18     append swap [
  19         [ prepose ] curry append
  20     ] unless-empty ; inline
  21
  22 : (shallow-fry) ( accum quot -- result )
  23     [ 1quotation ] [
  24         unclip {
  25             { \ , [ [ curry ] ((shallow-fry)) ] }
  26             { \ @ [ [ compose ] ((shallow-fry)) ] }
  27
  28             ! to avoid confusion, remove if fry goes core
  29             { \ make:, [ [ curry ] ((shallow-fry)) ] }
  30
  31             [ swap >r suffix r> (shallow-fry) ]
  32         } case
  33     ] if-empty ;
  34
  35 : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
  36
  37 PREDICATE: fry-specifier < word { , make:, @ } memq? ;
  38
  39 GENERIC: count-inputs ( quot -- n )
  40
  41 M: callable count-inputs [ count-inputs ] sigma ;
  42 M: fry-specifier count-inputs drop 1 ;
  43 M: object count-inputs drop 0 ;
  44
  45 PRIVATE>
  46
  47 : fry ( quot -- quot' )
  48     [
  49         [
  50             dup callable? [
  51                 [ count-inputs \ , <repetition> % ] [ fry % ] bi
  52             ] [ make:, ] if
  53         ] each
  54     ] [ ] make shallow-fry ;
  55
  56 : '[ \ ] parse-until fry over push-all ; parsing