basis/html/templates/chloe/compiler/compiler.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs combinators html.forms
   4 html.templates html.templates.chloe.syntax io io.streams.string
   5 kernel make namespaces present sequences splitting strings
   6 xml.data xml.entities xml.writer ;
   7 IN: html.templates.chloe.compiler
   8
   9 : chloe-attrs-only ( assoc -- assoc' )
  10     [ chloe-name? ] filter-keys ;
  11
  12 : non-chloe-attrs-only ( assoc -- assoc' )
  13     [ chloe-name? ] reject-keys ;
  14
  15 : chloe-tag? ( tag -- ? )
  16     dup xml? [ body>> ] when
  17     {
  18         { [ dup tag? not ] [ f ] }
  19         { [ dup chloe-name? not ] [ f ] }
  20         [ t ]
  21     } cond nip ;
  22
  23 SYMBOL: string-buffer
  24
  25 SYMBOL: tag-stack
  26
  27 DEFER: compile-element
  28
  29 : compile-children ( tag -- )
  30     [ compile-element ] each ;
  31
  32 : [write] ( string -- ) string-buffer get push-all ;
  33
  34 : reset-buffer ( -- )
  35     string-buffer get [
  36         [ >string , \ write , ] [ delete-all ] bi
  37     ] unless-empty ;
  38
  39 : [code] ( quot -- )
  40     reset-buffer % ;
  41
  42 : [code-with] ( obj quot -- )
  43     reset-buffer [ , ] [ % ] bi* ;
  44
  45 : [xml-code] ( quot -- )
  46     [ write-xml ] compose [code] ;
  47
  48 : expand-attr ( value -- )
  49     [ value present write ] [code-with] ;
  50
  51 : compile-attr ( value -- )
  52     reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
  53
  54 : compile-attrs ( assoc -- )
  55     [
  56         " " [write]
  57         swap name>string [write]
  58         "=\"" [write]
  59         "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
  60         "\"" [write]
  61     ] assoc-each ;
  62
  63 : compile-self-closing-tag ( tag -- )
  64     "<" [write]
  65     [ name>string [write] ] [ attrs>> compile-attrs ] bi
  66     " />" [write] ;
  67
  68 : compile-start-tag ( tag -- )
  69     "<" [write]
  70     [ name>string [write] ] [ attrs>> compile-attrs ] bi
  71     ">" [write] ;
  72
  73 : compile-end-tag ( tag -- )
  74     "</" [write]
  75     name>string [write]
  76     ">" [write] ;
  77
  78 SYMBOL: string-context?
  79
  80 ERROR: tag-not-allowed-here ;
  81
  82 CONSTANT: self-closing-tags {
  83         "area"
  84         "base"
  85         "br"
  86         "embed"
  87         "hr"
  88         "iframe"
  89         "img"
  90         "input"
  91         "link"
  92         "meta"
  93         "param"
  94         "source"
  95         "track"
  96     }
  97
  98 : check-tag ( -- )
  99     string-context? get [ tag-not-allowed-here ] when ;
 100
 101 : (compile-tag) ( tag -- )
 102     dup name>string >lower self-closing-tags
 103     member? [
 104         compile-self-closing-tag
 105     ] [
 106         [ compile-start-tag ]
 107         [ compile-children ]
 108         [ compile-end-tag ] tri
 109     ] if ;
 110
 111 : compile-tag ( tag -- )
 112     check-tag
 113     [ main>> tag-stack get push ]
 114     [ (compile-tag) ] bi
 115     tag-stack get pop* ;
 116
 117 ERROR: unknown-chloe-tag tag ;
 118
 119 : compile-chloe-tag ( tag -- )
 120     dup main>>
 121     [ chloe-tags get at ]
 122     [ call( tag -- ) ]
 123     [ unknown-chloe-tag ]
 124     ?if ;
 125
 126 : compile-string ( string -- )
 127     string-context? get [ escape-string ] unless [write] ;
 128
 129 : compile-misc ( object -- )
 130     check-tag
 131     [ write-xml ] [code-with] ;
 132
 133 : compile-element ( element -- )
 134     {
 135         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
 136         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
 137         { [ dup string? ] [ compile-string ] }
 138         { [ dup comment? ] [ drop ] }
 139         [ compile-misc ]
 140     } cond ;
 141
 142 : with-compiler ( quot -- quot' )
 143     [
 144         SBUF" " string-buffer namespaces:set
 145         V{ } clone tag-stack namespaces:set
 146         call
 147         reset-buffer
 148     ] [ ] make ; inline
 149
 150 : compile-chunk ( seq -- )
 151     [ compile-element ] each ;
 152
 153 : compile-quot ( quot -- )
 154     reset-buffer
 155     [
 156         SBUF" " string-buffer namespaces:set
 157         call
 158         reset-buffer
 159     ] [ ] make , ; inline
 160
 161 : process-children ( tag quot -- )
 162     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 163
 164 : compile-children>xml-string ( tag -- )
 165     [ with-string-writer ] process-children ;
 166
 167 : compile-children>string ( tag -- )
 168     t string-context? [
 169         compile-children>xml-string
 170     ] with-variable ;
 171
 172 : compile-with-scope ( quot -- )
 173     compile-quot [ with-scope ] [code] ; inline
 174
 175 : if-not-nested ( quot -- )
 176     nested-template? get swap unless ; inline
 177
 178 : compile-prologue ( xml -- )
 179     [
 180         before>> compile-chunk
 181     ] compile-quot
 182     [ if-not-nested ] [code] ;
 183
 184 : compile-epilogue ( xml -- )
 185     [ after>> compile-chunk ] compile-quot
 186     [ if-not-nested ] [code] ;
 187
 188 : compile-template ( xml -- quot )
 189     [
 190         [ compile-prologue ]
 191         [ compile-element ]
 192         [ compile-epilogue ]
 193         tri
 194     ] with-compiler ;