site.cd 11.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
47
     | Xtable
     | Paper | Slides | Link
     | <boxes-toc>[]
48
     | <pages-toc subsections=?"">[]
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


(** 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
136
137
138
139
140
141
142

let boxes_of  (Page -> [Xul?])
     <page>[ (items::Item | _)*] ->
        let toc = 
         transform items with 
          <box title=t link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in
        (match toc with [] -> [] | lis -> [ <ul>lis ])
 
143
let link_to (Page -> Xa)
144
145
146
 <page name=n new=_>[<title>t ; _ ] -> 
               <a href=(url_of_name n)>[!t 
                      <img src="img/new.gif" alt="(new)" style="border:0">[]]
147
| <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
148

149
150
let box (x : Flow) : Block =
 <table cellpadding="2" 
151
152
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
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
194
195
196
197
198
199
200
201
   [ <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;
}
"

202
203
(* Main transformation function *)

204
(* returns the last page of the descendance *)
205
let gen_page (prev : Page|[], page : Page, next : Page|[], 
206
                  path : Path, sitemap : Tree) : (Page|[]) = 
207
match page with
208
209
<page name=name>[ 
        <title>title <banner>banner | <title>(title & banner); items ] ->
210

211
212
213
 let footnote_counter = ref Int 0 in 
 let footnotes = ref Flow [] in

214
 let text (t : [InlineText*]) : Inlines =
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
  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 ]
232
 in
233

234
 let content (t : Content) : Flow =
235
  transform t with
236
   | <section title=title>c -> 
237
         [ <p>[ <b style="color: #008000">title ] !(content c) ]
238
   | <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab  ]  ->
239
         [ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. '
240
           !(authors aut) '. '
241
	   !(text com)
242
243
244
           <div class="abstract">[ 'Abstract:' !(content ab) ]
         ]
   | <slides file=f>[ <title>tit aut::Author* <comment>com ]  ->
245
        [ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
246
247
   | <sample highlight="false">s ->
        [ <div class="code">[ <pre>s ] ]
248
   | <sample>s ->
249
        [ <div class="code">[ <pre>(highlight s) ] ]
250
   | <link url=url title=title>com -> 
251
252
253
254
255
        [ <a href=url>title '. ' !(text com) ]
   | <ul>lis -> 
        [ <ul>(map lis with <li>x -> <li>(content x)) ]
   | Xtable & x -> 
        [ x ]
256
   | <p (attr)>x -> [ <p (attr)>(text x) ]
257
258
   | <pages-toc (a)>[] ->
       let toc = 
259
         transform items with 
260
261
         | Page & p ->  [ <li>[ (link_to p) 
                           !(match a with {|sections=_|} -> (boxes_of p) | _ -> [])] ]
262
         | <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in
263
264
265
266
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <boxes-toc>[] ->
        let toc = 
         transform items with 
267
          <box title=t link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in
268
269
270
271
272
273
        (match toc with [] -> [] | lis -> [ <ul>lis ])
   | <site-toc>[] ->
        [ <ul>[ (display_sitemap sitemap) ] ]
   | <local-links href=s>[] ->
         (match (split_comma s) with
           | [] -> []
274
           | l -> let l = map l with x -> <li>[ (local_link(sitemap,x,"")) ]
275
                  in [ <ul>l ])
276
277
278
279
280
   | <two-columns>[ <left>x <right>y ] ->
	[ <table width="100%">[ 
            <tr>[ 
              <td valign="top">(content x) 
              <td valign="top">(content y) ] ] ]
281
282
   | t -> text [ t ]
 in
283

284
285
286
287
288
(* 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">[
289
     <table cellpadding="0" cellspacing="15" 
290
291
292
            width="200"
            style="font-size:80%; border: 1px dashed black;
                   background: #ffcd72">
293
294
     (map left with x -> <tr>[ <td>[ (box (content x)) ] ]) ] in

295
 let dpath : Inlines = transform path with 
296
  | { url = f; title = t } -> [ <a href=f>t ': '] 
297
 in
298
 let npath = path @ [ { url = (url_of_name name); title = title } ] in
299
 let subpages = transform items with p & Page -> [ p ] in
300
 let (next,last) = gen_page_seq (page, subpages, next, npath, sitemap) in
301
302
303
 let next = match next with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
304
          <img width="16" height="16" class="icon" alt="Next page:"
305
               src="img/right.gif">[]
306
307
308
309
310
          ' ' !t
        ] ] in
 let prev = match prev with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
311
          <img width="16" height="16" class="icon"
312
               alt="Previous page:" src="img/left.gif">[]
313
314
          ' ' !t
        ] ] in
315
 let navig = 
316
   if prev = [] then [] else
317
   [ (box [
318
     <p>[ !dpath !title ]
319
320
321
322
323
324
325
326
327
328
329
     <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
330
331
332
333
 let notes = match !footnotes with
   | [] -> []
   | n -> [ (meta n) ] in
 let main = match (navig @ main @ notes @ navig) with
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
   | [] -> 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">[
349
       <table width="100%" cellpadding="0" cellspacing="17">
350
351
352
353
         (map main with x -> <tr>[ <td>[x] ])
      ] ]
  ] ] in

354
 let html : Xhtml =
355
356
 <html>[
  <head>[ 
357
   <title>[ 'CDuce: ' !title ]
358
   <meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">[]
359
   <style type="text/css">style
360
  ]
361
362
363
364
  <body style="margin: 0; padding : 0; background: #fcb333">[ 
   <table cellspacing="10" cellpadding="0" width="100%" border="0">[
    <tr>[ left right ]
   ]
365
  ]
366
367
 ]
 in
368
 let txt : Latin1 = 
369
   [ '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'
370
     '  "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'
371
372
     !(print_xml html) ] in
 let fn = "www/" @ name @ ".html" in
373
 dump_to_file fn txt;
374
 last
375
	
376

377
let gen_page_seq 
378
 (prev : Page|[], pages : [Page*], next : Page|[], 
379
  path : Path, sitemap : Tree) : (Page|[], Page|[]) =
380
381
 match pages with
 | [ p1 p2 ; _ ] & [ _; rest ] -> 
382
383
384
     let last = gen_page (prev,p1,p2, path, sitemap) in
     let (_,last)  = gen_page_seq (last, rest, next, path, sitemap) in 
     (p1,last)
385
 | [ p ] ->
386
     let last = gen_page (prev,p,next, path, sitemap) in (p,last)
387
 | [] -> (next,prev)
388

389

390
;;
391

392
match load_include input with
393
 | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
394
 | _ -> raise ("Invalid input document " @ input)
395

396