1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors circular combinators.short-circuit io kernel
4 math math.order sequences sequences.parser sequences.private
8 TUPLE: sequence-parser sequence n ;
10 : <sequence-parser> ( sequence -- sequence-parser )
15 :: with-sequence-parser
16 ( ..a sequence-parser quot: ( ..a parser -- ..b obj/f )
18 sequence-parser n>> :> n
19 sequence-parser quot call [
20 n sequence-parser n<< f
23 : offset ( sequence-parser offset -- obj/f )
25 [ n>> + ] [ sequence>> ?nth ] bi ; inline
27 : current ( sequence-parser -- obj/f ) 0 offset ; inline
29 : previous ( sequence-parser -- obj/f ) -1 offset ; inline
31 : peek-next ( sequence-parser -- obj/f ) 1 offset ; inline
33 : advance ( sequence-parser -- sequence-parser )
34 [ 1 + ] change-n ; inline
36 : consume ( sequence-parser -- obj/f )
37 [ current ] [ advance drop ] bi ; inline
39 : next ( sequence-parser -- obj/f )
40 [ advance drop ] [ current ] 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 )
67 } 3|| [ 3drop f ] [ <slice-unsafe> ] 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 growing-circular-push
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 ;
122 ( ..a sequence quot: ( ..a parser -- ..b ) -- ..b )
123 [ <sequence-parser> ] dip call ; inline
125 : take-integer ( sequence-parser -- n/f )
126 [ current digit? ] take-while ;
128 :: take-n ( sequence-parser n -- seq/f )
129 n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
130 sequence-parser take-rest
132 sequence-parser n>> dup n + sequence-parser sequence>> subseq
133 sequence-parser [ n + ] change-n drop
136 : sort-tokens ( seq -- seq' ) [ length ] inv-sort-by ;
138 : take-first-matching ( sequence-parser seq -- seq )
140 '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
142 : take-longest ( sequence-parser seq -- seq )
143 sort-tokens take-first-matching ;
145 : write-full ( sequence-parser -- ) sequence>> write ;
146 : write-rest ( sequence-parser -- ) take-rest write ;