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 continuations ;
   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? not ] assoc-filter ;
  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 : expand-attr ( value -- )
  46     [ value present write ] [code-with] ;
  47
  48 : compile-attr ( value -- )
  49     reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
  50
  51 : compile-attrs ( assoc -- )
  52     [
  53         " " [write]
  54         swap name>string [write]
  55         "=\"" [write]
  56         "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
  57         "\"" [write]
  58     ] assoc-each ;
  59
  60 : compile-start-tag ( tag -- )
  61     "<" [write]
  62     [ name>string [write] ] [ attrs>> compile-attrs ] bi
  63     ">" [write] ;
  64
  65 : compile-end-tag ( tag -- )
  66     "</" [write]
  67     name>string [write]
  68     ">" [write] ;
  69
  70 : compile-tag ( tag -- )
  71     {
  72         [ main>> tag-stack get push ]
  73         [ compile-start-tag ]
  74         [ compile-children ]
  75         [ compile-end-tag ]
  76         [ drop tag-stack get pop* ]
  77     } cleave ;
  78
  79 ERROR: unknown-chloe-tag tag ;
  80
  81 : compile-chloe-tag ( tag -- )
  82     dup main>> dup tags get at
  83     [ curry assert-depth ]
  84     [ unknown-chloe-tag ]
  85     ?if ;
  86
  87 : compile-element ( element -- )
  88     {
  89         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
  90         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
  91         { [ dup string? ] [ escape-string [write] ] }
  92         { [ dup comment? ] [ drop ] }
  93         [ [ write-xml ] [code-with] ]
  94     } cond ;
  95
  96 : with-compiler ( quot -- quot' )
  97     [
  98         SBUF" " string-buffer set
  99         V{ } clone tag-stack set
 100         call
 101         reset-buffer
 102     ] [ ] make ; inline
 103
 104 : compile-chunk ( seq -- )
 105     [ compile-element ] each ;
 106
 107 : compile-quot ( quot -- )
 108     reset-buffer
 109     [
 110         SBUF" " string-buffer set
 111         call
 112         reset-buffer
 113     ] [ ] make , ; inline
 114
 115 : process-children ( tag quot -- )
 116     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 117
 118 : compile-children>string ( tag -- )
 119      [ with-string-writer ] process-children ;
 120
 121 : compile-with-scope ( quot -- )
 122     compile-quot [ with-scope ] [code] ; inline
 123
 124 : if-not-nested ( quot -- )
 125     nested-template? get swap unless ; inline
 126
 127 : compile-prologue ( xml -- )
 128     [
 129         [ prolog>> [ write-xml ] [code-with] ]
 130         [ before>> compile-chunk ]
 131         bi
 132     ] compile-quot
 133     [ if-not-nested ] [code] ;
 134
 135 : compile-epilogue ( xml -- )
 136     [ after>> compile-chunk ] compile-quot
 137     [ if-not-nested ] [code] ;
 138
 139 : compile-template ( xml -- quot )
 140     [
 141         [ compile-prologue ]
 142         [ compile-element ]
 143         [ compile-epilogue ]
 144         tri
 145     ] with-compiler ;