extra/browser/parser/parser.factor

   1 USING: arrays browser.utils hashtables io kernel namespaces
   2 prettyprint quotations
   3 sequences splitting state-parser strings ;
   4 USE: tools.interpreter
   5 IN: browser.parser
   6
   7 TUPLE: tag name attributes text matched? closing? ;
   8
   9 SYMBOL: text
  10 SYMBOL: dtd
  11 SYMBOL: comment
  12 SYMBOL: javascript
  13 SYMBOL: tagstack
  14
  15 : push-tag ( tag -- )
  16     tagstack get push ;
  17
  18 : closing-tag? ( string -- ? )
  19     dup empty? [
  20         drop f
  21     ] [
  22         dup first CHAR: / =
  23         swap peek CHAR: / = or
  24     ] if ;
  25
  26 : <tag> ( name attributes closing? -- tag )
  27     { set-tag-name set-tag-attributes set-tag-closing? }
  28     tag construct ;
  29
  30 : make-tag ( str attribs -- tag )
  31     >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
  32
  33 : make-text-tag ( str -- tag )
  34     T{ tag f text } clone [ set-tag-text ] keep ;
  35
  36 : make-comment-tag ( str -- tag )
  37     T{ tag f comment } clone [ set-tag-text ] keep ;
  38
  39 : make-dtd-tag ( str -- tag )
  40     T{ tag f dtd } clone [ set-tag-text ] keep ;
  41
  42 : read-whitespace ( -- str )
  43     [ get-char blank? not ] take-until ;
  44
  45 : read-whitespace* ( -- )
  46     read-whitespace drop ;
  47
  48 : read-token ( -- str )
  49     read-whitespace*
  50     [ get-char blank? ] take-until ;
  51
  52 : read-single-quote ( -- str )
  53     [ get-char CHAR: ' = ] take-until ;
  54
  55 : read-double-quote ( -- str )
  56     [ get-char CHAR: " = ] take-until ;
  57
  58 : read-quote ( -- str )
  59     get-char next* CHAR: ' = [
  60         read-single-quote
  61     ] [
  62         read-double-quote
  63     ] if next* ;
  64
  65 : read-key ( -- str )
  66     read-whitespace*
  67     [ get-char CHAR: = = get-char blank? or ] take-until ;
  68
  69 : read-= ( -- )
  70     read-whitespace*
  71     [ get-char CHAR: = = ] take-until drop next* ;
  72
  73 : read-value ( -- str )
  74     read-whitespace*
  75     get-char quote? [
  76         read-quote
  77     ] [
  78         read-token
  79     ] if ;
  80
  81 : read-comment ( -- )
  82     "-->" take-string* make-comment-tag push-tag ;
  83
  84 : read-dtd ( -- )
  85     ">" take-string* make-dtd-tag push-tag ;
  86
  87 : read-bang ( -- )
  88     next* get-char CHAR: - = get-next CHAR: - = and [
  89         next* next*
  90         read-comment
  91     ] [
  92         read-dtd
  93     ] if ;
  94
  95 : read-tag ( -- )
  96     [ get-char CHAR: > = get-char CHAR: < = or ] take-until
  97     get-char CHAR: < = [ next* ] unless ;
  98
  99 : read-< ( -- str )
 100     next* get-char CHAR: ! = [
 101         read-bang f
 102     ] [
 103         read-tag
 104     ] if ;
 105
 106 : read-until-< ( -- str )
 107     [ get-char CHAR: < = ] take-until ;
 108
 109 : parse-text ( -- )
 110     read-until-< dup empty? [
 111         drop
 112     ] [
 113         make-text-tag push-tag
 114     ] if ;
 115
 116 : (parse-attributes) ( -- )
 117     read-whitespace*
 118     string-parse-end? [
 119         read-key >lower read-= read-value
 120         2array , (parse-attributes)
 121     ] unless ;
 122
 123 : parse-attributes ( -- hashtable )
 124     [ (parse-attributes) ] { } make >hashtable ;
 125
 126 : (parse-tag)
 127     [
 128         read-token >lower
 129         parse-attributes
 130     ] string-parse ;
 131
 132 : parse-tag ( -- )
 133     read-< dup empty? [
 134         drop
 135     ] [
 136         (parse-tag) make-tag push-tag
 137     ] if ;
 138
 139 : (parse-html) ( tag -- )
 140     get-next [
 141         parse-text
 142         parse-tag
 143         (parse-html)
 144     ] when ;
 145
 146 : tag-parse ( quot -- vector )
 147     [
 148         V{ } clone tagstack set
 149         string-parse
 150     ] with-scope ;
 151
 152 : parse-html ( string -- vector )
 153     [
 154         (parse-html)
 155         tagstack get
 156     ] tag-parse ;