extra/modern/html/html.factor

   1 ! Copyright (C) 2021 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit kernel make math modern modern.slices
   5 sequences sequences.extras shuffle combinators.extras splitting
   6 strings unicode ;
   7 IN: modern.html
   8
   9 TUPLE: tag open name props close children ;
  10
  11 TUPLE: processing-instruction open target props close ;
  12 : <processing-instruction> ( open target props close -- processing-instruction )
  13     processing-instruction new
  14         swap >>close
  15         swap >>props
  16         swap >>target
  17         swap >>open ; inline
  18
  19 TUPLE: embedded-language open payload close ;
  20 : <embedded-language> ( open payload close -- embedded-language )
  21     embedded-language new
  22         swap >>close
  23         swap >>payload
  24         swap >>open ; inline
  25
  26 TUPLE: doctype open close values ;
  27 : <doctype> ( open values close -- doctype )
  28     doctype new
  29         swap >string >>close
  30         swap >>values
  31         swap >string >>open ;
  32
  33 TUPLE: comment open payload close ;
  34 : <comment> ( open payload close -- comment )
  35     comment new
  36         swap >>close
  37         swap >>payload
  38         swap >>open ;
  39
  40 TUPLE: close-tag name ;
  41 : <close-tag> ( name -- tag )
  42     close-tag new
  43         swap >string rest rest but-last >>name ;
  44
  45 TUPLE: open-tag < tag close-tag ;
  46 : <open-tag> ( open name props close -- tag )
  47     open-tag new
  48         swap >>close
  49         swap >>props
  50         swap >string >>name
  51         swap >string >>open
  52         V{ } clone >>children ;
  53
  54 TUPLE: self-close-tag < tag ;
  55 : <self-close-tag> ( open name props close -- tag )
  56     self-close-tag new
  57         swap >>close
  58         swap >>props
  59         swap >string >>name
  60         swap >string >>open
  61         V{ } clone >>children ;
  62
  63 TUPLE: squote payload ;
  64 C: <squote> squote
  65 TUPLE: dquote payload ;
  66 C: <dquote> dquote
  67
  68 : advance-squote-payload ( n string -- n' string )
  69     over [
  70         { CHAR: \\ CHAR: ' } slice-til-separator-inclusive {
  71             { f [ to>> over string-expected-got-eof ] }
  72             { CHAR: ' [ drop ] }
  73             { CHAR: \\ [ drop take-char drop advance-squote-payload ] }
  74         } case
  75     ] [
  76         string-expected-got-eof
  77     ] if ;
  78
  79 :: read-string ( $n $string $char -- n' string payload )
  80     $n $string $char CHAR: ' =
  81     [ advance-squote-payload ]
  82     [ advance-dquote-payload ] if drop :> $n'
  83     $n' $string
  84     $n $n' 1 - $string <slice> ;
  85
  86 : take-tag-name ( n string -- n' string tag )
  87     [ "\s\r\n/>" member? ] slice-until ;
  88
  89 : read-value ( n string -- n' string value )
  90     skip-whitespace take-char {
  91         { CHAR: ' [ CHAR: ' read-string >string <squote> ] }
  92         { CHAR: " [ CHAR: " read-string >string <dquote> ] }
  93         { CHAR: [ [ "[" throw ] }
  94         { CHAR: { [ "{" throw ] }
  95         [ [ take-tag-name ] dip prefix ]
  96     } case ;
  97
  98 : read-prop ( n string -- n' string prop/f closing/f )
  99     skip-whitespace "\s\n\r\t\"'<=/>?" slice-til-either {
 100         { CHAR: < [ "< error" throw ] }
 101         { CHAR: = [ 1 split-slice-back drop >string [ read-value ] dip swap 2array f ] }
 102         { CHAR: / [ ">" expect-and-span 2 split-slice-back [ >string f like ] bi@ ] }
 103         { CHAR: > [ 1 split-slice-back [ >string f like ] bi@ ] }
 104         { CHAR: ' [ first read-string >string <squote> f ] }
 105         { CHAR: " [ first read-string >string <dquote> f ] }
 106         { CHAR: ? [ ">" expect-and-span >string f swap ] }
 107         { CHAR: \s [ >string f ] }
 108         { CHAR: \r [ >string f ] }
 109         { CHAR: \n [ >string f ] }
 110         { CHAR: \t [ >string f ] }
 111         { f [ "efff" throw ] }
 112     } case ;
 113
 114 : read-props* ( n string props -- n' string props closing )
 115     [ read-prop ] dip-2up [
 116         [ [ over push ] when* ] dip
 117     ] [
 118         [ over push ] when* read-props*
 119     ] if* ; inline recursive
 120
 121 : read-props ( n string -- n' string props closing )
 122     V{ } clone read-props* ;
 123
 124 : read-processing-instruction ( n string opening -- n string processing-instruction )
 125     "?" expect-and-span >string
 126     [ take-tag-name >string ] dip-1up
 127     [ read-props ] 2dip-2up
 128     <processing-instruction> ;
 129
 130 : read-doctype ( n string opening -- n string doctype/comment )
 131     "!" expect-and-span
 132     2over 2 peek-from "--" sequence= [
 133         "--" expect-and-span >string
 134         [ "-->" slice-til-string [ >string ] bi@ ] dip-2up <comment>
 135     ] [
 136         "DOCTYPE" expect-and-span-insensitive
 137         [ read-props ] dip-2up
 138         <doctype>
 139     ] if ;
 140
 141 : read-embedded-language ( n string opening -- n string embedded-language )
 142     "%" expect-and-span >string
 143     [ take-tag-name >string ] dip-1up append
 144     [ "%>" slice-til-string [ >string ] bi@ ] dip-2up
 145      <embedded-language> ;
 146
 147 : read-open-tag ( n string opening -- n' string tag )
 148     [ take-tag-name ] dip-1up
 149     [ read-props ] 2dip-2up
 150     dup ">" sequence= [
 151         <open-tag>
 152     ] [
 153         <self-close-tag>
 154     ] if ;
 155
 156 : read-close-tag ( n string opening -- n' string tag )
 157     "/" expect-and-span
 158     [ take-tag-name ] dip span-slices
 159     ">" expect-and-span
 160     <close-tag> ;
 161
 162 :: shorten* ( vector n -- seq )
 163     vector n tail
 164     n vector shorten ;
 165
 166 : unclosed-open-tag? ( obj -- ? )
 167     { [ open-tag? ] [ close-tag>> not ] } 1&& ; inline
 168
 169 ERROR: unmatched-open-tags-error stack seq ;
 170 : check-tag-stack ( stack -- stack )
 171     dup [ unclosed-open-tag? ] filter
 172     [ unmatched-open-tags-error ] unless-empty ;
 173
 174 ERROR: unmatched-closing-tag-error stack tag ;
 175 :: find-last-open-tag ( stack name -- seq )
 176     stack [ { [ unclosed-open-tag? ] [ name>> name = ] } 1&& ] find-last drop [
 177         stack swap shorten*
 178     ] [
 179         stack name unmatched-closing-tag-error
 180     ] if* ;
 181
 182 : lex-html ( stack n string -- stack n' string  )
 183     skip-whitespace "<" slice-til-either {
 184         { CHAR: < [
 185             1 split-slice-back [ >string f like [ reach push ] when* ] dip
 186             [ 2dup peek1-from ] dip
 187             swap {
 188                 { CHAR: / [
 189                     read-close-tag reach over name>> find-last-open-tag unclip
 190                     swap check-tag-stack >>children
 191                     swap >>close-tag
 192                     ] }
 193                 { CHAR: ! [ read-doctype ] }
 194                 { CHAR: ? [ read-processing-instruction ] }
 195                 { CHAR: % [ read-embedded-language ] }
 196                 [ drop read-open-tag ]
 197             } case
 198         ] }
 199         { f [ drop f ] }
 200         [ drop >string ]
 201     } case [ reach push lex-html ] when* ;
 202
 203 : string>html ( string -- sequence )
 204     [ V{ } clone 0 ] dip lex-html 2drop check-tag-stack ;
 205
 206 GENERIC: write-html ( tag -- )
 207
 208 : >value ( obj -- string )
 209     {
 210         { [ dup squote? ] [ payload>> "'" 1surround ] }
 211         { [ dup dquote? ] [ payload>> "\"" 1surround ] }
 212         [ ]
 213     } cond ;
 214
 215 M: doctype write-html
 216     [ open>> % ]
 217     [ values>> [ >value ] map join-words [ " " % % ] unless-empty ]
 218     [ close>> % ] tri ;
 219
 220 : write-props ( seq -- )
 221     [ dup array? [ first2 >value "=" glue ] [ >value ] if ] map join-words [ " " % % ] unless-empty ;
 222
 223 M: processing-instruction write-html
 224     {
 225         [ open>> % ]
 226         [ target>> % ]
 227         [ props>> write-props ]
 228         [ close>> % ]
 229     } cleave ;
 230
 231 M: open-tag write-html
 232     {
 233         [ open>> % ]
 234         [ name>> % ]
 235         [ props>> write-props ]
 236         [ close>> % ]
 237         [ children>> [ write-html ] each ]
 238         [ close-tag>> name>> "</" ">" surround % ]
 239     } cleave ;
 240
 241 M: self-close-tag write-html
 242     {
 243         [ open>> % ]
 244         [ name>> % ]
 245         [ props>> write-props ]
 246         [ close>> % ]
 247     } cleave ;
 248
 249 M: comment write-html
 250     [ open>> % ]
 251     [ payload>> % ]
 252     [ close>> % ] tri ;
 253
 254 M: string write-html % ;
 255
 256 : html>string ( sequence -- string )
 257     [ [ write-html ] each ] "" make ;
 258
 259 GENERIC#: walk-html 1 ( seq/tag quot -- )
 260
 261 M: sequence walk-html [ walk-html ] curry each ;
 262 M: string walk-html call( obj -- ) ;
 263 M: doctype walk-html call( obj -- ) ;
 264 M: processing-instruction walk-html call( obj -- ) ;
 265 M: embedded-language walk-html call( obj -- ) ;
 266 M: open-tag walk-html [ call( obj -- ) ] 2keep [ children>> ] dip [ walk-html ] curry each ;
 267 M: self-close-tag walk-html [ call( obj -- ) ] 2keep [ children>> ] dip [ walk-html ] curry each ;
 268 M: comment walk-html call( obj -- ) ;
 269
 270 : find-links ( seq -- links )
 271     [
 272         [
 273             dup tag? [
 274                 props>> [ drop  >lower "href" = ] assoc-find
 275                 [ nip , ] [ 2drop ] if
 276             ] [ drop ] if
 277         ] walk-html
 278     ] { } make [ payload>> ] map ;