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 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
     | Xtable
     | Paper | Slides | Link
47
48
     | <boxes-toc sections=?"">[]
     | <pages-toc sections=?"">[]
49
50
     | <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>[InlineText*]
61
   | Xa | Ximg | Xbr 
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
91
(** 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 ]
  |   ...
*)


92
93
94
95
96

(** Generic purpose functions **)

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

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

104
(* Highlighting text between {{...}} *)
105

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

114
115
(* Split a comma-separated string *)

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


121
(** Internal types **)
122

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

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

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

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

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

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

164
165

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

178
179
let box (x : Flow) : Block =
 <table cellpadding="2" 
180
181
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
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
229
230
   [ <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;
}
"

231
232
(* Main transformation function *)

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

240
241
242
 let footnote_counter = ref Int 0 in 
 let footnotes = ref Flow [] in

243
 let text (t : [InlineText*]) : Inlines =
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
  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 ']' ] ]
   | z -> [ z ]
261
 in
262

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

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

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

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

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

422

423
;;
424

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