site.cd 7.34 KB
Newer Older
1
2
3
(* This CDuce script produces CDuce web site. *)


4
5
include "xhtml-strict.cd";;  (* XHTML 1 Strict DTD *)
include "xhtml-categ.cd";;   (* Categories (Inline, ...) from this DTD *)
6

7
8
9
10
11

let fun load_include (String -> [Any*])
 name ->
   let _ = print [ 'Loading ' !name '... \n' ] in
   xtransform [ (load_xml name) ] with 
12
13
   | <include file=(s & String)>[] -> load_include s
   | <include-verbatim file=(s & String)>[] -> load_file s;; 
14
15


16
17
18
19
let fun highlight (String -> [ (Char | Xvar)* ] )
 | [ '{{' h ::(Char *?) '}}' ; rest ] -> 
          [ <var class="highlight">h; highlight rest ]
 | [ c; rest ] -> [ c; highlight rest ]
20
21
 | [] -> [];;

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
let fun split_comma (String -> [String*])
 | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)
 | s -> [ s ];;


(* Ugly hack to introduce PHP code ...
   The idea is to produce first an XML document with a distinguished element.
   The function patch_css search for the textual representation of this
   element and replace it with the PHP code. *)

let php_css : String =
[' <?php
$browser = getenv("HTTP_USER_AGENT");
if (preg_match("/MSIE/i", "$browser")) {
        $css = "<link rel=\\"stylesheet\\" href=\\"cduce.css\\"
type=\\"text/css\\">";
} elseif (preg_match("/Mozilla/i", "$browser")) {
        $css = "<blink>For better presentation use a more recent version
of your browser, like Netscape 6</blink>";
} if (preg_match("/Mozilla\\/5.0/i", "$browser")) {
        $css = "<link rel=\\"stylesheet\\" href=\\"cduce.css\\"
type=\\"text/css\\">";
} elseif  (preg_match("/opera/i", "$browser")) {
        $css = "<link rel=\\"stylesheet\\" href=\\"cduce.css\\"
type=\\"text/css\\">";
}
echo "$css";
?> '];;


let fun patch_css (String -> String)
| [ a::_*? '<meta content="css"/>'; rem ] -> a @ php_css @ rem
| s -> s;;



58

59

60
type Page = 
61
  <page name=String>[
62
63
    <title>String
    <banner>[InlineText*]
64
65
66
67
68
69
70
71
72
73
74
    Item*
  ];;

type External = <external {|href=String; title=String; name=String |}>[];;

type Item = 
   <box title=String; subtitle=?String; link=String>Content
 | <meta>Content
 | <left>Content
 | Page
 | External;;
75
76
77

type Author = <author>String;;
type Paper = 
78
79
80
81
82
83
  <paper file=?String>[ 
    <title>String 
    Author+ 
    <comment>[InlineText*] 
    <abstract>Content ];;

84
type Slides = 
85
86
87
88
  <slides file=String>[ 
   <title>String 
   Author+ 
   <comment>[InlineText*] ];;
89
90

type Link =
91
  <link url=String; title=String>[ InlineText* ];;
92
93
94
95
96

type Content =      
   [ ( <p {||}>[InlineText*]
     | <ul {||}>[<li {||}>Content +]
     | <section title=String>Content
97
     | <sample>String
98
     | Xtable
99
100
101
102
103
104
105
     | Paper | Slides | Link
     | <boxes-toc>[]
     | <pages-toc>[]
     | <site-toc>[]
     | <local-links href=String>[]
     | InlineText
     )* ];;
106
107
108

type InlineText =
     Char
109
   | <(`b|`i|`tt|`em) {||}>[InlineText*]
110
111
112
   | <code>String
   | <local href=String>[]
   | Xa | Ximg | Xbr ;;
113

114
115
116
type Path = [ { url = String; title = String }* ];;
type Tree = { name = String; url = String; title = String; 
              children = [Tree*] } ;;
117
118
119
120
121
122

let fun authors ([Author+] -> String)
   | [ <author>a ] -> a
   | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
   | [ <author>a; rem ] -> a @ ", " @ authors rem;;

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
let fun find_local_link (sitemap : [Tree*], l : String) : Inline =
match sitemap with
 | (h,t) ->
   if (h . name = l) then <a href=(h . url)>(h . title)
   else 
    (try find_local_link (t,l) with `Not_found -> 
         find_local_link (h . children,l))
 | [] -> raise `Not_found;;

let fun local_link (sitemap : Tree, l : String) : Inline =
 try find_local_link ([sitemap],l) 
 with `Not_found -> raise [ 'Local link not found: ' !l ];;
 

let fun compute_sitemap ((Page|External) -> Tree)
 <page name=name>[ <title>title (c::(Page|External) | _)* ] ->
   let children = map c with p -> compute_sitemap p in
   { name = name; url = name; title = title; children =children }
|<external name=name; href=h; title=t>[] ->
   { name = name; url = h; title = t; children = [] };;

let fun display_sitemap (h : Tree) :  Xli =
  let ch = map h . children with x -> display_sitemap x in
  let ch = match ch with [] -> [] | l -> [ <ul>l ] in
  <li>[ <a href=(h . url)>(h . title); ch ];;

let fun gen_page (page : Page, path : Path, sitemap : Tree) : [] = 
match page with
<page name=name>[ <title>title <banner>banner ; items ] ->

 let fun text (t : [InlineText*]) : Inlines =
154
  map t with
155
156
   | <code>x -> <b>[ <tt>(highlight x) ]
   | <local href=l>[] -> local_link (sitemap,l)
157
   | <(tag & (`b|`i|`tt|`em))>x -> <(tag)>(text x)
158
159
   | z -> z
 in
160

161
 let fun content (t : Content) : Flow =
162
  transform t with
163
164
   | <section title=title>c -> 
         [ <h4>title !(content c) ]
165
   | <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab  ]  ->
166
         [ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. '
167
           !(authors aut) '. '
168
	   !(text com)
169
170
171
           <div class="abstract">[ 'Abstract:' !(content ab) ]
         ]
   | <slides file=f>[ <title>tit aut::Author* <comment>com ]  ->
172
        [ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
173
   | <sample>s ->
174
        [ <div class="code">[ <pre>(highlight s) ] ]
175
176
177
178
179
180
   | <link url=url; title=title>com -> 
        [ <a href=url>title '. ' !(text com) ]
   | <ul>lis -> 
        [ <ul>(map lis with <li>x -> <li>(content x)) ]
   | Xtable & x -> 
        [ x ]
181
   | <p>x -> [ <p>(text x) ]
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
   | <pages-toc>[] ->
        let toc = 
         transform items with 
           <page name=l>[<title>t;_]
         | <external href=l; title=t>[] -> [ <li>[ <a href=l>t ] ] in
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <boxes-toc>[] ->
        let toc = 
         transform items with 
          <box title=t; link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <site-toc>[] ->
        [ <ul>[ (display_sitemap sitemap) ] ]
   | <local-links href=s>[] ->
         (match (split_comma s) with
           | [] -> []
           | l -> let l = map l with x -> <li>[ (local_link(sitemap,x)) ]
                  in [ <ul>l ])
   | t -> text [ t ]
 in
202

203
204
205
206
207
208
209
210
211
212
213
214
215
216
 let main : Flow = transform items with
  | <box (r)>c ->
     [ <div class="box">[
         <h2>(r . title)
          !(match r with { subtitle = t } -> [<b>t] | _ -> [])
         <a name=r . link>[] 
         !(content c)  ] ]
  | <meta>c -> [ <div class="meta">(content c) ] 
 in
 let navig : Flow = transform items with 
  | <left>c -> [<div class="box">(content c)] 
 in
 let dpath : Inlines = transform path with 
  | { url = f; title = t } -> [ <a href=f>t ' :: '] 
217
 in
218
 let html : Xhtml =
219
220
221
222
 <html>[
  <head>[ 
   <title>title
   <meta content="text/html; charset=iso-8859-1"; http-equiv="Content-Type">[]
223
   <meta content="css">[]  (* Placeholder for PHP code *)
224
225
  ]
  <body>[ 
226
   <div class="title">[ <h1>(text banner) <p>[ !dpath !title ] ]
227
   <div id="Sidelog">navig
228
   <div id="Content">main
229
  ]
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
 ]
 in
 let txt : String = 
   [ (* '<?xml version="1.0" encoding="iso-8859-1"?>' *)
     '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'
     '  "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'
     !(patch_css (print_xml html)) ] in
 let _ = print [ 'Generating page ' !name '...\n' ] in
 let filename = name @ ".php" in
 let _ = dump_to_file filename txt in
 let path = path @ [ { url = name; title = title } ] in
 transform items with p & Page -> gen_page (p,path,sitemap);;
    


match load_include "site.xml" with
 | [ Page & p ] ->
     let sitemap = compute_sitemap p in
     gen_page (p,[],sitemap)
249
 | _ -> raise "Invalid site.xml";;
250