extra/html/parser/parser.factor

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