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