site.cd 12.7 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 use --arg to specify an input file on the command line"
9

10
(** Output types **)
11

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

15

16
17
(** Input types **)

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

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

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

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

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

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

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

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
(** Error reporting **)

(*
let check_page(Any -> Any)
  | <page name=String new=?Any>[ title (banner :: <banner>_)? item::_* ] ->
        <page>[ (check_title title) 
	        !(map banner with x -> check_banner x);
                !(map item with x -> check_item x) ]
  | <page>_ ->
        <page>[ <error>"invalid attributes" ]
  | _ ->
        <error>"<page> expected"

let check_title(Any -> Any)
  | <title>String -> <title>"..."
  | <title>_ -> <title>[ <error>"PCDATA only under title" ]
  | _ -> <error>"<title> expected"

let check_banner(Any -> Any)
  | <banner>[ InlineText* ] -> <banner>"..."
  | <banner>s -> <banner>(check_inline_star s)
  | _ -> <error>"<banner> expected"

let check_inline_star(Any -> Any)
  | [ x :: Char+; rest ] -> [ '...'; check_inline_star rest ]
  |   ...
*)


91
92
93
94
(** Generic purpose functions **)

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

95
let load_include (String -> [Any*])
96
 name ->
97
(*   let _ = print [ 'Loading ' !name '... \n' ] in *)
98
   xtransform [ (load_xml name) ] with 
99
   | <include file=(s & String)>[] -> load_include s
100
   | <include-verbatim file=(s & String)>[] -> load_file s 
101

102
(* Highlighting text between {{...}} *)
103

104
let highlight (String -> [ (Char | Xvar | Xi)* ] )
105
106
 | [ '{{' h ::(Char *?) '}}' ; rest ] -> 
          [ <var class="highlight">h; highlight rest ]
107
 | [ '%%' h ::(Char *?) '%%' ; rest ] ->
108
          [ <i>h; highlight rest ] 
109
 | [ c; rest ] -> [ c; highlight rest ]
110
 | [] -> []
111

112
113
(* Split a comma-separated string *)

114
let split_comma (String -> [String*])
115
 | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)
116
 | s -> [ s ]
117
118


119
(** Internal types **)
120

121
type Path = [ { url = String; title = String }* ]
122
type Tree = { name = String; url = String; title = String; 
123
              children = [Tree*] } 
124

125
let url_of_name (String -> String)
126
   "index" -> "/"
127
 | s -> s @ ".html"
128

129
let authors ([Author+] -> String)
130
131
   | [ <author>a ] -> a
   | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
132
   | [ <author>a; rem ] -> a @ ", " @ authors rem
133

134
let find_local_link (sitemap : [Tree*], l : String) : Tree =
135
136
match sitemap with
 | (h,t) ->
137
   if (h . name = l) then h
138
139
140
   else 
    (try find_local_link (t,l) with `Not_found -> 
         find_local_link (h . children,l))
141
 | [] -> raise `Not_found
142

143
let local_link (sitemap : Tree, l : String, txt : String) : Inline =
144
145
146
147
 try 
  let h = find_local_link ([sitemap],l)  in
  let txt = if txt = "" then h . title else txt in
  <a href=(h . url)>txt
148
 with `Not_found -> raise [ 'Local link not found: ' !l ]
149
 
150
let compute_sitemap ((Page|External) -> Tree)
151
152
 <page name=name>[ <title>title (c::(Page|External) | _)* ] ->
   let children = map c with p -> compute_sitemap p in
153
   { name = name; url = (url_of_name name); title = title; children =children }
154
|<external name=name href=h title=t>[] ->
155
   { name = name; url = h; title = t; children = [] }
156

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

162
163

let boxes_of  (Page -> [Xul?])
164
     <page name=n>[ (items::Item | _)*] ->
165
166
        let toc = 
         transform items with 
167
          <box title=t link=l>_ -> [ <li>[ <a href=((url_of_name n)@('#',l))>t ] ] in
168
169
        (match toc with [] -> [] | lis -> [ <ul>lis ])
 
170
let link_to (Page -> Xa)
171
172
173
 <page name=n new=_>[<title>t ; _ ] -> 
               <a href=(url_of_name n)>[!t 
                      <img src="img/new.gif" alt="(new)" style="border:0">[]]
174
| <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
175

176
177
let box (x : Flow) : Block =
 <table cellpadding="2" 
178
179
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
   [ <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;
}
"

229
230
(* Main transformation function *)

231
(* returns the last page of the descendance *)
232
let gen_page (prev : Page|[], page : Page, next : Page|[], 
233
                  path : Path, sitemap : Tree) : (Page|[]) = 
234
match page with
235
236
<page name=name>[ 
        <title>title <banner>banner | <title>(title & banner); items ] ->
237

238
239
240
 let footnote_counter = ref Int 0 in 
 let footnotes = ref Flow [] in

241
 let text (t : [InlineText*]) : Inlines =
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
  transform t with
   | <code>x -> [ <b>[ <tt>(highlight x) ] ]
   | <local href=l>txt -> [ (local_link (sitemap,l,txt)) ]
   | <(tag & (`b|`i|`tt|`em)) (attr)>x -> [ <(tag) (attr)>(text x) ]
(*   | <a href=url>_ & z -> let [] = print [ 'Link: ' !url '\n'] in [z] *)
   | <footnote>c -> 
      footnote_counter := !footnote_counter + 1;
      let n = string_of !footnote_counter in
      let fn = !footnotes in
      footnotes := [];
      let c = <p>[ <a name=[ 'note' !n ]>[] 
                   <a href=[ '#bnote' !n ]>[ '[' !n ']' ]
		   ' ' ; text c ] in
      footnotes := fn @ [ c ] @ !footnotes;
      [ <a name=[ 'bnote' !n ]>[]
        <a href=[ '#note' !n ]>[ '[' !n ']' ] ]
258
   | z -> [ z ] 
259
 in
260

261
 let content (t : Content) : Flow =
262
  transform t with
263
   | <section title=title>c -> 
264
         [ <p>[ <b style="color: #008000">title ] !(content c) ]
265
   | <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab  ]  ->
266
         [ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. '
267
           !(authors aut) '. '
268
	   !(text com)
269
270
271
           <div class="abstract">[ 'Abstract:' !(content ab) ]
         ]
   | <slides file=f>[ <title>tit aut::Author* <comment>com ]  ->
272
        [ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
273
274
   | <sample highlight="false">s ->
        [ <div class="code">[ <pre>s ] ]
275
   | <sample>s ->
276
        [ <div class="code">[ <pre>(highlight s) ] ]
277
   | <link url=url title=title>com -> 
278
279
280
281
282
        [ <a href=url>title '. ' !(text com) ]
   | <ul>lis -> 
        [ <ul>(map lis with <li>x -> <li>(content x)) ]
   | Xtable & x -> 
        [ x ]
283
   | <p (attr)>x -> [ <p (attr)>(text x) ]
284
285
   | <pages-toc (a)>[] ->
       let toc = 
286
         transform items with 
287
288
         | Page & p ->  [ <li>[ (link_to p) 
                           !(match a with {|sections=_|} -> (boxes_of p) | _ -> [])] ]
289
         | <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in
290
        (match toc with [] -> [] | lis -> [ <ul>lis ])
291
   | <boxes-toc (a)>[] ->
292
293
        let toc = 
         transform items with 
294
295
296
297
298
299
          <box title=t link=l>b -> [ <li>[ <a href=('#',l)>t 
             !(match a with 
                | {|sections=_|} -> 
                     (transform b with <section title=t>_ -> [<br>[] '-' !t])
                | _ ->[])]]
        in (match toc with [] -> [] | lis -> [ <ul>lis ])
300
301
302
303
304
   | <site-toc>[] ->
        [ <ul>[ (display_sitemap sitemap) ] ]
   | <local-links href=s>[] ->
         (match (split_comma s) with
           | [] -> []
305
           | l -> let l = map l with x -> <li>[ (local_link(sitemap,x,"")) ]
306
                  in [ <ul>l ])
307
308
309
310
311
   | <two-columns>[ <left>x <right>y ] ->
	[ <table width="100%">[ 
            <tr>[ 
              <td valign="top">(content x) 
              <td valign="top">(content y) ] ] ]
312
313
   | t -> text [ t ]
 in
314

315
(* Preparing left panel *)
316

317
318
319
320
 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">[
321
     <table cellpadding="0" cellspacing="15" 
322
323
324
            width="200"
            style="font-size:80%; border: 1px dashed black;
                   background: #ffcd72">
325
326
     (map left with x -> <tr>[ <td>[ (box (content x)) ] ]) ] in

327
 let dpath : Inlines = transform path with 
328
  | { url = f; title = t } -> [ <a href=f>t ': '] 
329
 in
330
 let npath = path @ [ { url = (url_of_name name); title = title } ] in
331
 let subpages = transform items with p & Page -> [ p ] in
332
 let (next,last) = gen_page_seq (page, subpages, next, npath, sitemap) in
333
334
335
 let next = match next with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
336
          <img width="16" height="16" class="icon" alt="Next page:"
337
               src="img/right.gif">[]
338
339
340
341
342
          ' ' !t
        ] ] in
 let prev = match prev with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
343
          <img width="16" height="16" class="icon"
344
               alt="Previous page:" src="img/left.gif">[]
345
346
          ' ' !t
        ] ] in
347
 let navig = 
348
   if prev = [] then [] else
349
   [ (box [
350
     <p>[ !dpath !title ]
351
352
353
354
355
356
357
358
359
360
361
     <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
362
363
364
365
 let notes = match !footnotes with
   | [] -> []
   | n -> [ (meta n) ] in
 let main = match (navig @ main @ notes @ navig) with
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
   | [] -> 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">[
381
       <table width="100%" cellpadding="0" cellspacing="17">
382
383
384
385
         (map main with x -> <tr>[ <td>[x] ])
      ] ]
  ] ] in

386
 let html : Xhtml =
387
388
 <html>[
  <head>[ 
389
   <title>[ 'CDuce: ' !title ]
390
   <meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">[]
391
   <style type="text/css">style
392
  ]
393
394
395
396
  <body style="margin: 0; padding : 0; background: #fcb333">[ 
   <table cellspacing="10" cellpadding="0" width="100%" border="0">[
    <tr>[ left right ]
   ]
397
  ]
398
399
 ]
 in
400
 let txt : Latin1 = 
401
   [ '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'
402
     '  "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'
403
404
     !(print_xml html) ] in
 let fn = "www/" @ name @ ".html" in
405
 dump_to_file fn txt;
406
 last
407
	
408

409
let gen_page_seq 
410
 (prev : Page|[], pages : [Page*], next : Page|[], 
411
  path : Path, sitemap : Tree) : (Page|[], Page|[]) =
412
413
 match pages with
 | [ p1 p2 ; _ ] & [ _; rest ] -> 
414
415
416
     let last = gen_page (prev,p1,p2, path, sitemap) in
     let (_,last)  = gen_page_seq (last, rest, next, path, sitemap) in 
     (p1,last)
417
 | [ p ] ->
418
     let last = gen_page (prev,p,next, path, sitemap) in (p,last)
419
 | [] -> (next,prev)
420

421

422
;;
423

424
match load_include input with
425
 | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
426
 | _ -> raise ("Invalid input document " @ input)
427

428