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