basis/sequences/parser/parser.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors circular combinators.short-circuit io kernel
   4 math math.order sequences sequences.parser sequences.private
   5 sorting.functor sorting.slots unicode ;
   6 IN: sequences.parser
   7
   8 TUPLE: sequence-parser sequence n ;
   9
  10 : <sequence-parser> ( sequence -- sequence-parser )
  11     sequence-parser new
  12         swap >>sequence
  13         0 >>n ;
  14
  15 :: with-sequence-parser ( sequence-parser quot -- seq/f )
  16     sequence-parser n>> :> n
  17     sequence-parser quot call [
  18         n sequence-parser n<< f
  19     ] unless* ; inline
  20
  21 : offset  ( sequence-parser offset -- char/f )
  22     swap
  23     [ n>> + ] [ sequence>> ?nth ] bi ; inline
  24
  25 : current ( sequence-parser -- char/f ) 0 offset ; inline
  26
  27 : previous ( sequence-parser -- char/f ) -1 offset ; inline
  28
  29 : peek-next ( sequence-parser -- char/f ) 1 offset ; inline
  30
  31 : advance ( sequence-parser -- sequence-parser )
  32     [ 1 + ] change-n ; inline
  33
  34 : advance* ( sequence-parser -- )
  35     advance drop ; inline
  36
  37 : next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
  38
  39 : get+increment ( sequence-parser -- char/f )
  40     [ current ] [ advance drop ] bi ; inline
  41
  42 :: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... )
  43     sequence-parser current [
  44         sequence-parser quot call
  45         [ sequence-parser advance quot skip-until ] unless
  46     ] when ; inline recursive
  47
  48 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
  49
  50 : take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
  51     over sequence-parse-end? [
  52         2drop f
  53     ] [
  54         [ drop n>> ]
  55         [ skip-until ]
  56         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
  57     ] if ; inline
  58
  59 : take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
  60     [ not ] compose take-until ; inline
  61
  62 : <safe-slice> ( from to seq -- slice/f )
  63     3dup {
  64         [ 2drop 0 < ]
  65         [ nipd length > ]
  66         [ drop > ]
  67     } 3|| [ 3drop f ] [ <slice-unsafe> ] if ; inline
  68
  69 :: take-sequence ( sequence-parser sequence -- obj/f )
  70     sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
  71     <safe-slice> sequence sequence= [
  72         sequence
  73         sequence-parser [ sequence length + ] change-n drop
  74     ] [
  75         f
  76     ] if ;
  77
  78 : take-sequence* ( sequence-parser sequence -- )
  79     take-sequence drop ;
  80
  81 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
  82     sequence-parser n>> :> saved
  83     sequence length <growing-circular> :> growing
  84     sequence-parser
  85     [
  86         current growing growing-circular-push
  87         sequence growing sequence=
  88     ] take-until :> found
  89     growing sequence sequence= [
  90         found dup length
  91         growing length 1 - - head
  92         sequence-parser [ growing length - 1 + ] change-n drop
  93         ! sequence-parser advance drop
  94     ] [
  95         saved sequence-parser n<<
  96         f
  97     ] if ;
  98
  99 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
 100     sequence-parser sequence take-until-sequence :> out
 101     out [
 102         sequence-parser [ sequence length + ] change-n drop
 103     ] when out ;
 104
 105 : skip-whitespace ( sequence-parser -- sequence-parser )
 106     [ [ current blank? not ] take-until drop ] keep ;
 107
 108 : skip-whitespace-eol ( sequence-parser -- sequence-parser )
 109     [ [ current " \t\r" member? not ] take-until drop ] keep ;
 110
 111 : take-rest-slice ( sequence-parser -- sequence/f )
 112     [ sequence>> ] [ n>> ] bi
 113     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 114
 115 : take-rest ( sequence-parser -- sequence )
 116     [ take-rest-slice ] [ sequence>> like ] bi f like ;
 117
 118 : take-until-object ( sequence-parser obj -- sequence )
 119     '[ current _ = ] take-until ;
 120
 121 : parse-sequence ( sequence quot -- )
 122     [ <sequence-parser> ] dip call ; inline
 123
 124 : take-integer ( sequence-parser -- n/f )
 125     [ current digit? ] take-while ;
 126
 127 :: take-n ( sequence-parser n -- seq/f )
 128     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
 129         sequence-parser take-rest
 130     ] [
 131         sequence-parser n>> dup n + sequence-parser sequence>> subseq
 132         sequence-parser [ n + ] change-n drop
 133     ] if ;
 134
 135 << "length" [ length ] define-sorting >>
 136
 137 : sort-tokens ( seq -- seq' )
 138     { length>=< <=> } sort-by ;
 139
 140 : take-first-matching ( sequence-parser seq -- seq )
 141     swap
 142     '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 143
 144 : take-longest ( sequence-parser seq -- seq )
 145     sort-tokens take-first-matching ;
 146
 147 : write-full ( sequence-parser -- ) sequence>> write ;
 148 : write-rest ( sequence-parser -- ) take-rest write ;