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