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

3
4
(** Command line **)

5
let input =
6
  match argv with
7
  | [ s ] -> s
8
  | _ -> raise "Please specify an input file on the command line"
9
10


11
(** Output types **)
12

13
14
include "xhtml-strict.cd"  (* XHTML 1 Strict DTD *)
include "xhtml-categ.cd"   (* Categories (Inline, ...) from this DTD *)
15

16

17
18
(** Input types **)

19
type Page =  <page name=String new=?Any>[ <title>String <banner>[InlineText*]? Item* ]
20
type External = <external {|href=String; title=String; name=String |}>[]
21
22

type Item = 
23
   <box title=String link=String>Content
24
25
26
 | <meta>Content
 | <left>Content
 | Page
27
 | External
28

29
type Author = <author>String
30
31
type Paper = 
  <paper file=?String>[ 
32
     <title>String Author+ <comment>[InlineText*] <abstract>Content ]
33
34

type Slides = 
35
  <slides file=String>[ <title>String Author+ <comment>[InlineText*] ]
36
37

type Link =
38
  <link url=String title=String>[ InlineText* ]
39
40

type Content =      
41
   [ ( <p {|style=?String|}>[InlineText*]
42
43
     | <ul {||}>[<li {||}>Content +]
     | <section title=String>Content
44
     | <sample highlight=?"true"|"false">String
45
46
47
48
49
50
     | Xtable
     | Paper | Slides | Link
     | <boxes-toc>[]
     | <pages-toc>[]
     | <site-toc>[]
     | <local-links href=String>[]
51
     | <two-columns>[ <left>Content <right>Content ]
52
     | InlineText
53
     )* ]
54
55
56

type InlineText =
     Char
57
   | <(`b|`i|`tt|`em) {| style=?String |}>[InlineText*]
58
   | <code>String
59
   | <local href=String>String
60
   | <footnote>Content
61
   | Xa | Ximg | Xbr 
62
63
64
65
66
67


(** Generic purpose functions **)

(* Recursive inclusion of XML files and verbatim text files *)

68
let load_include (String -> [Any*])
69
 name ->
70
(*   let _ = print [ 'Loading ' !name '... \n' ] in *)
71
   xtransform [ (load_xml name) ] with 
72
   | <include file=(s & String)>[] -> load_include s
73
   | <include-verbatim file=(s & String)>[] -> load_file s 
74

75
(* Highlighting text between {{...}} *)
76

77
let highlight (String -> [ (Char | Xvar | Xi)* ] )
78
79
 | [ '{{' h ::(Char *?) '}}' ; rest ] -> 
          [ <var class="highlight">h; highlight rest ]
80
 | [ '%%' h ::(Char *?) '%%' ; rest ] ->
81
          [ <i>h; highlight rest ]
82
 | [ c; rest ] -> [ c; highlight rest ]
83
 | [] -> []
84

85
86
(* Split a comma-separated string *)

87
let split_comma (String -> [String*])
88
 | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)
89
 | s -> [ s ]
90
91


92
(** Internal types **)
93

94
type Path = [ { url = String; title = String }* ]
95
type Tree = { name = String; url = String; title = String; 
96
              children = [Tree*] } 
97

98
let url_of_name (String -> String)
99
   "index" -> "/"
100
 | s -> s @ ".html"
101

102
let authors ([Author+] -> String)
103
104
   | [ <author>a ] -> a
   | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
105
   | [ <author>a; rem ] -> a @ ", " @ authors rem
106

107
let find_local_link (sitemap : [Tree*], l : String) : Tree =
108
109
match sitemap with
 | (h,t) ->
110
   if (h . name = l) then h
111
112
113
   else 
    (try find_local_link (t,l) with `Not_found -> 
         find_local_link (h . children,l))
114
 | [] -> raise `Not_found
115

116
let local_link (sitemap : Tree, l : String, txt : String) : Inline =
117
118
119
120
 try 
  let h = find_local_link ([sitemap],l)  in
  let txt = if txt = "" then h . title else txt in
  <a href=(h . url)>txt
121
 with `Not_found -> raise [ 'Local link not found: ' !l ]
122
 
123
let compute_sitemap ((Page|External) -> Tree)
124
125
 <page name=name>[ <title>title (c::(Page|External) | _)* ] ->
   let children = map c with p -> compute_sitemap p in
126
   { name = name; url = url_of_name name; title = title; children =children }
127
|<external name=name href=h title=t>[] ->
128
   { name = name; url = h; title = t; children = [] }
129

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

135
let link_to (Page -> Xa)
136
137
138
 <page name=n new=_>[<title>t ; _ ] -> 
               <a href=(url_of_name n)>[!t 
                      <img src="img/new.gif" alt="(new)" style="border:0">[]]
139
| <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
140

141
142
let box (x : Flow) : Block =
 <table cellpadding="2" 
143
144
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
   [ <tr> [<td>x] ]

let meta (x : Flow) : Block =
 <table cellpadding="2" 
    style="border: solid 1px #b0b0b0; background: #e0e0e0; font-size: 80%" 
    width="100%">
   [ <tr> [<td>x] ]

let box_title (x : Flow, t : String) : Block =
 <table cellpadding="5" 
    style="border: solid 2px black; background: #ffffff" width="100%">
   [ <tr>[ <td style="background: #fff0f0; color: #0000ff; font: bold
100% helvetica">t ] <tr> [<td>x] ]

let style = "
a:link:hover, a:visited:hover {
  text-decoration: none;
  background: #FFFFD0;
  color: #FF0000;
}
p {
  text-align: justify;
  margin: 1ex 1em 0 1em;
}
pre {
  margin: 1ex 1em 0 1em;
}
var.highlight {
  color: #FF0000;
}
img.icon {
  border: 0;
}
div.code {
  background: #E0E0E0;
  margin: 0.5ex 0.5em 0 0.5em;
  padding: 0.2ex;
}
div.abstract { 
  font: bold 80% helvetica;
  margin: 1ex 1em 1ex 1em;
  padding: 1ex 1em 1ex 1em;
  background: #F0F0F0;
}
div.abstract p { 
  font: 100% sans-serif;
}
"

194
195
(* Main transformation function *)

196

197
(* returns the last page of the descendance *)
198
let gen_page (prev : Page|[], page : Page, next : Page|[], 
199
                  path : Path, sitemap : Tree) : (Page|[]) = 
200
match page with
201
202
<page name=name>[ 
        <title>title <banner>banner | <title>(title & banner); items ] ->
203

204
 let text (t : [InlineText*]) : Inlines =
205
  map t with
206
   | <code>x -> <b>[ <tt>(highlight x) ]
207
   | <local href=l>txt -> local_link (sitemap,l,txt)
208
   | <(tag & (`b|`i|`tt|`em)) (attr)>x -> <(tag) (attr)>(text x)
209
(*   | <a href=url>_ & z -> let [] = print [ 'Link: ' !url '\n'] in z *)
210
   | <footnote>_ -> raise "Footnotes not yet implemented !"
211
212
   | z -> z
 in
213

214
 let content (t : Content) : Flow =
215
  transform t with
216
   | <section title=title>c -> 
217
         [ <p>[ <b style="color: #008000">title ] !(content c) ]
218
   | <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab  ]  ->
219
         [ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. '
220
           !(authors aut) '. '
221
	   !(text com)
222
223
224
           <div class="abstract">[ 'Abstract:' !(content ab) ]
         ]
   | <slides file=f>[ <title>tit aut::Author* <comment>com ]  ->
225
        [ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
226
227
   | <sample highlight="false">s ->
        [ <div class="code">[ <pre>s ] ]
228
   | <sample>s ->
229
        [ <div class="code">[ <pre>(highlight s) ] ]
230
   | <link url=url title=title>com -> 
231
232
233
234
235
        [ <a href=url>title '. ' !(text com) ]
   | <ul>lis -> 
        [ <ul>(map lis with <li>x -> <li>(content x)) ]
   | Xtable & x -> 
        [ x ]
236
   | <p (attr)>x -> [ <p (attr)>(text x) ]
237
238
239
   | <pages-toc>[] ->
        let toc = 
         transform items with 
240
         | Page & p ->  [ <li>[ (link_to p) ] ]
241
         | <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in
242
243
244
245
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <boxes-toc>[] ->
        let toc = 
         transform items with 
246
          <box title=t link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in
247
248
249
250
251
252
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <site-toc>[] ->
        [ <ul>[ (display_sitemap sitemap) ] ]
   | <local-links href=s>[] ->
         (match (split_comma s) with
           | [] -> []
253
           | l -> let l = map l with x -> <li>[ (local_link(sitemap,x,"")) ]
254
                  in [ <ul>l ])
255
256
257
258
259
   | <two-columns>[ <left>x <right>y ] ->
	[ <table width="100%">[ 
            <tr>[ 
              <td valign="top">(content x) 
              <td valign="top">(content y) ] ] ]
260
261
   | t -> text [ t ]
 in
262

263
264
265
266
267
268

(* Preparing left panel *)
 let navig = transform items with <left>c -> [ c ] in
 let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in
 let left = 
   <td valign="top" align="left">[
269
     <table cellpadding="0" cellspacing="15" 
270
271
272
            width="200"
            style="font-size:80%; border: 1px dashed black;
                   background: #ffcd72">
273
274
     (map left with x -> <tr>[ <td>[ (box (content x)) ] ]) ] in

275
 let dpath : Inlines = transform path with 
276
  | { url = f; title = t } -> [ <a href=f>t ': '] 
277
 in
278
279
 let npath = path @ [ { url = url_of_name name; title = title } ] in
 let subpages = transform items with p & Page -> [ p ] in
280
 let (next,last) = gen_page_seq (page, subpages, next, npath, sitemap) in
281
282
283
 let next = match next with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
284
          <img width="16" height="16" class="icon" alt="Next page:"
285
               src="img/right.gif">[]
286
287
288
289
290
          ' ' !t
        ] ] in
 let prev = match prev with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
291
          <img width="16" height="16" class="icon"
292
               alt="Previous page:" src="img/left.gif">[]
293
294
          ' ' !t
        ] ] in
295
 let navig = 
296
   if prev = [] then [] else
297
   [ (box [
298
     <p>[ !dpath !title ]
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
     <p>[ !prev ' ' !next ] ]) ] in

(* Preparing main panel *)
 let main = transform items with
  | <box (r)>c ->
      let b = [
         <a name=(r . link)>[] 
         !(content c) ] in
      [ (box_title (b,r . title)) ]
 | <meta>c -> [ (meta (content c)) ]
 in
 let main = match (navig @ main @ navig) with
   | [] -> raise "Empty page !"
   | x -> x in

 let right : Xtd =
  <td valign="top" align="left" style="width:100%">[
   <table width="100%">[
    <tr>[ <td valign="top" align="left"
              style="border: 2px solid black; background: #ffffff;
text-align:center; color: #aa0000; font: bold 200% helvetica" >
          (text banner)
        ]
 
    <tr>[
      <td valign="top" align="left"
          style="border: 1px solid black; background: #fccead">[
326
       <table width="100%" cellpadding="0" cellspacing="17">
327
328
329
330
         (map main with x -> <tr>[ <td>[x] ])
      ] ]
  ] ] in

331
 let html : Xhtml =
332
333
 <html>[
  <head>[ 
334
   <title>[ 'CDuce: ' !title ]
335
   <meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">[]
336
   <style type="text/css">style
337
  ]
338
339
340
341
  <body style="margin: 0; padding : 0; background: #fcb333">[ 
   <table cellspacing="10" cellpadding="0" width="100%" border="0">[
    <tr>[ left right ]
   ]
342
  ]
343
344
 ]
 in
345
 let txt : Latin1 = 
346
   [ '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'
347
     '  "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'
348
349
     !(print_xml html) ] in
 let fn = "www/" @ name @ ".html" in
350
 let [] = dump_to_file fn txt in
351
 last
352
	
353

354
let gen_page_seq 
355
 (prev : Page|[], pages : [Page*], next : Page|[], 
356
  path : Path, sitemap : Tree) : (Page|[], Page|[]) =
357
358
 match pages with
 | [ p1 p2 ; _ ] & [ _; rest ] -> 
359
360
361
     let last = gen_page (prev,p1,p2, path, sitemap) in
     let (_,last)  = gen_page_seq (last, rest, next, path, sitemap) in 
     (p1,last)
362
 | [ p ] ->
363
     let last = gen_page (prev,p,next, path, sitemap) in (p,last)
364
 | [] -> (next,prev)
365

366

367
;;
368

369
match load_include input with
370
 | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
371
 | _ -> raise ("Invalid input document " @ input)
372