extra/fry2/fry2.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit combinators.smart fry generalizations
   5 kernel lexer make math math.order multiline namespaces parser
   6 prettyprint quotations sequences sequences.deep
   7 sequences.private sets sorting.slots splitting
   8 splitting.monotonic strings.parser ;
   9 IN: fry2
  10
  11 MACRO: nswapd ( ndown1 ndown2 dip -- quot )
  12     [ 2dup < [ swap ] when
  13     [ [ - ] keep ] [  ] 2bi ] dip
  14     '[ [ _ _  -nrotd _ _ nrotd ] _ ndip ] ;
  15
  16
  17
  18 TUPLE: local name mutable? ;
  19
  20 : <local> ( name -- local )
  21     local new
  22         swap "!" ?tail
  23         [ >>name ] dip
  24         [ >>mutable? ] when* ; inline
  25
  26 TUPLE: fry-quot seq ;
  27 INSTANCE: fry-quot immutable-sequence
  28
  29 : <fry-quot> ( seq -- fry-quot )
  30     fry-quot new
  31         swap >>seq ; inline
  32
  33 M: fry-quot length seq>> length ;
  34 M: fry-quot nth-unsafe seq>> nth-unsafe ;
  35
  36 : find-locals ( seq -- hash )
  37     [ local? ] deep-filter members
  38     { { name>> >=< } } sort-by zip-index reverse ;
  39
  40 DEFER: fry2
  41 DEFER: fry3
  42 <<
  43 SYNTAX: FRY[ parse-quotation <fry-quot> fry >quotation append! ;
  44 SYNTAX: FRY2[ parse-quotation <fry-quot> fry2 append! ;
  45 ! SYNTAX: LFRY[ parse-quotation <fry-quot> fry3 append! ;
  46 SYNTAX: L" lexer get skip-blank parse-string <local> suffix! ;
  47 >>
  48
  49 : split-fry ( quot -- seq )
  50     [
  51         [ { _ @ } member? ] bi@
  52         2array { { t f } { f f } } member?
  53     ] monotonic-split ;
  54
  55 : trim-fry ( seq -- quot )
  56     [
  57         dup ?first \ _ = [
  58             unclip drop >quotation '[ _ curry ]
  59         ] [
  60             dup ?first \ @ = [
  61                 unclip drop >quotation '[ B _ compose ] ! B '[ call @ ]
  62             ] [
  63                ! B
  64             ] if
  65         ] if
  66     ] map [ >quotation ] map dup .
  67
  68     '[ [ _ spread ] [ ] output>sequence concat ] ; inline
  69
  70 : fry2 ( quot -- quot' ) split-fry trim-fry ; inline
  71
  72 DEFER: convert-locals
  73
  74 ! : fry3 ( quot -- quot' )
  75 !     [ find-locals ] keep
  76 !     [ convert-locals call ] keep
  77 !     [ dup local? [ drop \ _ ] when ] map split-fry trim-fry ; inline
  78
  79 :: convert-locals ( locals quot -- quot' )
  80     locals assoc-size :> size
  81     [
  82         size quot [
  83             {
  84                 { [ dup \ _ = ] [ drop 1 - [ ] , ] }
  85                 ! { [ dup \ @ = ] [ drop "omg" throw 1 - [ ] , ] }
  86                 { [ dup local? ] [
  87                     [ locals at dup size swap - swap [ + ] dip '[ 1 _ _ mntuckd ] , ] keepd
  88                 ] }
  89                 ! { [ dup fry-quot? ] [
  90                 !     B
  91                 !     ! size '[ _ 1 1 noverd ] ,
  92                 !     ! [ locals ] dip  '[ _ _ convert-locals fry ] ,
  93                 !     [ locals ] dip convert-locals fry '[ _ ] , ! fry ,
  94                 !     ! size '[ _ ndrop ] ,
  95                 ! ] }
  96                 [ drop ]
  97             } cond
  98         ] each drop
  99         size '[ _ ndrop ] ,
 100     ] [ ] make concat ; inline