! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces make prettyprint quotations sequences splitting
-html.parser.state strings unicode.categories unicode.case ;
+USING: accessors combinators.short-circuit html.parser.utils
+kernel make math namespaces quoting sequences sequences.parser
+unicode ;
IN: html.parser
TUPLE: tag name attributes text closing? ;
SINGLETON: text
SINGLETON: dtd
SINGLETON: comment
+
+<PRIVATE
+
SYMBOL: tagstack
: push-tag ( tag -- )
: closing-tag? ( string -- ? )
[ f ]
- [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
+ [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
: make-tag ( string attribs -- tag )
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
-: make-text-tag ( string -- tag )
- tag new
- text >>name
- swap >>text ;
-
-: make-comment-tag ( string -- tag )
+: new-tag ( text name -- tag )
tag new
- comment >>name
- swap >>text ;
+ swap >>name
+ swap >>text ; inline
-: make-dtd-tag ( string -- tag )
- tag new
- dtd >>name
- swap >>text ;
+: (read-quote) ( sequence-parser ch -- string )
+ '[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: read-whitespace ( -- string )
- [ get-char blank? not ] take-until ;
+: read-single-quote ( sequence-parser -- string )
+ CHAR: ' (read-quote) ;
-: read-whitespace* ( -- ) read-whitespace drop ;
+: read-double-quote ( sequence-parser -- string )
+ CHAR: \" (read-quote) ;
-: read-token ( -- string )
- read-whitespace*
- [ get-char blank? ] take-until ;
+: read-quote ( sequence-parser -- string )
+ dup get+increment CHAR: ' =
+ [ read-single-quote ] [ read-double-quote ] if ;
-: read-single-quote ( -- string )
- [ get-char CHAR: ' = ] take-until ;
+: read-key ( sequence-parser -- string )
+ skip-whitespace
+ [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-double-quote ( -- string )
- [ get-char CHAR: " = ] take-until ;
+: read-token ( sequence-parser -- string )
+ [ current blank? ] take-until ;
-: read-quote ( -- string )
- get-char next CHAR: ' =
- [ read-single-quote ] [ read-double-quote ] if next ;
+: read-value ( sequence-parser -- string )
+ skip-whitespace
+ dup current quote? [ read-quote ] [ read-token ] if
+ [ blank? ] trim ;
-: read-key ( -- string )
- read-whitespace*
- [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
+: read-comment ( sequence-parser -- )
+ [ "-->" take-until-sequence comment new-tag push-tag ]
+ [ '[ _ advance drop ] 3 swap times ] bi ;
-: read-= ( -- )
- read-whitespace*
- [ get-char CHAR: = = ] take-until drop next ;
+: read-dtd ( sequence-parser -- )
+ [ ">" take-until-sequence dtd new-tag push-tag ]
+ [ advance drop ] bi ;
-: read-value ( -- string )
- read-whitespace*
- get-char quote? [ read-quote ] [ read-token ] if
- [ blank? ] trim ;
+: read-bang ( sequence-parser -- )
+ advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+ [ advance advance read-comment ] [ read-dtd ] if ;
-: read-comment ( -- )
- "-->" take-string make-comment-tag push-tag ;
+: read-tag ( sequence-parser -- string )
+ [
+ [ current "><" member? ] take-until
+ [ CHAR: / = ] trim-tail
+ ] [ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-dtd ( -- )
- ">" take-string make-dtd-tag push-tag ;
+: read-until-< ( sequence-parser -- string )
+ [ current CHAR: < = ] take-until ;
-: read-bang ( -- )
- next get-char CHAR: - = get-next CHAR: - = and [
- next next
- read-comment
- ] [
- read-dtd
- ] if ;
+: parse-text ( sequence-parser -- )
+ read-until-< [ text new-tag push-tag ] unless-empty ;
-: read-tag ( -- string )
- [ get-char CHAR: > = get-char CHAR: < = or ] take-until
- get-char CHAR: < = [ next ] unless ;
+: parse-key/value ( sequence-parser -- key value )
+ [ read-key >lower ]
+ [ skip-whitespace "=" take-sequence ]
+ [ swap [ read-value ] [ drop dup ] if ] tri ;
-: read-< ( -- string )
- next get-char CHAR: ! = [
- read-bang f
+: (parse-attributes) ( sequence-parser -- )
+ skip-whitespace
+ dup sequence-parse-end? [
+ drop
] [
- read-tag
+ [ parse-key/value swap ,, ] [ (parse-attributes) ] bi
] if ;
-: read-until-< ( -- string )
- [ get-char CHAR: < = ] take-until ;
+: parse-attributes ( sequence-parser -- hashtable )
+ [ (parse-attributes) ] H{ } make ;
-: parse-text ( -- )
- read-until-< [
- make-text-tag push-tag
- ] unless-empty ;
+: (parse-tag) ( string -- string' hashtable )
+ [
+ [ read-token >lower ] [ parse-attributes ] bi
+ ] parse-sequence ;
-: (parse-attributes) ( -- )
- read-whitespace*
- string-parse-end? [
- read-key >lower read-= read-value
- 2array , (parse-attributes)
- ] unless ;
+: read-< ( sequence-parser -- string/f )
+ advance dup current [
+ CHAR: ! = [ read-bang f ] [ read-tag ] if
+ ] [
+ drop f
+ ] if* ;
-: parse-attributes ( -- hashtable )
- [ (parse-attributes) ] { } make >hashtable ;
+: parse-tag ( sequence-parser -- )
+ read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-tag) ( string -- string' hashtable )
- [
- read-token >lower
- parse-attributes
- ] string-parse ;
-
-: parse-tag ( -- )
- read-< [
- (parse-tag) make-tag push-tag
- ] unless-empty ;
-
-: (parse-html) ( -- )
- get-next [
- parse-text
- parse-tag
- (parse-html)
- ] when ;
+: (parse-html) ( sequence-parser -- )
+ dup peek-next [
+ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
+ ] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ string-parse ] with-variable ;
+ V{ } clone tagstack [ parse-sequence ] with-variable ; inline
+
+PRIVATE>
: parse-html ( string -- vector )
[ (parse-html) tagstack get ] tag-parse ;
projects / factor.git / blobdiff