basis/html/templates/chloe/chloe.factor

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