Merge branch 'master' of factorcode.org:/git/factor
commit
7e0f5be76b
|
@ -42,6 +42,19 @@ V{
|
||||||
}
|
}
|
||||||
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
V{
|
||||||
|
T{ tag f "a"
|
||||||
|
H{
|
||||||
|
{ "a" "pirsqd" }
|
||||||
|
{ "foo" "bar" }
|
||||||
|
{ "href" "http://factorcode.org/" }
|
||||||
|
{ "baz" "quux" }
|
||||||
|
{ "nofollow" f }
|
||||||
|
} f f }
|
||||||
|
}
|
||||||
|
] [ "<a href = \"http://factorcode.org/\" nofollow foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
V{
|
V{
|
||||||
T{ tag f "html" H{ } f f }
|
T{ tag f "html" H{ } f f }
|
||||||
|
|
|
@ -1,17 +1,19 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays hashtables html.parser.state
|
USING: accessors arrays hashtables html.parser.state
|
||||||
html.parser.utils kernel make namespaces sequences
|
html.parser.utils kernel namespaces sequences
|
||||||
unicode.case unicode.categories combinators.short-circuit
|
unicode.case unicode.categories combinators.short-circuit
|
||||||
quoting ;
|
quoting fry ;
|
||||||
IN: html.parser
|
IN: html.parser
|
||||||
|
|
||||||
|
|
||||||
TUPLE: tag name attributes text closing? ;
|
TUPLE: tag name attributes text closing? ;
|
||||||
|
|
||||||
SINGLETON: text
|
SINGLETON: text
|
||||||
SINGLETON: dtd
|
SINGLETON: dtd
|
||||||
SINGLETON: comment
|
SINGLETON: comment
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
SYMBOL: tagstack
|
SYMBOL: tagstack
|
||||||
|
|
||||||
: push-tag ( tag -- )
|
: push-tag ( tag -- )
|
||||||
|
@ -19,7 +21,7 @@ SYMBOL: tagstack
|
||||||
|
|
||||||
: closing-tag? ( string -- ? )
|
: closing-tag? ( string -- ? )
|
||||||
[ f ]
|
[ f ]
|
||||||
[ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
|
[ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
|
||||||
|
|
||||||
: <tag> ( name attributes closing? -- tag )
|
: <tag> ( name attributes closing? -- tag )
|
||||||
tag new
|
tag new
|
||||||
|
@ -30,22 +32,19 @@ SYMBOL: tagstack
|
||||||
: make-tag ( string attribs -- tag )
|
: make-tag ( string attribs -- tag )
|
||||||
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
|
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
|
||||||
|
|
||||||
: new-tag ( string type -- tag )
|
: new-tag ( text name -- tag )
|
||||||
tag new
|
tag new
|
||||||
swap >>name
|
swap >>name
|
||||||
swap >>text ; inline
|
swap >>text ; inline
|
||||||
|
|
||||||
: make-text-tag ( string -- tag ) text new-tag ; inline
|
: (read-quote) ( state-parser ch -- string )
|
||||||
|
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
|
||||||
: make-comment-tag ( string -- tag ) comment new-tag ; inline
|
|
||||||
|
|
||||||
: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
|
|
||||||
|
|
||||||
: read-single-quote ( state-parser -- string )
|
: read-single-quote ( state-parser -- string )
|
||||||
[ [ current CHAR: ' = ] take-until ] [ next drop ] bi ;
|
CHAR: ' (read-quote) ;
|
||||||
|
|
||||||
: read-double-quote ( state-parser -- string )
|
: read-double-quote ( state-parser -- string )
|
||||||
[ [ current CHAR: " = ] take-until ] [ next drop ] bi ;
|
CHAR: " (read-quote) ;
|
||||||
|
|
||||||
: read-quote ( state-parser -- string )
|
: read-quote ( state-parser -- string )
|
||||||
dup get+increment CHAR: ' =
|
dup get+increment CHAR: ' =
|
||||||
|
@ -55,10 +54,6 @@ SYMBOL: tagstack
|
||||||
skip-whitespace
|
skip-whitespace
|
||||||
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
||||||
|
|
||||||
: read-= ( state-parser -- )
|
|
||||||
skip-whitespace
|
|
||||||
[ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ;
|
|
||||||
|
|
||||||
: read-token ( state-parser -- string )
|
: read-token ( state-parser -- string )
|
||||||
[ current blank? ] take-until ;
|
[ current blank? ] take-until ;
|
||||||
|
|
||||||
|
@ -68,42 +63,40 @@ SYMBOL: tagstack
|
||||||
[ blank? ] trim ;
|
[ blank? ] trim ;
|
||||||
|
|
||||||
: read-comment ( state-parser -- )
|
: read-comment ( state-parser -- )
|
||||||
"-->" take-until-sequence make-comment-tag push-tag ;
|
"-->" take-until-sequence comment new-tag push-tag ;
|
||||||
|
|
||||||
: read-dtd ( state-parser -- )
|
: read-dtd ( state-parser -- )
|
||||||
">" take-until-sequence make-dtd-tag push-tag ;
|
">" take-until-sequence dtd new-tag push-tag ;
|
||||||
|
|
||||||
: read-bang ( state-parser -- )
|
: read-bang ( state-parser -- )
|
||||||
next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
|
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
|
||||||
next next
|
[ advance advance read-comment ] [ read-dtd ] if ;
|
||||||
read-comment
|
|
||||||
] [
|
|
||||||
read-dtd
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: read-tag ( state-parser -- string )
|
: read-tag ( state-parser -- string )
|
||||||
[ [ current "><" member? ] take-until ]
|
[ [ current "><" member? ] take-until ]
|
||||||
[ dup current CHAR: < = [ next ] unless drop ] bi ;
|
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
|
||||||
|
|
||||||
: read-until-< ( state-parser -- string )
|
: read-until-< ( state-parser -- string )
|
||||||
[ current CHAR: < = ] take-until ;
|
[ current CHAR: < = ] take-until ;
|
||||||
|
|
||||||
: parse-text ( state-parser -- )
|
: parse-text ( state-parser -- )
|
||||||
read-until-< [ make-text-tag push-tag ] unless-empty ;
|
read-until-< [ text new-tag push-tag ] unless-empty ;
|
||||||
|
|
||||||
|
: parse-key/value ( state-parser -- key value )
|
||||||
|
[ read-key >lower ]
|
||||||
|
[ skip-whitespace "=" take-sequence ]
|
||||||
|
[ swap [ read-value ] [ drop f ] if ] tri ;
|
||||||
|
|
||||||
: (parse-attributes) ( state-parser -- )
|
: (parse-attributes) ( state-parser -- )
|
||||||
skip-whitespace
|
skip-whitespace
|
||||||
dup state-parse-end? [
|
dup state-parse-end? [
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
[
|
[ parse-key/value swap set ] [ (parse-attributes) ] bi
|
||||||
[ read-key >lower ] [ read-= ] [ read-value ] tri
|
|
||||||
2array ,
|
|
||||||
] keep (parse-attributes)
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: parse-attributes ( state-parser -- hashtable )
|
: parse-attributes ( state-parser -- hashtable )
|
||||||
[ (parse-attributes) ] { } make >hashtable ;
|
[ (parse-attributes) ] H{ } make-assoc ;
|
||||||
|
|
||||||
: (parse-tag) ( string -- string' hashtable )
|
: (parse-tag) ( string -- string' hashtable )
|
||||||
[
|
[
|
||||||
|
@ -111,7 +104,7 @@ SYMBOL: tagstack
|
||||||
] state-parse ;
|
] state-parse ;
|
||||||
|
|
||||||
: read-< ( state-parser -- string/f )
|
: read-< ( state-parser -- string/f )
|
||||||
next dup current [
|
advance dup current [
|
||||||
CHAR: ! = [ read-bang f ] [ read-tag ] if
|
CHAR: ! = [ read-bang f ] [ read-tag ] if
|
||||||
] [
|
] [
|
||||||
drop f
|
drop f
|
||||||
|
@ -128,5 +121,7 @@ SYMBOL: tagstack
|
||||||
: tag-parse ( quot -- vector )
|
: tag-parse ( quot -- vector )
|
||||||
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: parse-html ( string -- vector )
|
: parse-html ( string -- vector )
|
||||||
[ (parse-html) tagstack get ] tag-parse ;
|
[ (parse-html) tagstack get ] tag-parse ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
: advance ( 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 ] [ advance 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 advance 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
|
||||||
|
@ -58,15 +67,15 @@ TUPLE: state-parser sequence n ;
|
||||||
] take-until :> found
|
] take-until :> found
|
||||||
found dup length
|
found dup length
|
||||||
growing length 1- - head
|
growing length 1- - head
|
||||||
state-parser next drop ;
|
state-parser advance 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 -- )
|
||||||
|
|
Loading…
Reference in New Issue