factor: trim using lists

[factor.git] / extra / html / parser / parser.factor

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 61088d1b5e5a2dd16d7bf0fb8c6433717171f6e8..3b6db6aab3822d0a0f96f307a6e52b73f256a672 100644 (file)
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,17 +1,18 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
-html.parser.utils kernel make namespaces sequences
-unicode.case unicode.categories combinators.short-circuit
-quoting ;
+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 -- )
@@ -19,7 +20,7 @@ SYMBOL: tagstack
 
 : 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
@@ -30,103 +31,100 @@ SYMBOL: tagstack
 : make-tag ( string attribs -- tag )
     [ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
 
-: new-tag ( string type -- tag )
+: new-tag ( text name -- tag )
     tag new
         swap >>name
         swap >>text ; inline
 
-: make-text-tag ( string -- tag ) text new-tag ; inline
+: (read-quote) ( sequence-parser ch -- string )
+    '[ [ current _ = ] take-until ] [ advance drop ] bi ;
 
-: make-comment-tag ( string -- tag ) comment new-tag ; inline
+: read-single-quote ( sequence-parser -- string )
+    CHAR: ' (read-quote) ;
 
-: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
+: read-double-quote ( sequence-parser -- string )
+    CHAR: \" (read-quote) ;
 
-: read-single-quote ( state-parser -- string )
-    [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ;
-
-: read-double-quote ( state-parser -- string )
-    [ [ current CHAR: " = ] take-until ] [ next drop ] bi ;
-
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
     dup get+increment CHAR: ' =
     [ read-single-quote ] [ read-double-quote ] if ;
 
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
     skip-whitespace
     [ 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 ( sequence-parser -- string )
     [ current blank? ] take-until ;
 
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
     skip-whitespace
     dup current quote? [ read-quote ] [ read-token ] if
     [ blank? ] trim ;
 
-: read-comment ( state-parser -- )
-    "-->" take-until-sequence make-comment-tag push-tag ;
+: read-comment ( sequence-parser -- )
+    [ "-->" take-until-sequence comment new-tag push-tag ]
+    [ '[ _ advance drop ] 3 swap times ] bi ;
 
-: read-dtd ( state-parser -- )
-    ">" take-until-sequence make-dtd-tag push-tag ;
+: read-dtd ( sequence-parser -- )
+    [ ">" take-until-sequence dtd new-tag push-tag ]
+    [ advance drop ] bi ;
 
-: read-bang ( state-parser -- )
-    next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
-        next next
-        read-comment
-    ] [
-        read-dtd
-    ] if ;
+: read-bang ( sequence-parser -- )
+    advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+    [ advance advance read-comment ] [ read-dtd ] if ;
 
-: read-tag ( state-parser -- string )
-    [ [ current "><" member? ] take-until ]
-    [ dup current CHAR: < = [ next ] unless drop ] bi ;
+: read-tag ( sequence-parser -- string )
+    [
+        [ current "><" member? ] take-until
+        [ CHAR: / = ] trim-tail
+    ] [ dup current CHAR: < = [ advance ] unless drop ] bi ;
 
-: read-until-< ( state-parser -- string )
+: read-until-< ( sequence-parser -- string )
     [ current CHAR: < = ] take-until ;
 
-: parse-text ( state-parser -- )
-    read-until-< [ make-text-tag push-tag ] unless-empty ;
+: parse-text ( sequence-parser -- )
+    read-until-< [ text new-tag push-tag ] unless-empty ;
+
+: parse-key/value ( sequence-parser -- key value )
+    [ read-key >lower ]
+    [ skip-whitespace "=" take-sequence ]
+    [ swap [ read-value ] [ drop dup ] if ] tri ;
 
-: (parse-attributes) ( state-parser -- )
+: (parse-attributes) ( sequence-parser -- )
     skip-whitespace
-    dup state-parse-end? [
+    dup sequence-parse-end? [
         drop
     ] [
-        [
-            [ read-key >lower ] [ read-= ] [ read-value ] tri
-            2array ,
-        ] keep (parse-attributes)
+        [ parse-key/value swap ,, ] [ (parse-attributes) ] bi
     ] if ;
 
-: parse-attributes ( state-parser -- hashtable )
-    [ (parse-attributes) ] { } make >hashtable ;
+: parse-attributes ( sequence-parser -- hashtable )
+    [ (parse-attributes) ] H{ } make ;
 
 : (parse-tag) ( string -- string' hashtable )
     [
         [ read-token >lower ] [ parse-attributes ] bi
-    ] state-parse ;
+    ] parse-sequence ;
 
-: read-< ( state-parser -- string/f )
-    next dup current [
+: read-< ( sequence-parser -- string/f )
+    advance dup current [
         CHAR: ! = [ read-bang f ] [ read-tag ] if
     ] [
         drop f
     ] if* ;
 
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
     read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
 
-: (parse-html) ( state-parser -- )
+: (parse-html) ( sequence-parser -- )
     dup peek-next [
         [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
     ] [ drop ] if ;
 
 : tag-parse ( quot -- vector )
-    V{ } clone tagstack [ state-parse ] with-variable ; inline
+    V{ } clone tagstack [ parse-sequence ] with-variable ; inline
+
+PRIVATE>
 
 : parse-html ( string -- vector )
     [ (parse-html) tagstack get ] tag-parse ;