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 : next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
  39
  40 : get+increment ( sequence-parser -- char/f )
  41     [ current ] [ advance drop ] bi ; inline
  42
  43 :: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
  44     sequence-parser current [
  45         sequence-parser quot call
  46         [ sequence-parser advance quot skip-until ] unless
  47     ] when ; inline recursive
  48
  49 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
  50
  51 : take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  52     over sequence-parse-end? [
  53         2drop f
  54     ] [
  55         [ drop n>> ]
  56         [ skip-until ]
  57         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
  58     ] if ; inline
  59
  60 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  61     [ not ] compose take-until ; inline
  62
  63 : <safe-slice> ( from to seq -- slice/f )
  64     3dup {
  65         [ 2drop 0 < ]
  66         [ [ drop ] 2dip length > ]
  67         [ drop > ]
  68     } 3|| [ 3drop f ] [ slice boa ] if ; inline
  69
  70 :: take-sequence ( sequence-parser sequence -- obj/f )
  71     sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
  72     <safe-slice> sequence sequence= [
  73         sequence
  74         sequence-parser [ sequence length + ] change-n drop
  75     ] [
  76         f
  77     ] if ;
  78
  79 : take-sequence* ( sequence-parser sequence -- )
  80     take-sequence drop ;
  81
  82 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
  83     sequence-parser n>> :> saved
  84     sequence length <growing-circular> :> growing
  85     sequence-parser
  86     [
  87         current growing push-growing-circular
  88         sequence growing sequence=
  89     ] take-until :> found
  90     growing sequence sequence= [
  91         found dup length
  92         growing length 1- - head
  93         sequence-parser [ growing length - 1 + ] change-n drop
  94         ! sequence-parser advance drop
  95     ] [
  96         saved sequence-parser (>>n)
  97         f
  98     ] if ;
  99
 100 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
 101     sequence-parser sequence take-until-sequence :> out
 102     out [
 103         sequence-parser [ sequence length + ] change-n drop
 104     ] when out ;
 105
 106 : skip-whitespace ( sequence-parser -- sequence-parser )
 107     [ [ current blank? not ] take-until drop ] keep ;
 108
 109 : skip-whitespace-eol ( sequence-parser -- sequence-parser )
 110     [ [ current " \t\r" member? not ] take-until drop ] keep ;
 111
 112 : take-c-comment ( sequence-parser -- seq/f )
 113     [
 114         dup "/*" take-sequence [
 115             "*/" take-until-sequence*
 116         ] [
 117             drop f
 118         ] if
 119     ] with-sequence-parser ;
 120
 121 : take-c++-comment ( sequence-parser -- seq/f )
 122     [
 123         dup "//" take-sequence [
 124             [
 125                 [
 126                     { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
 127                 ] take-until
 128             ] [
 129                 advance drop
 130             ] bi
 131         ] [
 132             drop f
 133         ] if
 134     ] with-sequence-parser ;
 135
 136 : skip-whitespace/comments ( sequence-parser -- sequence-parser )
 137     skip-whitespace-eol
 138     {
 139         { [ dup take-c-comment ] [ skip-whitespace/comments ] }
 140         { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
 141         [ ]
 142     } cond ;
 143
 144 : take-define-identifier ( sequence-parser -- string )
 145     skip-whitespace/comments
 146     [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
 147
 148 : take-rest-slice ( sequence-parser -- sequence/f )
 149     [ sequence>> ] [ n>> ] bi
 150     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 151
 152 : take-rest ( sequence-parser -- sequence )
 153     [ take-rest-slice ] [ sequence>> like ] bi f like ;
 154
 155 : take-until-object ( sequence-parser obj -- sequence )
 156     '[ current _ = ] take-until ;
 157
 158 : parse-sequence ( sequence quot -- )
 159     [ <sequence-parser> ] dip call ; inline
 160
 161 :: take-quoted-string ( sequence-parser escape-char quote-char -- string )
 162     sequence-parser n>> :> start-n
 163     sequence-parser advance
 164     [
 165         {
 166             [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
 167             [ current quote-char = not ]
 168         } 1||
 169     ] take-while :> string
 170     sequence-parser current quote-char = [
 171         sequence-parser advance* string
 172     ] [
 173         start-n sequence-parser (>>n) f
 174     ] if ;
 175
 176 : (take-token) ( sequence-parser -- string )
 177     skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
 178
 179 :: take-token* ( sequence-parser escape-char quote-char -- string/f )
 180     sequence-parser skip-whitespace
 181     dup current {
 182         { quote-char [ escape-char quote-char take-quoted-string ] }
 183         { f [ drop f ] }
 184         [ drop (take-token) ]
 185     } case ;
 186
 187 : take-token ( sequence-parser -- string/f )
 188     CHAR: \ CHAR: " take-token* ;
 189
 190 : take-integer ( sequence-parser -- n/f )
 191     [ current digit? ] take-while ;
 192
 193 :: take-n ( sequence-parser n -- seq/f )
 194     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
 195         sequence-parser take-rest
 196     ] [
 197         sequence-parser n>> dup n + sequence-parser sequence>> subseq
 198         sequence-parser [ n + ] change-n drop
 199     ] if ;
 200
 201 : c-identifier-begin? ( ch -- ? )
 202     CHAR: a CHAR: z [a,b]
 203     CHAR: A CHAR: Z [a,b]
 204     { CHAR: _ } 3append member? ;
 205
 206 : c-identifier-ch? ( ch -- ? )
 207     CHAR: a CHAR: z [a,b]
 208     CHAR: A CHAR: Z [a,b]
 209     CHAR: 0 CHAR: 9 [a,b]
 210     { CHAR: _ } 4 nappend member? ;
 211
 212 : (take-c-identifier) ( sequence-parser -- string/f )
 213     dup current c-identifier-begin? [
 214         [ current c-identifier-ch? ] take-while
 215     ] [
 216         drop f
 217     ] if ;
 218
 219 : take-c-identifier ( sequence-parser -- string/f )
 220     [ (take-c-identifier) ] with-sequence-parser ;
 221
 222 << "length" [ length ] define-sorting >>
 223
 224 : sort-tokens ( seq -- seq' )
 225     { length>=< <=> } sort-by ;
 226
 227 : take-first-matching ( sequence-parser seq -- seq )
 228     swap
 229     '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 230
 231
 232 : take-longest ( sequence-parser seq -- seq )
 233     sort-tokens take-first-matching ;
 234
 235 : take-c-integer ( sequence-parser -- string/f )
 236     [
 237         dup take-integer [
 238             swap
 239             { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
 240             take-longest [ append ] when*
 241         ] [
 242             drop f
 243         ] if*
 244     ] with-sequence-parser ;
 245
 246 CONSTANT: c-punctuators
 247     {
 248         "[" "]" "(" ")" "{" "}" "." "->"
 249         "++" "--" "&" "*" "+" "-" "~" "!"
 250         "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
 251         "?" ":" ";" "..."
 252         "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
 253         "," "#" "##"
 254         "<:" ":>" "<%" "%>" "%:" "%:%:"
 255     }
 256
 257 : take-c-punctuator ( sequence-parser -- string/f )
 258     c-punctuators take-longest ;
 259
 260 : write-full ( sequence-parser -- ) sequence>> write ;
 261 : write-rest ( sequence-parser -- ) take-rest write ;