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 combinators combinators.short-circuit
   4 generalizations kernel make math modern modern.slices multiline
   5 sequences sequences.extras strings unicode ;
   6 IN: modern.html
   7
   8 TUPLE: tag name open-close-delimiter props children ;
   9
  10 TUPLE: doctype open close values ;
  11 : <doctype> ( open close values -- doctype )
  12     doctype new
  13         swap >>values
  14         swap >string >>close
  15         swap >string >>open ;
  16
  17 TUPLE: comment open payload close ;
  18 : <comment> ( open payload close -- comment )
  19     comment new
  20         swap >>close
  21         swap >>payload
  22         swap >>open ;
  23
  24 TUPLE: close-tag name ;
  25 : <close-tag> ( name -- tag )
  26     close-tag new
  27         swap >string rest rest but-last >>name ;
  28
  29 TUPLE: open-tag < tag close-tag ;
  30 : <open-tag> ( name delimiter props -- tag )
  31     open-tag new
  32         swap >>props
  33         swap >string drop ! >>open-close-delimiter
  34         swap >string >>name
  35         V{ } clone >>children ;
  36
  37 TUPLE: self-close-tag < tag ;
  38 : <self-close-tag> ( name delimiter props -- tag )
  39     self-close-tag new
  40         swap >>props
  41         swap >string drop ! >>open-close-delimiter
  42         swap >string >>name
  43         V{ } clone >>children ;
  44
  45 TUPLE: squote payload ;
  46 C: <squote> squote
  47 TUPLE: dquote payload ;
  48 C: <dquote> dquote
  49
  50 : read-squote-string-payload ( n string -- n' string )
  51     over [
  52         { CHAR: \\ CHAR: ' } slice-til-separator-inclusive {
  53             { f [ drop ] }
  54             { CHAR: ' [ drop ] }
  55             { CHAR: \\ [ drop next-char-from drop read-string-payload ] }
  56         } case
  57     ] [
  58         string-expected-got-eof
  59     ] if ;
  60
  61 : read-dquote-string-payload ( n string -- n' string )
  62     over [
  63         { CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
  64             { f [ drop ] }
  65             { CHAR: \" [ drop ] }
  66             { CHAR: \\ [ drop next-char-from drop read-string-payload ] }
  67         } case
  68     ] [
  69         string-expected-got-eof
  70     ] if ;
  71
  72 :: read-string ( n string char -- n' string payload )
  73     n string char CHAR: ' = [ read-squote-string-payload ] [ read-dquote-string-payload ] if drop :> n'
  74     n' string
  75     n' [ n string string-expected-got-eof ] unless
  76     n n' 1 - string <slice> ;
  77
  78 : take-tag-name ( n string -- n' string tag )
  79     [ "\s\r\n/>" member? ] slice-until ;
  80
  81 : read-value ( n string -- n' string value )
  82     skip-whitespace next-char-from {
  83         { CHAR: ' [ CHAR: ' read-string >string <squote> ] }
  84         { CHAR: " [ CHAR: " read-string >string <dquote> ] }
  85         { CHAR: [ [ "[" throw ] }
  86         { CHAR: { [ "{" throw ] }
  87         [ [ take-tag-name ] dip prefix ]
  88     } case ;
  89
  90 : read-prop ( n string -- n' string closing/f prop/f )
  91     skip-whitespace "\s\n\r\"'<=/>" slice-til-either {
  92         { CHAR: < [ "< error" throw ] }
  93         { CHAR: = [ 1 split-slice-back drop >string [ read-value ] dip swap 2array f swap ] }
  94         { CHAR: / [ ">" expect-and-span 2 split-slice-back swap >string f like ] }
  95         { CHAR: > [ 1 split-slice-back swap >string f like ] }
  96         { CHAR: ' [ first read-string >string <squote> f swap ] }
  97         { CHAR: " [ first read-string >string <dquote> f swap ] }
  98         { CHAR: \s [ f swap >string ] }
  99         { CHAR: \r [ f swap >string ] }
 100         { CHAR: \n [ f swap >string ] }
 101         { f [ "efff" throw ] }
 102     } case ;
 103
 104 : read-props ( props n string -- props n' string closing )
 105     read-prop
 106     [ 5 npick push ] when*
 107     [ ] [ read-props ] if* ;
 108
 109 : read-doctype ( n string opening -- n string doctype/comment )
 110     "!" expect-and-span
 111     2over 2 peek-from "--" sequence= [
 112         "--" expect-and-span >string
 113         [ "-->" slice-til-string [ >string ] bi@ ] dip -rot <comment>
 114     ] [
 115         "DOCTYPE" expect-and-span
 116         [ V{ } clone -rot read-props ] dip
 117         swap 5 nrot <doctype>
 118     ] if ;
 119
 120 : read-open-tag ( n string opening -- n' string tag )
 121     [ take-tag-name ] dip drop ! B span-slices
 122     [ V{ } clone -rot read-props ] dip
 123     swap 5 nrot over ">" sequence= [
 124         <open-tag>
 125     ] [
 126         <self-close-tag>
 127     ] if ;
 128
 129 : read-close-tag ( n string opening -- n' string tag )
 130     "/" expect-and-span
 131     [ take-tag-name ] dip span-slices
 132     ">" expect-and-span
 133     <close-tag> ;
 134
 135 :: shorten* ( vector n -- seq )
 136     vector n tail
 137     n vector shorten ;
 138
 139 : pop-til-end ( stack quot -- seq/f )
 140     [ find-last drop ] keepd swap
 141     [ shorten* ] [ drop f ] if* ; inline
 142
 143 ERROR: unmatched-open-tags-error stack seq ;
 144 : check-tag-stack ( stack -- stack )
 145     dup [
 146         { [ open-tag? ] [ close-tag>> not ] } 1&&
 147     ] filter [ unmatched-open-tags-error ] unless-empty ;
 148
 149 ERROR: unmatched-closing-tag-error stack tag ;
 150 :: find-last-open-tag ( stack name -- seq )
 151     stack [ { [ tag? ] [ name>> name = ] } 1&& ] find-last drop [
 152         stack swap shorten*
 153     ] [
 154         stack name unmatched-closing-tag-error
 155     ] if* ;
 156
 157 : lex-html ( stack n string -- stack n' string  )
 158     skip-whitespace "<" slice-til-either {
 159         { CHAR: < [
 160             1 split-slice-back [ >string f like [ reach push ] when* ] dip
 161             [ 2dup peek1-from ] dip
 162             swap {
 163                 { CHAR: / [
 164                     read-close-tag reach over name>> find-last-open-tag unclip
 165                     swap check-tag-stack >>children
 166                     swap >>close-tag
 167                     ] }
 168                 { CHAR: ! [ read-doctype ] }
 169                 [ drop read-open-tag ]
 170             } case
 171         ] }
 172         { f [ drop f ] }
 173         [ drop >string ]
 174     } case [ reach push lex-html ] when* ;
 175
 176 : string>html ( string -- sequence )
 177     [ V{ } clone 0 ] dip lex-html 2drop check-tag-stack ;
 178
 179 GENERIC: write-html ( tag -- )
 180
 181 : >value ( obj -- string )
 182     {
 183         { [ dup squote? ] [ payload>> "'" dup surround ] }
 184         { [ dup dquote? ] [ payload>> "\"" dup surround ] }
 185         [ ]
 186     } cond ;
 187
 188 M: doctype write-html
 189     [ open>> % ]
 190     [ values>> [ >value ] map unwords [ " " % % ] unless-empty ]
 191     [ close>> % ] tri ;
 192
 193
 194 : write-props ( seq -- )
 195     [ dup array? [ first2 >value "=" glue ] [ >value ] if ] map unwords [ " " % % ] unless-empty ;
 196
 197 M: open-tag write-html
 198     {
 199         [ "<" % name>> % ]
 200         [ props>> write-props ">" % ]
 201         [ children>> [ write-html ] each ]
 202         [ close-tag>> name>> "</" ">" surround % ]
 203     } cleave ;
 204
 205 M: self-close-tag write-html
 206     {
 207         [ "<" % name>> % ]
 208         [ props>> write-props "/>" % ]
 209     } cleave ;
 210
 211 M: comment write-html
 212     [ open>> % ]
 213     [ payload>> % ]
 214     [ close>> % ] tri ;
 215
 216 M: string write-html % ;
 217
 218 : html>string ( sequence -- string )
 219     [ [ write-html ] each ] "" make ;