extra/modern/html/html.factor

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