basis/html/parser/parser.factor

   1 USING: accessors arrays html.parser.utils hashtables io kernel
   2 namespaces prettyprint quotations
   3 sequences splitting state-parser strings unicode.categories unicode.case
   4 sequences.lib ;
   5 IN: html.parser
   6
   7 TUPLE: tag name attributes text closing? ;
   8
   9 SINGLETON: text
  10 SINGLETON: dtd
  11 SINGLETON: comment
  12 SYMBOL: tagstack
  13
  14 : push-tag ( tag -- )
  15     tagstack get push ;
  16
  17 : closing-tag? ( string -- ? )
  18     [ f ]
  19     [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
  20
  21 : <tag> ( name attributes closing? -- tag )
  22     tag new
  23         swap >>closing?
  24         swap >>attributes
  25         swap >>name ;
  26
  27 : make-tag ( string attribs -- tag )
  28     >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
  29
  30 : make-text-tag ( string -- tag )
  31     tag new
  32         text >>name
  33         swap >>text ;
  34
  35 : make-comment-tag ( string -- tag )
  36     tag new
  37         comment >>name
  38         swap >>text ;
  39
  40 : make-dtd-tag ( string -- tag )
  41     tag new
  42         dtd >>name
  43         swap >>text ;
  44
  45 : read-whitespace ( -- string )
  46     [ get-char blank? not ] take-until ;
  47
  48 : read-whitespace* ( -- ) read-whitespace drop ;
  49
  50 : read-token ( -- string )
  51     read-whitespace*
  52     [ get-char blank? ] take-until ;
  53
  54 : read-single-quote ( -- string )
  55     [ get-char CHAR: ' = ] take-until ;
  56
  57 : read-double-quote ( -- string )
  58     [ get-char CHAR: " = ] take-until ;
  59
  60 : read-quote ( -- string )
  61     get-char next* CHAR: ' =
  62     [ read-single-quote ] [ read-double-quote ] if next* ;
  63
  64 : read-key ( -- string )
  65     read-whitespace*
  66     [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
  67
  68 : read-= ( -- )
  69     read-whitespace*
  70     [ get-char CHAR: = = ] take-until drop next* ;
  71
  72 : read-value ( -- string )
  73     read-whitespace*
  74     get-char quote? [ read-quote ] [ read-token ] if
  75     [ blank? ] trim ;
  76
  77 : read-comment ( -- )
  78     "-->" take-string* make-comment-tag push-tag ;
  79
  80 : read-dtd ( -- )
  81     ">" take-string* make-dtd-tag push-tag ;
  82
  83 : read-bang ( -- )
  84     next* get-char CHAR: - = get-next CHAR: - = and [
  85         next* next*
  86         read-comment
  87     ] [
  88         read-dtd
  89     ] if ;
  90
  91 : read-tag ( -- string )
  92     [ get-char CHAR: > = get-char CHAR: < = or ] take-until
  93     get-char CHAR: < = [ next* ] unless ;
  94
  95 : read-< ( -- string )
  96     next* get-char CHAR: ! = [
  97         read-bang f
  98     ] [
  99         read-tag
 100     ] if ;
 101
 102 : read-until-< ( -- string )
 103     [ get-char CHAR: < = ] take-until ;
 104
 105 : parse-text ( -- )
 106     read-until-< dup empty? [
 107         drop
 108     ] [
 109         make-text-tag push-tag
 110     ] if ;
 111
 112 : (parse-attributes) ( -- )
 113     read-whitespace*
 114     string-parse-end? [
 115         read-key >lower read-= read-value
 116         2array , (parse-attributes)
 117     ] unless ;
 118
 119 : parse-attributes ( -- hashtable )
 120     [ (parse-attributes) ] { } make >hashtable ;
 121
 122 : (parse-tag) ( string -- string' hashtable )
 123     [
 124         read-token >lower
 125         parse-attributes
 126     ] string-parse ;
 127
 128 : parse-tag ( -- )
 129     read-< [
 130         (parse-tag) make-tag push-tag
 131     ] unless-empty ;
 132
 133 : (parse-html) ( -- )
 134     get-next [
 135         parse-text
 136         parse-tag
 137         (parse-html)
 138     ] when ;
 139
 140 : tag-parse ( quot -- vector )
 141     V{ } clone tagstack [ string-parse ] with-variable ;
 142
 143 : parse-html ( string -- vector )
 144     [ (parse-html) tagstack get ] tag-parse ;