extra/html/parser/parser.factor

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