remove duplication, refactor html.parser to use new state parser

extra/html/parser/parser.factor

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

extra/html/parser/utils/utils-tests.factor

@@ -1,20 +1,13 @@
 USING: assocs combinators continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
-strings tools.test ;
+strings tools.test html.parser.utils quoting ;
-USING: html.parser.utils ;
 IN: html.parser.utils.tests
 
 [ "'Rome'" ] [ "Rome" single-quote ] unit-test
 [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
 [ "'Firenze'" ] [ "Firenze" quote ] unit-test
 [ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test
-[ f ] [ "" quoted? ] unit-test
-[ t ] [ "''" quoted? ] unit-test
-[ t ] [ "\"\"" quoted? ] unit-test
-[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
-[ t ] [ "'Circus Maximus'" quoted? ] unit-test
-[ f ] [ "Circus Maximus" quoted? ] unit-test
 [ "'Italy'" ] [ "Italy" ?quote ] unit-test
 [ "'Italy'" ] [ "'Italy'" ?quote ] unit-test
 [ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test

extra/html/parser/utils/utils.factor

@@ -3,16 +3,12 @@
 USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math namespaces prettyprint
 quotations sequences splitting html.parser.state strings
-combinators.short-circuit ;
+combinators.short-circuit quoting ;
 IN: html.parser.utils
 
-: string-parse-end? ( -- ? ) get-next not ;
-
 : trim1 ( seq ch -- newseq )
     [ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
 
-: quote? ( ch -- ? ) "'\"" member? ;
-
 : single-quote ( str -- newstr ) "'" dup surround ;
 
 : double-quote ( str -- newstr ) "\"" dup surround ;
@@ -21,14 +17,4 @@ IN: html.parser.utils
     CHAR: ' over member?
     [ double-quote ] [ single-quote ] if ;
 
-: quoted? ( str -- ? )
-    {
-        [ length 1 > ]
-        [ first quote? ]
-        [ [ first ] [ peek ] bi = ]
-    } 1&& ;
-
 : ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
-
-: unquote ( str -- newstr )
-    dup quoted? [ but-last-slice rest-slice >string ] when ;