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