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 namespaces sequences
   5 unicode.case unicode.categories combinators.short-circuit
   6 quoting fry ;
   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 CHAR: / = ] [ peek CHAR: / = ] } 1|| ] 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 ( text name -- tag )
  34     tag new
  35         swap >>name
  36         swap >>text ; inline
  37
  38 : (read-quote) ( state-parser ch -- string )
  39     '[ [ current _ = ] take-until ] [ next drop ] bi ;
  40
  41 : read-single-quote ( state-parser -- string )
  42     CHAR: ' (read-quote) ;
  43
  44 : read-double-quote ( state-parser -- string )
  45     CHAR: " (read-quote) ;
  46
  47 : read-quote ( state-parser -- string )
  48     dup get+increment CHAR: ' =
  49     [ read-single-quote ] [ read-double-quote ] if ;
  50
  51 : read-key ( state-parser -- string )
  52     skip-whitespace
  53     [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
  54
  55 : read-= ( state-parser -- )
  56     skip-whitespace
  57     [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ;
  58
  59 : read-token ( state-parser -- string )
  60     [ current blank? ] take-until ;
  61
  62 : read-value ( state-parser -- string )
  63     skip-whitespace
  64     dup current quote? [ read-quote ] [ read-token ] if
  65     [ blank? ] trim ;
  66
  67 : read-comment ( state-parser -- )
  68     "-->" take-until-sequence comment new-tag push-tag ;
  69
  70 : read-dtd ( state-parser -- )
  71     ">" take-until-sequence dtd new-tag push-tag ;
  72
  73 : read-bang ( state-parser -- )
  74     next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
  75         next next
  76         read-comment
  77     ] [
  78         read-dtd
  79     ] if ;
  80
  81 : read-tag ( state-parser -- string )
  82     [ [ current "><" member? ] take-until ]
  83     [ dup current CHAR: < = [ next ] unless drop ] bi ;
  84
  85 : read-until-< ( state-parser -- string )
  86     [ current CHAR: < = ] take-until ;
  87
  88 : parse-text ( state-parser -- )
  89     read-until-< [ text new-tag push-tag ] unless-empty ;
  90
  91 : (parse-attributes) ( state-parser -- )
  92     skip-whitespace
  93     dup state-parse-end? [
  94         drop
  95     ] [
  96         [
  97             [ read-key >lower ] [ read-= ] [ read-value ] tri
  98             swap set
  99         ] keep (parse-attributes)
 100     ] if ;
 101
 102 : parse-attributes ( state-parser -- hashtable )
 103     [ (parse-attributes) ] H{ } make-assoc ;
 104
 105 : (parse-tag) ( string -- string' hashtable )
 106     [
 107         [ read-token >lower ] [ parse-attributes ] bi
 108     ] state-parse ;
 109
 110 : read-< ( state-parser -- string/f )
 111     next dup current [
 112         CHAR: ! = [ read-bang f ] [ read-tag ] if
 113     ] [
 114         drop f
 115     ] if* ;
 116
 117 : parse-tag ( state-parser -- )
 118     read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
 119
 120 : (parse-html) ( state-parser -- )
 121     dup peek-next [
 122         [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
 123     ] [ drop ] if ;
 124
 125 : tag-parse ( quot -- vector )
 126     V{ } clone tagstack [ state-parse ] with-variable ; inline
 127
 128 : parse-html ( string -- vector )
 129     [ (parse-html) tagstack get ] tag-parse ;