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
   5 memoize io io.files io.encodings.utf8 io.streams.string
   6 unicode.case mirrors math urls present multiline quotations xml
   7 xml.data
   8 html.forms
   9 html.elements
  10 html.components
  11 html.templates
  12 html.templates.chloe.compiler
  13 html.templates.chloe.components
  14 html.templates.chloe.syntax ;
  15 IN: html.templates.chloe
  16
  17 ! Chloe is Ed's favorite web designer
  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     [ <title> write-title </title> ] [ write-title ] ? [code] ;
  31
  32 CHLOE: style
  33     dup "include" optional-attr [
  34         utf8 file-contents [ add-style ] [code-with]
  35     ] [
  36         compile-children>string [ add-style ] [code]
  37     ] ?if ;
  38
  39 CHLOE: write-style
  40     drop [ <style> write-style </style> ] [code] ;
  41
  42 CHLOE: even
  43     [ "index" value even? swap when ] process-children ;
  44
  45 CHLOE: odd
  46     [ "index" value odd? swap when ] process-children ;
  47
  48 : (bind-tag) ( tag quot -- )
  49     [
  50         [ "name" required-attr compile-attr ] keep
  51     ] dip process-children ; inline
  52
  53 CHLOE: each [ with-each-value ] (bind-tag) ;
  54
  55 CHLOE: bind-each [ with-each-object ] (bind-tag) ;
  56
  57 CHLOE: bind [ with-form ] (bind-tag) ;
  58
  59 CHLOE: comment drop ;
  60
  61 CHLOE: call-next-template
  62     drop reset-buffer \ call-next-template , ;
  63
  64 : attr>word ( value -- word/f )
  65     ":" split1 swap lookup ;
  66
  67 : if>quot ( tag -- quot )
  68     [
  69         [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
  70         [ "value" optional-attr [ , \ value , ] [ t , ] if* ]
  71         bi
  72         \ and ,
  73     ] [ ] make ;
  74
  75 CHLOE: if dup if>quot [ swap when ] append process-children ;
  76
  77 CHLOE-SINGLETON: label
  78 CHLOE-SINGLETON: link
  79 CHLOE-SINGLETON: inspector
  80 CHLOE-SINGLETON: comparison
  81 CHLOE-SINGLETON: html
  82 CHLOE-SINGLETON: hidden
  83
  84 CHLOE-TUPLE: farkup
  85 CHLOE-TUPLE: field
  86 CHLOE-TUPLE: textarea
  87 CHLOE-TUPLE: password
  88 CHLOE-TUPLE: choice
  89 CHLOE-TUPLE: checkbox
  90 CHLOE-TUPLE: code
  91
  92 : read-template ( chloe -- xml )
  93     path>> ".xml" append utf8 <file-reader> read-xml ;
  94
  95 MEMO: template-quot ( chloe -- quot )
  96     read-template compile-template ;
  97
  98 MEMO: nested-template-quot ( chloe -- quot )
  99     read-template compile-nested-template ;
 100
 101 : reset-templates ( -- )
 102     { template-quot nested-template-quot } [ reset-memoized ] each ;
 103
 104 M: chloe call-template*
 105     nested-template? get
 106     [ nested-template-quot ] [ template-quot ] if
 107     assert-depth ;
 108
 109 INSTANCE: chloe template