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 kernel sequences accessors combinators
   4 strings splitting io io.streams.string present xml.writer
   5 xml.data xml.entities html.forms html.templates.chloe.syntax ;
   6 IN: html.templates.chloe.compiler
   7
   8 : chloe-attrs-only ( assoc -- assoc' )
   9     [ drop url>> chloe-ns = ] assoc-filter ;
  10
  11 : non-chloe-attrs-only ( assoc -- assoc' )
  12     [ drop url>> chloe-ns = not ] assoc-filter ;
  13
  14 : chloe-tag? ( tag -- ? )
  15     dup xml? [ body>> ] when
  16     {
  17         { [ dup tag? not ] [ f ] }
  18         { [ dup url>> chloe-ns = not ] [ f ] }
  19         [ t ]
  20     } cond nip ;
  21
  22 SYMBOL: string-buffer
  23
  24 SYMBOL: tag-stack
  25
  26 DEFER: compile-element
  27
  28 : compile-children ( tag -- )
  29     [ compile-element ] each ;
  30
  31 : [write] ( string -- ) string-buffer get push-all ;
  32
  33 : reset-buffer ( -- )
  34     string-buffer get [
  35         [ >string , \ write , ] [ delete-all ] bi
  36     ] unless-empty ;
  37
  38 : [code] ( quot -- )
  39     reset-buffer % ;
  40
  41 : [code-with] ( obj quot -- )
  42     reset-buffer [ , ] [ % ] bi* ;
  43
  44 : expand-attr ( value -- )
  45     [ value present write ] [code-with] ;
  46
  47 : compile-attr ( value -- )
  48     reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
  49
  50 : compile-attrs ( assoc -- )
  51     [
  52         " " [write]
  53         swap name>string [write]
  54         "=\"" [write]
  55         "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
  56         "\"" [write]
  57     ] assoc-each ;
  58
  59 : compile-start-tag ( tag -- )
  60     "<" [write]
  61     [ name>string [write] ] [ compile-attrs ] bi
  62     ">" [write] ;
  63
  64 : compile-end-tag ( tag -- )
  65     "</" [write]
  66     name>string [write]
  67     ">" [write] ;
  68
  69 : compile-tag ( tag -- )
  70     {
  71         [ main>> tag-stack get push ]
  72         [ compile-start-tag ]
  73         [ compile-children ]
  74         [ compile-end-tag ]
  75         [ drop tag-stack get pop* ]
  76     } cleave ;
  77
  78 : compile-chloe-tag ( tag -- )
  79     ! "Unknown chloe tag: " prepend throw
  80     dup main>> dup tags get at
  81     [ curry assert-depth ] [ 2drop ] ?if ;
  82
  83 : compile-element ( element -- )
  84     {
  85         { [ dup chloe-tag? ] [ compile-chloe-tag ] }
  86         { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
  87         { [ dup string? ] [ escape-string [write] ] }
  88         { [ dup comment? ] [ drop ] }
  89         [ [ write-item ] [code-with] ]
  90     } cond ;
  91
  92 : with-compiler ( quot -- quot' )
  93     [
  94         SBUF" " string-buffer set
  95         V{ } clone tag-stack set
  96         call
  97         reset-buffer
  98     ] [ ] make ; inline
  99
 100 : compile-nested-template ( xml -- quot )
 101     [ compile-element ] with-compiler ;
 102
 103 : compile-chunk ( seq -- )
 104     [ compile-element ] each ;
 105
 106 : compile-quot ( quot -- )
 107     reset-buffer
 108     [
 109         SBUF" " string-buffer set
 110         call
 111         reset-buffer
 112     ] [ ] make , ; inline
 113
 114 : process-children ( tag quot -- )
 115     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 116
 117 : compile-children>string ( tag -- )
 118      [ with-string-writer ] process-children ;
 119
 120 : compile-with-scope ( quot -- )
 121     compile-quot [ with-scope ] [code] ; inline
 122
 123 : compile-template ( xml -- quot )
 124     [
 125         {
 126             [ prolog>> [ write-prolog ] [code-with] ]
 127             [ before>> compile-chunk ]
 128             [ compile-element ]
 129             [ after>> compile-chunk ]
 130         } cleave
 131     ] with-compiler ;