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