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.files.info io.encodings.utf8 io.streams.string
   6 unicode.case mirrors math urls present multiline quotations xml
   7 logging
   8 xml.data xml.writer xml.syntax strings
   9 html.forms
  10 html
  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 TUPLE: chloe path ;
  19
  20 C: <chloe> chloe
  21
  22 CHLOE: chloe compile-children ;
  23
  24 CHLOE: title compile-children>string [ set-title ] [code] ;
  25
  26 CHLOE: write-title
  27     drop
  28     "head" tag-stack get member?
  29     "title" tag-stack get member? not and
  30     [ get-title [XML <title><-></title> XML] ]
  31     [ get-title ] ?
  32     [xml-code] ;
  33
  34 CHLOE: style
  35     dup "include" optional-attr [
  36         utf8 file-contents [ add-style ] [code-with]
  37     ] [
  38         compile-children>string [ add-style ] [code]
  39     ] ?if ;
  40
  41 CHLOE: write-style
  42     drop [
  43         get-style
  44         [XML <style type="text/css"> <-> </style> XML]
  45     ] [xml-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 COMPONENT: xml
  99
 100 SYMBOL: template-cache
 101
 102 H{ } template-cache set-global
 103
 104 TUPLE: cached-template path last-modified quot ;
 105
 106 : load-template ( chloe -- cached-template )
 107     path>> ".xml" append
 108     [ ]
 109     [ file-info modified>> ]
 110     [ file>xml compile-template ] tri
 111     \ cached-template boa ;
 112
 113 \ load-template DEBUG add-input-logging
 114
 115 : cached-template ( chloe -- cached-template/f )
 116     template-cache get at* [
 117         [
 118             [ path>> file-info modified>> ]
 119             [ last-modified>> ]
 120             bi =
 121         ] keep and
 122     ] when ;
 123
 124 : template-quot ( chloe -- quot )
 125     dup cached-template [ ] [
 126         [ load-template dup ] keep
 127         template-cache get set-at
 128     ] ?if quot>> ;
 129
 130 : reset-cache ( -- )
 131     template-cache get clear-assoc ;
 132
 133 M: chloe call-template*
 134     template-quot call( -- ) ;
 135
 136 INSTANCE: chloe template