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 fry io
4 kernel locals math math.order sequences sorting.functor
5 sorting.slots unicode.categories ;
8 TUPLE: sequence-parser sequence n ;
10 : <sequence-parser> ( sequence -- sequence-parser )
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
21 : offset ( sequence-parser offset -- char/f )
23 [ n>> + ] [ sequence>> ?nth ] bi ; inline
25 : current ( sequence-parser -- char/f ) 0 offset ; inline
27 : previous ( sequence-parser -- char/f ) -1 offset ; inline
29 : peek-next ( sequence-parser -- char/f ) 1 offset ; inline
31 : advance ( sequence-parser -- sequence-parser )
32 [ 1 + ] change-n ; inline
34 : advance* ( sequence-parser -- )
37 : next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
39 : get+increment ( sequence-parser -- char/f )
40 [ current ] [ advance drop ] bi ; inline
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
48 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
50 : take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
51 over sequence-parse-end? [
56 [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
59 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
60 [ not ] compose take-until ; inline
62 : <safe-slice> ( from to seq -- slice/f )
65 [ [ drop ] 2dip length > ]
67 } 3|| [ 3drop f ] [ slice boa ] if ; inline
69 :: take-sequence ( sequence-parser sequence -- obj/f )
70 sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
71 <safe-slice> sequence sequence= [
73 sequence-parser [ sequence length + ] change-n drop
78 : take-sequence* ( sequence-parser sequence -- )
81 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
82 sequence-parser n>> :> saved
83 sequence length <growing-circular> :> growing
86 current growing push-growing-circular
87 sequence growing sequence=
89 growing sequence sequence= [
91 growing length 1- - head
92 sequence-parser [ growing length - 1 + ] change-n drop
93 ! sequence-parser advance drop
95 saved sequence-parser (>>n)
99 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
100 sequence-parser sequence take-until-sequence :> out
102 sequence-parser [ sequence length + ] change-n drop
105 : skip-whitespace ( sequence-parser -- sequence-parser )
106 [ [ current blank? not ] take-until drop ] keep ;
108 : skip-whitespace-eol ( sequence-parser -- sequence-parser )
109 [ [ current " \t\r" member? not ] take-until drop ] keep ;
111 : take-rest-slice ( sequence-parser -- sequence/f )
112 [ sequence>> ] [ n>> ] bi
113 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
115 : take-rest ( sequence-parser -- sequence )
116 [ take-rest-slice ] [ sequence>> like ] bi f like ;
118 : take-until-object ( sequence-parser obj -- sequence )
119 '[ current _ = ] take-until ;
121 : parse-sequence ( sequence quot -- )
122 [ <sequence-parser> ] dip call ; inline
124 : take-integer ( sequence-parser -- n/f )
125 [ current digit? ] take-while ;
127 :: take-n ( sequence-parser n -- seq/f )
128 n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
129 sequence-parser take-rest
131 sequence-parser n>> dup n + sequence-parser sequence>> subseq
132 sequence-parser [ n + ] change-n drop
135 << "length" [ length ] define-sorting >>
137 : sort-tokens ( seq -- seq' )
138 { length>=< <=> } sort-by ;
140 : take-first-matching ( sequence-parser seq -- seq )
142 '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
144 : take-longest ( sequence-parser seq -- seq )
145 sort-tokens take-first-matching ;
147 : write-full ( sequence-parser -- ) sequence>> write ;
148 : write-rest ( sequence-parser -- ) take-rest write ;