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 fry
   4 namespaces make classes.tuple assocs splitting words arrays io
   5 io.files io.encodings.utf8 io.streams.string unicode.case
   6 mirrors math urls present multiline quotations xml logging
   7 continuations
   8 xml.data
   9 html.forms
  10 html.elements
  11 html.components
  12 html.templates
  13 html.templates.chloe.compiler
  14 html.templates.chloe.components
  15 html.templates.chloe.syntax ;
  16 IN: html.templates.chloe
  17
  18 ! Chloe is Ed's favorite web designer
  19 TUPLE: chloe path ;
  20
  21 C: <chloe> chloe
  22
  23 CHLOE: chloe compile-children ;
  24
  25 CHLOE: title compile-children>string [ set-title ] [code] ;
  26
  27 CHLOE: write-title
  28     drop
  29     "head" tag-stack get member?
  30     "title" tag-stack get member? not and
  31     [ <title> write-title </title> ] [ write-title ] ? [code] ;
  32
  33 CHLOE: style
  34     dup "include" optional-attr [
  35         utf8 file-contents [ add-style ] [code-with]
  36     ] [
  37         compile-children>string [ add-style ] [code]
  38     ] ?if ;
  39
  40 CHLOE: write-style
  41     drop [
  42         <style "text/css" =type style>
  43             write-style
  44         </style>
  45     ] [code] ;
  46
  47 CHLOE: even
  48     [ "index" value even? swap when ] process-children ;
  49
  50 CHLOE: odd
  51     [ "index" value odd? swap when ] process-children ;
  52
  53 : (bind-tag) ( tag quot -- )
  54     [
  55         [ "name" required-attr compile-attr ] keep
  56     ] dip process-children ; inline
  57
  58 CHLOE: each [ with-each-value ] (bind-tag) ;
  59
  60 CHLOE: bind-each [ with-each-object ] (bind-tag) ;
  61
  62 CHLOE: bind [ with-form ] (bind-tag) ;
  63
  64 CHLOE: comment drop ;
  65
  66 CHLOE: call-next-template
  67     drop reset-buffer \ call-next-template , ;
  68
  69 CHLOE: validation-errors
  70     drop [ render-validation-errors ] [code] ;
  71
  72 : attr>word ( value -- word/f )
  73     ":" split1 swap lookup ;
  74
  75 : if>quot ( tag -- quot )
  76     [
  77         [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
  78         [ "value" optional-attr [ , \ value , ] [ t , ] if* ]
  79         bi
  80         \ and ,
  81     ] [ ] make ;
  82
  83 CHLOE: if dup if>quot [ swap when ] append process-children ;
  84
  85 COMPONENT: label
  86 COMPONENT: link
  87 COMPONENT: inspector
  88 COMPONENT: comparison
  89 COMPONENT: html
  90 COMPONENT: hidden
  91 COMPONENT: farkup
  92 COMPONENT: field
  93 COMPONENT: textarea
  94 COMPONENT: password
  95 COMPONENT: choice
  96 COMPONENT: checkbox
  97 COMPONENT: code
  98
  99 SYMBOL: template-cache
 100
 101 H{ } template-cache set-global
 102
 103 TUPLE: cached-template path last-modified quot ;
 104
 105 : load-template ( chloe -- cached-template )
 106     path>> ".xml" append
 107     [ ]
 108     [ file-info modified>> ]
 109     [ utf8 <file-reader> read-xml compile-template ] tri
 110     \ cached-template boa ;
 111
 112 \ load-template DEBUG add-input-logging
 113
 114 : cached-template ( chloe -- cached-template/f )
 115     template-cache get at* [
 116         [
 117             [ path>> file-info modified>> ]
 118             [ last-modified>> ]
 119             bi =
 120         ] keep and
 121     ] when ;
 122
 123 : template-quot ( chloe -- quot )
 124     dup cached-template [ ] [
 125         [ load-template dup ] keep
 126         template-cache get set-at
 127     ] ?if quot>> ;
 128
 129 : reset-cache ( -- )
 130     template-cache get clear-assoc ;
 131
 132 M: chloe call-template*
 133     template-quot assert-depth ;
 134
 135 INSTANCE: chloe template