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

fix html.parser

db4
Doug Coleman 2009-04-11 12:11:00 -05:00
parent d88f4d9914
commit 9ac2214b62
1 changed files with 22 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
extra/html/parser/parser.factor
View File

@ -37,89 +37,89 @@ SYMBOL: tagstack
swap >>name swap >>name
swap >>text ; inline swap >>text ; inline
: (read-quote) ( state-parser ch -- string ) : (read-quote) ( sequence-parser ch -- string )
'[ [ current _ = ] take-until ] [ advance drop ] bi ; '[ [ current _ = ] take-until ] [ advance drop ] bi ;
: read-single-quote ( state-parser -- string ) : read-single-quote ( sequence-parser -- string )
CHAR: ' (read-quote) ; CHAR: ' (read-quote) ;
: read-double-quote ( state-parser -- string ) : read-double-quote ( sequence-parser -- string )
CHAR: " (read-quote) ; CHAR: " (read-quote) ;
: read-quote ( state-parser -- string ) : read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' = dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ; [ read-single-quote ] [ read-double-quote ] if ;
: read-key ( state-parser -- string ) : read-key ( sequence-parser -- string )
skip-whitespace skip-whitespace
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
: read-token ( state-parser -- string ) : read-token ( sequence-parser -- string )
[ current blank? ] take-until ; [ current blank? ] take-until ;
: read-value ( state-parser -- string ) : read-value ( sequence-parser -- string )
skip-whitespace skip-whitespace
dup current quote? [ read-quote ] [ read-token ] if dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ; [ blank? ] trim ;
: read-comment ( state-parser -- ) : read-comment ( sequence-parser -- )
"-->" take-until-sequence comment new-tag push-tag ; "-->" take-until-sequence comment new-tag push-tag ;
: read-dtd ( state-parser -- ) : read-dtd ( sequence-parser -- )
">" take-until-sequence dtd new-tag push-tag ; ">" take-until-sequence dtd new-tag push-tag ;
: read-bang ( state-parser -- ) : read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
[ advance advance read-comment ] [ read-dtd ] if ; [ advance advance read-comment ] [ read-dtd ] if ;
: read-tag ( state-parser -- string ) : read-tag ( sequence-parser -- string )
[ [ current "><" member? ] take-until ] [ [ current "><" member? ] take-until ]
[ dup current CHAR: < = [ advance ] unless drop ] bi ; [ dup current CHAR: < = [ advance ] unless drop ] bi ;
: read-until-< ( state-parser -- string ) : read-until-< ( sequence-parser -- string )
[ current CHAR: < = ] take-until ; [ current CHAR: < = ] take-until ;
: parse-text ( state-parser -- ) : parse-text ( sequence-parser -- )
read-until-< [ text new-tag push-tag ] unless-empty ; read-until-< [ text new-tag push-tag ] unless-empty ;
: parse-key/value ( state-parser -- key value ) : parse-key/value ( sequence-parser -- key value )
[ read-key >lower ] [ read-key >lower ]
[ skip-whitespace "=" take-sequence ] [ skip-whitespace "=" take-sequence ]
[ swap [ read-value ] [ drop dup ] if ] tri ; [ swap [ read-value ] [ drop dup ] if ] tri ;
: (parse-attributes) ( state-parser -- ) : (parse-attributes) ( sequence-parser -- )
skip-whitespace skip-whitespace
dup state-parse-end? [ dup sequence-parse-end? [
drop drop
] [ ] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi [ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ; ] if ;
: parse-attributes ( state-parser -- hashtable ) : parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ; [ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable ) : (parse-tag) ( string -- string' hashtable )
[ [
[ read-token >lower ] [ parse-attributes ] bi [ read-token >lower ] [ parse-attributes ] bi
] state-parse ; ] parse-sequence ;
: read-< ( state-parser -- string/f ) : read-< ( sequence-parser -- string/f )
advance dup current [ advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if CHAR: ! = [ read-bang f ] [ read-tag ] if
] [ ] [
drop f drop f
] if* ; ] if* ;
: parse-tag ( state-parser -- ) : parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ; read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
: (parse-html) ( state-parser -- ) : (parse-html) ( sequence-parser -- )
dup peek-next [ dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ; ] [ drop ] if ;
: tag-parse ( quot -- vector ) : tag-parse ( quot -- vector )
V{ } clone tagstack [ state-parse ] with-variable ; inline V{ } clone tagstack [ parse-sequence ] with-variable ; inline
PRIVATE> PRIVATE>