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: assocs namespaces make kernel sequences accessors
   4 combinators strings splitting io io.streams.string present
   5 xml.writer xml.data xml.entities html.forms
   6 html.templates html.templates.chloe.syntax ;
   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-start-tag ( tag -- )
  64     "<" [write]
  65     [ name>string [write] ] [ attrs>> compile-attrs ] bi
  66     ">" [write] ;
  67
  68 : compile-end-tag ( tag -- )
  69     "</" [write]
  70     name>string [write]
  71     ">" [write] ;
  72
  73 SYMBOL: string-context?
  74
  75 ERROR: tag-not-allowed-here ;
  76
  77 : check-tag ( -- )
  78     string-context? get [ throw-tag-not-allowed-here ] when ;
  79
  80 : compile-tag ( tag -- )
  81     check-tag
  82     {
  83         [ main>> tag-stack get push ]
  84         [ compile-start-tag ]
  85         [ compile-children ]
  86         [ compile-end-tag ]
  87     } cleave
  88     tag-stack get pop* ;
  89
  90 ERROR: unknown-chloe-tag tag ;
  91
  92 : compile-chloe-tag ( tag -- )
  93     dup main>> dup tags get at
  94     [ call( tag -- ) ]
  95     [ unknown-chloe-tag ]
  96     ?if ;
  97
  98 : compile-string ( string -- )
  99     string-context? get [ escape-string ] unless [write] ;
 100
 101 : compile-misc ( object -- )
 102     check-tag
 103     [ write-xml ] [code-with] ;
 104
 105 : compile-element ( element -- )
 106     {
 107         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
 108         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
 109         { [ dup string? ] [ compile-string ] }
 110         { [ dup comment? ] [ drop ] }
 111         [ compile-misc ]
 112     } cond ;
 113
 114 : with-compiler ( quot -- quot' )
 115     [
 116         SBUF" " string-buffer set
 117         V{ } clone tag-stack set
 118         call
 119         reset-buffer
 120     ] [ ] make ; inline
 121
 122 : compile-chunk ( seq -- )
 123     [ compile-element ] each ;
 124
 125 : compile-quot ( quot -- )
 126     reset-buffer
 127     [
 128         SBUF" " string-buffer set
 129         call
 130         reset-buffer
 131     ] [ ] make , ; inline
 132
 133 : process-children ( tag quot -- )
 134     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 135
 136 : compile-children>xml-string ( tag -- )
 137     [ with-string-writer ] process-children ;
 138
 139 : compile-children>string ( tag -- )
 140     t string-context? [
 141         compile-children>xml-string
 142     ] with-variable ;
 143
 144 : compile-with-scope ( quot -- )
 145     compile-quot [ with-scope ] [code] ; inline
 146
 147 : if-not-nested ( quot -- )
 148     nested-template? get swap unless ; inline
 149
 150 : compile-prologue ( xml -- )
 151     [
 152         [ prolog>> [ write-xml ] [code-with] ]
 153         [ before>> compile-chunk ]
 154         bi
 155     ] compile-quot
 156     [ if-not-nested ] [code] ;
 157
 158 : compile-epilogue ( xml -- )
 159     [ after>> compile-chunk ] compile-quot
 160     [ if-not-nested ] [code] ;
 161
 162 : compile-template ( xml -- quot )
 163     [
 164         [ compile-prologue ]
 165         [ compile-element ]
 166         [ compile-epilogue ]
 167         tri
 168     ] with-compiler ;