steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

add take-sequence to state parser

db4
Doug Coleman 2009-04-01 12:44:06 -05:00
parent d82b8ba4eb
commit 7060a5905f
2 changed files with 42 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
extra/html/parser/state/state-tests.factor
View File

@ -34,3 +34,21 @@ IN: html.parser.state.tests
[ { 1 2 } ] [ { 1 2 } ]
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test [ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
[ "ab" ]
[ "abcd" <state-parser> "ab" take-sequence ] unit-test
[ f ]
[ "abcd" <state-parser> "lol" take-sequence ] unit-test
[ "ab" ]
[
"abcd" <state-parser>
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
] unit-test
[ "" ]
[ "abcd" <state-parser> "" take-sequence ] unit-test
[ "cd" ]
[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test

39
extra/html/parser/state/state.factor
View File

@ -12,32 +12,32 @@ TUPLE: state-parser sequence n ;
swap >>sequence swap >>sequence
0 >>n ; 0 >>n ;
: state-parser-nth ( n state -- char/f ) : state-parser-nth ( n state-parser -- char/f )
sequence>> ?nth ; inline sequence>> ?nth ; inline
: current ( state -- char/f ) : current ( state-parser -- char/f )
[ n>> ] keep state-parser-nth ; inline [ n>> ] keep state-parser-nth ; inline
: previous ( state -- char/f ) : previous ( state-parser -- char/f )
[ n>> 1 - ] keep state-parser-nth ; inline [ n>> 1 - ] keep state-parser-nth ; inline
: peek-next ( state -- char/f ) : peek-next ( state-parser -- char/f )
[ n>> 1 + ] keep state-parser-nth ; inline [ n>> 1 + ] keep state-parser-nth ; inline
: next ( state -- state ) : next ( state-parser -- state-parser )
[ 1 + ] change-n ; inline [ 1 + ] change-n ; inline
: get+increment ( state -- char/f ) : get+increment ( state-parser -- char/f )
[ current ] [ next drop ] bi ; inline [ current ] [ next drop ] bi ; inline
:: skip-until ( state quot: ( obj -- ? ) -- ) :: skip-until ( state-parser quot: ( obj -- ? ) -- )
state current [ state-parser current [
state quot call [ state next quot skip-until ] unless state-parser quot call [ state-parser next quot skip-until ] unless
] when ; inline recursive ] when ; inline recursive
: state-parse-end? ( state -- ? ) peek-next not ; : state-parse-end? ( state-parser -- ? ) peek-next not ;
: take-until ( state quot: ( obj -- ? ) -- sequence/f ) : take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
over state-parse-end? [ over state-parse-end? [
2drop f 2drop f
] [ ] [
@ -46,9 +46,18 @@ TUPLE: state-parser sequence n ;
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
] if ; inline ] if ; inline
: take-while ( state quot: ( obj -- ? ) -- sequence/f ) : take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
[ not ] compose take-until ; inline [ not ] compose take-until ; inline
:: take-sequence ( state-parser sequence -- obj/f )
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
sequence sequence= [
sequence
state-parser [ sequence length + ] change-n drop
] [
f
] if ;
:: take-until-sequence ( state-parser sequence -- sequence' ) :: take-until-sequence ( state-parser sequence -- sequence' )
sequence length <growing-circular> :> growing sequence length <growing-circular> :> growing
state-parser state-parser
@ -60,13 +69,13 @@ TUPLE: state-parser sequence n ;
growing length 1- - head growing length 1- - head
state-parser next drop ; state-parser next drop ;
: skip-whitespace ( state -- state ) : skip-whitespace ( state-parser -- state-parser )
[ [ current blank? not ] take-until drop ] keep ; [ [ current blank? not ] take-until drop ] keep ;
: take-rest ( state -- sequence ) : take-rest ( state-parser -- sequence )
[ drop f ] take-until ; inline [ drop f ] take-until ; inline
: take-until-object ( state obj -- sequence ) : take-until-object ( state-parser obj -- sequence )
'[ current _ = ] take-until ; '[ current _ = ] take-until ;
: state-parse ( sequence quot -- ) : state-parse ( sequence quot -- )