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

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://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     [ drop chloe-name? ] assoc-filter ;
  11
  12 : non-chloe-attrs-only ( assoc -- assoc' )
  13     [ drop chloe-name? ] assoc-reject ;
  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>> dup tags get at
 121     [ call( tag -- ) ]
 122     [ unknown-chloe-tag ]
 123     ?if ;
 124
 125 : compile-string ( string -- )
 126     string-context? get [ escape-string ] unless [write] ;
 127
 128 : compile-misc ( object -- )
 129     check-tag
 130     [ write-xml ] [code-with] ;
 131
 132 : compile-element ( element -- )
 133     {
 134         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
 135         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
 136         { [ dup string? ] [ compile-string ] }
 137         { [ dup comment? ] [ drop ] }
 138         [ compile-misc ]
 139     } cond ;
 140
 141 : with-compiler ( quot -- quot' )
 142     [
 143         SBUF" " string-buffer namespaces:set
 144         V{ } clone tag-stack namespaces:set
 145         call
 146         reset-buffer
 147     ] [ ] make ; inline
 148
 149 : compile-chunk ( seq -- )
 150     [ compile-element ] each ;
 151
 152 : compile-quot ( quot -- )
 153     reset-buffer
 154     [
 155         SBUF" " string-buffer namespaces:set
 156         call
 157         reset-buffer
 158     ] [ ] make , ; inline
 159
 160 : process-children ( tag quot -- )
 161     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 162
 163 : compile-children>xml-string ( tag -- )
 164     [ with-string-writer ] process-children ;
 165
 166 : compile-children>string ( tag -- )
 167     t string-context? [
 168         compile-children>xml-string
 169     ] with-variable ;
 170
 171 : compile-with-scope ( quot -- )
 172     compile-quot [ with-scope ] [code] ; inline
 173
 174 : if-not-nested ( quot -- )
 175     nested-template? get swap unless ; inline
 176
 177 : compile-prologue ( xml -- )
 178     [
 179         before>> compile-chunk
 180     ] compile-quot
 181     [ if-not-nested ] [code] ;
 182
 183 : compile-epilogue ( xml -- )
 184     [ after>> compile-chunk ] compile-quot
 185     [ if-not-nested ] [code] ;
 186
 187 : compile-template ( xml -- quot )
 188     [
 189         [ compile-prologue ]
 190         [ compile-element ]
 191         [ compile-epilogue ]
 192         tri
 193     ] with-compiler ;