basis/html/templates/templates.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs boxes continuations debugger io
   4 io.encodings.utf8 io.files io.streams.string kernel namespaces
   5 prettyprint quotations sequences strings xml.data xml.syntax
   6 xml.writer ;
   7 IN: html.templates
   8
   9 MIXIN: template
  10
  11 GENERIC: call-template* ( template -- )
  12
  13 M: string call-template* write ;
  14
  15 M: callable call-template* call( -- ) ;
  16
  17 M: xml call-template* write-xml ;
  18
  19 M: object call-template* output-stream get stream-copy ;
  20
  21 ERROR: template-error template error ;
  22
  23 M: template-error error.
  24     "Error while processing template " write
  25     [ template>> short. ":" print nl ]
  26     [ error>> error. ]
  27     bi ;
  28
  29 : call-template ( template -- )
  30     [ call-template* ] [ \ template-error boa rethrow ] recover ;
  31
  32 ERROR: no-boilerplate ;
  33
  34 M: no-boilerplate error.
  35     drop
  36     "get-title and set-title can only be used from within" print
  37     "a with-boilerplate form" print ;
  38
  39 SYMBOL: title
  40
  41 : set-title ( string -- )
  42     title get [ >box ] [ no-boilerplate ] if* ;
  43
  44 : get-title ( -- string )
  45     title get [ value>> ] [ no-boilerplate ] if* ;
  46
  47 : write-title ( -- )
  48     get-title write ;
  49
  50 SYMBOL: style
  51
  52 : add-style ( string -- )
  53     "\n" style get push-all
  54          style get push-all ;
  55
  56 : get-style ( -- string )
  57     style get >string ;
  58
  59 : write-style ( -- )
  60     get-style write ;
  61
  62 SYMBOL: script
  63
  64 : add-script ( string -- )
  65     "\n" script get push-all
  66          script get push-all ;
  67
  68 : get-script ( -- string )
  69     script get >string ;
  70
  71 : write-script ( -- )
  72     get-script write ;
  73
  74 SYMBOL: meta
  75
  76 : add-meta ( name content -- )
  77     2array meta get push ;
  78
  79 : get-meta ( -- xml )
  80     meta get [
  81         [XML <meta name=<-> content=<->/> XML]
  82     ] { } assoc>map ;
  83
  84 : write-meta ( -- )
  85     get-meta write-xml ;
  86
  87 SYMBOL: atom-feeds
  88
  89 : add-atom-feed ( title url -- )
  90     2array atom-feeds get push ;
  91
  92 : get-atom-feeds ( -- xml )
  93     atom-feeds get [
  94         [XML
  95             <link
  96                 rel="alternate"
  97                 type="application/atom+xml"
  98                 title=<->
  99                 href=<->/>
 100         XML]
 101     ] { } assoc>map ;
 102
 103 : write-atom-feeds ( -- )
 104     get-atom-feeds write-xml ;
 105
 106 SYMBOL: nested-template?
 107
 108 SYMBOL: next-template
 109
 110 : call-next-template ( -- )
 111     next-template get write ;
 112
 113 M: f call-template* drop call-next-template ;
 114
 115 : with-boilerplate ( child master -- )
 116     [
 117         title [ [ <box> ] unless* ] change
 118         style [ [ SBUF" " clone ] unless* ] change
 119         script [ [ SBUF" " clone ] unless* ] change
 120         meta [ [ V{ } clone ] unless* ] change
 121         atom-feeds [ V{ } like ] change
 122
 123         [
 124             [
 125                 nested-template? on
 126                 call-template
 127             ] with-string-writer
 128             next-template set
 129         ]
 130         [ call-template ]
 131         bi*
 132     ] with-scope ; inline
 133
 134 : template-convert ( template output -- )
 135     utf8 [ call-template ] with-file-writer ;