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