extra/sequence-parser/sequence-parser.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces math kernel sequences accessors fry circular
   4 unicode.case unicode.categories locals combinators.short-circuit
   5 make combinators io splitting math.parser math.ranges
   6 generalizations sorting.functor math.order sorting.slots ;
   7 IN: sequence-parser
   8
   9 TUPLE: sequence-parser sequence n ;
  10
  11 : <sequence-parser> ( sequence -- sequence-parser )
  12     sequence-parser new
  13         swap >>sequence
  14         0 >>n ;
  15
  16 :: with-sequence-parser ( sequence-parser quot -- seq/f )
  17     sequence-parser n>> :> n
  18     sequence-parser quot call [
  19         n sequence-parser (>>n) f
  20     ] unless* ; inline
  21
  22 : offset  ( sequence-parser offset -- char/f )
  23     swap
  24     [ n>> + ] [ sequence>> ?nth ] bi ; inline
  25
  26 : current ( sequence-parser -- char/f ) 0 offset ; inline
  27
  28 : previous ( sequence-parser -- char/f ) -1 offset ; inline
  29
  30 : peek-next ( sequence-parser -- char/f ) 1 offset ; inline
  31
  32 : advance ( sequence-parser -- sequence-parser )
  33     [ 1 + ] change-n ; inline
  34
  35 : advance* ( sequence-parser -- )
  36     advance drop ; inline
  37
  38 : get+increment ( sequence-parser -- char/f )
  39     [ current ] [ advance drop ] bi ; inline
  40
  41 :: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
  42     sequence-parser current [
  43         sequence-parser quot call
  44         [ sequence-parser advance quot skip-until ] unless
  45     ] when ; inline recursive
  46
  47 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
  48
  49 : take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  50     over sequence-parse-end? [
  51         2drop f
  52     ] [
  53         [ drop n>> ]
  54         [ skip-until ]
  55         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
  56     ] if ; inline
  57
  58 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  59     [ not ] compose take-until ; inline
  60
  61 : <safe-slice> ( from to seq -- slice/f )
  62     3dup {
  63         [ 2drop 0 < ]
  64         [ [ drop ] 2dip length > ]
  65         [ drop > ]
  66     } 3|| [ 3drop f ] [ slice boa ] if ; inline
  67
  68 :: take-sequence ( sequence-parser sequence -- obj/f )
  69     sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
  70     <safe-slice> sequence sequence= [
  71         sequence
  72         sequence-parser [ sequence length + ] change-n drop
  73     ] [
  74         f
  75     ] if ;
  76
  77 : take-sequence* ( sequence-parser sequence -- )
  78     take-sequence drop ;
  79
  80 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
  81     sequence-parser n>> :> saved
  82     sequence length <growing-circular> :> growing
  83     sequence-parser
  84     [
  85         current growing push-growing-circular
  86         sequence growing sequence=
  87     ] take-until :> found
  88     growing sequence sequence= [
  89         found dup length
  90         growing length 1- - head
  91         sequence-parser [ growing length - 1 + ] change-n drop
  92         ! sequence-parser advance drop
  93     ] [
  94         saved sequence-parser (>>n)
  95         f
  96     ] if ;
  97
  98 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
  99     sequence-parser sequence take-until-sequence :> out
 100     out [
 101         sequence-parser [ sequence length + ] change-n drop
 102     ] when out ;
 103
 104 : skip-whitespace ( sequence-parser -- sequence-parser )
 105     [ [ current blank? not ] take-until drop ] keep ;
 106
 107 : take-rest-slice ( sequence-parser -- sequence/f )
 108     [ sequence>> ] [ n>> ] bi
 109     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 110
 111 : take-rest ( sequence-parser -- sequence )
 112     [ take-rest-slice ] [ sequence>> like ] bi ;
 113
 114 : take-until-object ( sequence-parser obj -- sequence )
 115     '[ current _ = ] take-until ;
 116
 117 : parse-sequence ( sequence quot -- )
 118     [ <sequence-parser> ] dip call ; inline
 119
 120 :: take-quoted-string ( sequence-parser escape-char quote-char -- string )
 121     sequence-parser n>> :> start-n
 122     sequence-parser advance
 123     [
 124         {
 125             [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
 126             [ current quote-char = not ]
 127         } 1||
 128     ] take-while :> string
 129     sequence-parser current quote-char = [
 130         sequence-parser advance* string
 131     ] [
 132         start-n sequence-parser (>>n) f
 133     ] if ;
 134
 135 : (take-token) ( sequence-parser -- string )
 136     skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
 137
 138 :: take-token* ( sequence-parser escape-char quote-char -- string/f )
 139     sequence-parser skip-whitespace
 140     dup current {
 141         { quote-char [ escape-char quote-char take-quoted-string ] }
 142         { f [ drop f ] }
 143         [ drop (take-token) ]
 144     } case ;
 145
 146 : take-token ( sequence-parser -- string/f )
 147     CHAR: \ CHAR: " take-token* ;
 148
 149 : take-integer ( sequence-parser -- n/f )
 150     [ current digit? ] take-while ;
 151
 152 :: take-n ( sequence-parser n -- seq/f )
 153     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
 154         f
 155     ] [
 156         sequence-parser n>> dup n + sequence-parser sequence>> subseq
 157         sequence-parser [ n + ] change-n drop
 158     ] if ;
 159
 160 : take-c-comment ( sequence-parser -- seq/f )
 161     [
 162         dup "/*" take-sequence [
 163             "*/" take-until-sequence*
 164         ] [
 165             drop f
 166         ] if
 167     ] with-sequence-parser ;
 168
 169 : take-c++-comment ( sequence-parser -- seq/f )
 170     [
 171         dup "//" take-sequence [
 172             [
 173                 [
 174                     { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
 175                 ] take-until
 176             ] [
 177                 advance drop
 178             ] bi
 179         ] [
 180             drop f
 181         ] if
 182     ] with-sequence-parser ;
 183
 184 : c-identifier-begin? ( ch -- ? )
 185     CHAR: a CHAR: z [a,b]
 186     CHAR: A CHAR: Z [a,b]
 187     { CHAR: _ } 3append member? ;
 188
 189 : c-identifier-ch? ( ch -- ? )
 190     CHAR: a CHAR: z [a,b]
 191     CHAR: A CHAR: Z [a,b]
 192     CHAR: 0 CHAR: 9 [a,b]
 193     { CHAR: _ } 4 nappend member? ;
 194
 195 : take-c-identifier ( state-parser -- string/f )
 196     [
 197         dup current c-identifier-begin? [
 198             [ current c-identifier-ch? ] take-while
 199         ] [
 200             drop f
 201         ] if
 202     ] with-sequence-parser ;
 203
 204 << "length" [ length ] define-sorting >>
 205
 206 : sort-tokens ( seq -- seq' )
 207     { length>=< <=> } sort-by ;
 208
 209 : take-first-matching ( state-parser seq -- seq )
 210     swap
 211     '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 212
 213
 214 : take-longest ( state-parser seq -- seq )
 215     sort-tokens take-first-matching ;
 216
 217 : take-c-integer ( state-parser -- string/f )
 218     [
 219         dup take-integer [
 220             swap
 221             { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
 222             take-longest [ append ] when*
 223         ] [
 224             drop f
 225         ] if*
 226     ] with-sequence-parser ;
 227
 228 : write-full ( sequence-parser -- ) sequence>> write ;
 229 : write-rest ( sequence-parser -- ) take-rest write ;