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