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 ;
   6 IN: sequence-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 : get+increment ( sequence-parser -- char/f )
  38     [ current ] [ advance drop ] bi ; inline
  39
  40 :: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
  41     sequence-parser current [
  42         sequence-parser quot call
  43         [ sequence-parser advance quot skip-until ] unless
  44     ] when ; inline recursive
  45
  46 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
  47
  48 : take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  49     over sequence-parse-end? [
  50         2drop f
  51     ] [
  52         [ drop n>> ]
  53         [ skip-until ]
  54         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
  55     ] if ; inline
  56
  57 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
  58     [ not ] compose take-until ; inline
  59
  60 : <safe-slice> ( from to seq -- slice/f )
  61     3dup {
  62         [ 2drop 0 < ]
  63         [ [ drop ] 2dip length > ]
  64         [ drop > ]
  65     } 3|| [ 3drop f ] [ slice boa ] if ; inline
  66
  67 :: take-sequence ( sequence-parser sequence -- obj/f )
  68     sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
  69     <safe-slice> sequence sequence= [
  70         sequence
  71         sequence-parser [ sequence length + ] change-n drop
  72     ] [
  73         f
  74     ] if ;
  75
  76 : take-sequence* ( sequence-parser sequence -- )
  77     take-sequence drop ;
  78
  79 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
  80     sequence-parser n>> :> saved
  81     sequence length <growing-circular> :> growing
  82     sequence-parser
  83     [
  84         current growing push-growing-circular
  85         sequence growing sequence=
  86     ] take-until :> found
  87     growing sequence sequence= [
  88         found dup length
  89         growing length 1- - head
  90         sequence-parser [ growing length - 1 + ] change-n drop
  91         ! sequence-parser advance drop
  92     ] [
  93         saved sequence-parser (>>n)
  94         f
  95     ] if ;
  96
  97 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
  98     sequence-parser sequence take-until-sequence :> out
  99     out [
 100         sequence-parser [ sequence length + ] change-n drop
 101     ] when out ;
 102
 103 : skip-whitespace ( sequence-parser -- sequence-parser )
 104     [ [ current blank? not ] take-until drop ] keep ;
 105
 106 : take-rest-slice ( sequence-parser -- sequence/f )
 107     [ sequence>> ] [ n>> ] bi
 108     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 109
 110 : take-rest ( sequence-parser -- sequence )
 111     [ take-rest-slice ] [ sequence>> like ] bi ;
 112
 113 : take-until-object ( sequence-parser obj -- sequence )
 114     '[ current _ = ] take-until ;
 115
 116 : parse-sequence ( sequence quot -- )
 117     [ <sequence-parser> ] dip call ; inline
 118
 119 :: take-quoted-string ( sequence-parser escape-char quote-char -- string )
 120     sequence-parser n>> :> start-n
 121     sequence-parser advance
 122     [
 123         {
 124             [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
 125             [ current quote-char = not ]
 126         } 1||
 127     ] take-while :> string
 128     sequence-parser current quote-char = [
 129         sequence-parser advance* string
 130     ] [
 131         start-n sequence-parser (>>n) f
 132     ] if ;
 133
 134 : (take-token) ( sequence-parser -- string )
 135     skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
 136
 137 :: take-token* ( sequence-parser escape-char quote-char -- string/f )
 138     sequence-parser skip-whitespace
 139     dup current {
 140         { quote-char [ escape-char quote-char take-quoted-string ] }
 141         { f [ drop f ] }
 142         [ drop (take-token) ]
 143     } case ;
 144
 145 : take-token ( sequence-parser -- string/f )
 146     CHAR: \ CHAR: " take-token* ;
 147
 148 : take-integer ( sequence-parser -- n/f )
 149     [ current digit? ] take-while string>number ;
 150
 151 :: take-n ( sequence-parser n -- seq/f )
 152     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
 153         f
 154     ] [
 155         sequence-parser n>> dup n + sequence-parser sequence>> subseq
 156         sequence-parser [ n + ] change-n drop
 157     ] if ;
 158
 159 : take-c-comment ( sequence-parser -- seq/f )
 160     [
 161         dup "/*" take-sequence [
 162             "*/" take-until-sequence*
 163         ] [
 164             drop f
 165         ] if
 166     ] with-sequence-parser ;
 167
 168 : write-full ( sequence-parser -- ) sequence>> write ;
 169 : write-rest ( sequence-parser -- ) take-rest write ;