basis/html/templates/chloe/chloe.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel sequences combinators kernel namespaces
   4 classes.tuple assocs splitting words arrays memoize
   5 io io.files io.encodings.utf8 io.streams.string
   6 unicode.case tuple-syntax mirrors fry math urls present
   7 multiline xml xml.data xml.writer xml.utilities
   8 html.forms
   9 html.elements
  10 html.components
  11 html.templates
  12 html.templates.chloe.syntax ;
  13 IN: html.templates.chloe
  14
  15 ! Chloe is Ed's favorite web designer
  16 SYMBOL: tag-stack
  17
  18 TUPLE: chloe path ;
  19
  20 C: <chloe> chloe
  21
  22 DEFER: process-template
  23
  24 : chloe-attrs-only ( assoc -- assoc' )
  25     [ drop url>> chloe-ns = ] assoc-filter ;
  26
  27 : non-chloe-attrs-only ( assoc -- assoc' )
  28     [ drop url>> chloe-ns = not ] assoc-filter ;
  29
  30 : chloe-tag? ( tag -- ? )
  31     dup xml? [ body>> ] when
  32     {
  33         { [ dup tag? not ] [ f ] }
  34         { [ dup url>> chloe-ns = not ] [ f ] }
  35         [ t ]
  36     } cond nip ;
  37
  38 : process-tag-children ( tag -- )
  39     [ process-template ] each ;
  40
  41 CHLOE: chloe process-tag-children ;
  42
  43 : children>string ( tag -- string )
  44     [ process-tag-children ] with-string-writer ;
  45
  46 CHLOE: title children>string set-title ;
  47
  48 CHLOE: write-title
  49     drop
  50     "head" tag-stack get member?
  51     "title" tag-stack get member? not and
  52     [ <title> write-title </title> ] [ write-title ] if ;
  53
  54 CHLOE: style
  55     dup "include" optional-attr dup [
  56         swap children>string empty? [
  57             "style tag cannot have both an include attribute and a body" throw
  58         ] unless
  59         utf8 file-contents
  60     ] [
  61         drop children>string
  62     ] if add-style ;
  63
  64 CHLOE: write-style
  65     drop <style> write-style </style> ;
  66
  67 CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
  68
  69 CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
  70
  71 : (bind-tag) ( tag quot -- )
  72     [
  73         [ "name" required-attr ] keep
  74         '[ , process-tag-children ]
  75     ] dip call ; inline
  76
  77 CHLOE: each [ with-each-value ] (bind-tag) ;
  78
  79 CHLOE: bind-each [ with-each-object ] (bind-tag) ;
  80
  81 CHLOE: bind [ with-form ] (bind-tag) ;
  82
  83 : error-message-tag ( tag -- )
  84     children>string render-error ;
  85
  86 CHLOE: comment drop ;
  87
  88 CHLOE: call-next-template drop call-next-template ;
  89
  90 : attr>word ( value -- word/f )
  91     ":" split1 swap lookup ;
  92
  93 : if-satisfied? ( tag -- ? )
  94     [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
  95     [ "value" optional-attr [ value ] [ t ] if* ]
  96     bi and ;
  97
  98 CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
  99
 100 CHLOE-SINGLETON: label
 101 CHLOE-SINGLETON: link
 102 CHLOE-SINGLETON: inspector
 103 CHLOE-SINGLETON: comparison
 104 CHLOE-SINGLETON: html
 105 CHLOE-SINGLETON: hidden
 106
 107 CHLOE-TUPLE: farkup
 108 CHLOE-TUPLE: field
 109 CHLOE-TUPLE: textarea
 110 CHLOE-TUPLE: password
 111 CHLOE-TUPLE: choice
 112 CHLOE-TUPLE: checkbox
 113 CHLOE-TUPLE: code
 114
 115 : process-chloe-tag ( tag -- )
 116     dup main>> dup tags get at
 117     [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
 118
 119 : process-tag ( tag -- )
 120     {
 121         [ main>> >lower tag-stack get push ]
 122         [ write-start-tag ]
 123         [ process-tag-children ]
 124         [ write-end-tag ]
 125         [ drop tag-stack get pop* ]
 126     } cleave ;
 127
 128 : expand-attrs ( tag -- tag )
 129     dup [ tag? ] [ xml? ] bi or [
 130         clone [
 131             [ "@" ?head [ value present ] when ] assoc-map
 132         ] change-attrs
 133     ] when ;
 134
 135 : process-template ( xml -- )
 136     expand-attrs
 137     {
 138         { [ dup chloe-tag? ] [ process-chloe-tag ] }
 139         { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
 140         { [ t ] [ write-item ] }
 141     } cond ;
 142
 143 : process-chloe ( xml -- )
 144     [
 145         V{ } clone tag-stack set
 146
 147         nested-template? get [
 148             process-template
 149         ] [
 150             {
 151                 [ prolog>> write-prolog ]
 152                 [ before>> write-chunk  ]
 153                 [ process-template        ]
 154                 [ after>> write-chunk   ]
 155             } cleave
 156         ] if
 157     ] with-scope ;
 158
 159 M: chloe call-template*
 160     path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
 161
 162 INSTANCE: chloe template