site.cd 11.9 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
using H = "xhtml"
13

14
15
(** Input types **)

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

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

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

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

type Link =
35
  <link url=String title=String>[ InlineText* ]
36
37

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

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

60
61
62
63
(** Generic purpose functions **)

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

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

71
(* Highlighting text between {{...}} *)
72

73
let highlight (String -> [ (Char | H:Xvar | H:Xi)* ] )
74
75
 | [ '{{' h ::(Char *?) '}}' ; rest ] -> 
          [ <var class="highlight">h; highlight rest ]
76
 | [ '%%' h ::(Char *?) '%%' ; rest ] ->
77
          [ <i>h; highlight rest ] 
78
 | [ c; rest ] -> [ c; highlight rest ]
79
 | [] -> []
80

81
82
(* Split a comma-separated string *)

83
let split_comma (String -> [String*])
84
 | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)
85
 | s -> [ s ]
86
87


88
(** Internal types **)
89

90
type Path = [ { url = String; title = String }* ]
91
type Tree = { name = String; url = String; title = String; 
92
              children = [Tree*] } 
93

94
let url_of_name (String -> String)
95
   "index" -> "/"
96
 | s -> s @ ".html"
97

98
let authors ([Author+] -> String)
99
100
   | [ <author>a ] -> a
   | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
101
   | [ <author>a; rem ] -> a @ ", " @ authors rem
102

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

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

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

131

132
let boxes_of  (Page -> [H:Xul?])
133
     <page name=n>[ (items::Item | _)*] ->
134
135
        let toc = 
         transform items with 
136
          <box title=t link=l>_ -> [ <li>[ <a href=((url_of_name n)@('#',l))>t ] ] in
137
138
        (match toc with [] -> [] | lis -> [ <ul>lis ])
 
139
let link_to (Page -> H:Xa)
140
141
142
 <page name=n new=_>[<title>t ; _ ] -> 
               <a href=(url_of_name n)>[!t 
                      <img src="img/new.gif" alt="(new)" style="border:0">[]]
143
| <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
144

145
let box (x : H:Flow) : H:Block =
146
 <table cellpadding="2" 
147
148
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
149
150
   [ <tr> [<td>x] ]

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

157
let box_title (x : H:Flow, t : String) : H:Block =
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
 <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;
}
"

198
199
(* Main transformation function *)

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

207
 let footnote_counter = ref Int 0 in 
208
 let footnotes = ref H:Flow [] in
209

210
 let text (t : [InlineText*]) : H:Inlines =
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
  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 ']' ] ]
227
   | z -> [ z ] 
228
 in
229

230
 let content (t : Content) : H:Flow =
231
  transform t with
232
   | <section title=title>c -> 
233
         [ <p>[ <b style="color: #008000">title ] !(content c) ]
234
   | <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab  ]  ->
235
         [ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. '
236
           !(authors aut) '. '
237
	   !(text com)
238
239
240
           <div class="abstract">[ 'Abstract:' !(content ab) ]
         ]
   | <slides file=f>[ <title>tit aut::Author* <comment>com ]  ->
241
        [ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
242
243
   | <sample highlight="false">s ->
        [ <div class="code">[ <pre>s ] ]
244
   | <sample>s ->
245
        [ <div class="code">[ <pre>(highlight s) ] ]
246
   | <link url=url title=title>com -> 
247
248
249
        [ <a href=url>title '. ' !(text com) ]
   | <ul>lis -> 
        [ <ul>(map lis with <li>x -> <li>(content x)) ]
250
   | H:Xtable & x -> 
251
        [ x ]
252
   | <p (attr)>x -> [ <p (attr)>(text x) ]
253
254
   | <pages-toc (a)>[] ->
       let toc = 
255
         transform items with 
256
257
         | Page & p ->  [ <li>[ (link_to p) 
                           !(match a with {|sections=_|} -> (boxes_of p) | _ -> [])] ]
258
         | <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in
259
        (match toc with [] -> [] | lis -> [ <ul>lis ])
260
   | <boxes-toc (a)>[] ->
261
262
        let toc = 
         transform items with 
263
264
265
266
267
268
          <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 ])
269
270
271
272
273
   | <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
(* Preparing left panel *)
285

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

296
 let dpath : H:Inlines = transform path with 
297
  | { url = f; title = t } -> [ <a href=f>t ': '] 
298
 in
299
 let npath = path @ [ { url = (url_of_name name); title = title } ] in
300
 let subpages = transform items with p & Page -> [ p ] in
301
 let (next,last) = gen_page_seq (page, subpages, next, npath, sitemap) in
302
303
304
 let next = match next with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
305
          <img width="16" height="16" class="icon" alt="Next page:"
306
               src="img/right.gif">[]
307
308
309
310
311
          ' ' !t
        ] ] in
 let prev = match prev with [] -> [] 
   | <page name=n>[ <title>t; _ ] -> 
      [ <a href=(url_of_name n)>[ 
312
          <img width="16" height="16" class="icon"
313
               alt="Previous page:" src="img/left.gif">[]
314
315
          ' ' !t
        ] ] in
316
 let navig = 
317
   if prev = [] then [] else
318
   [ (box [
319
     <p>[ !dpath !title ]
320
321
322
323
324
325
326
327
328
329
330
     <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
331
332
333
334
 let notes = match !footnotes with
   | [] -> []
   | n -> [ (meta n) ] in
 let main = match (navig @ main @ notes @ navig) with
335
336
337
   | [] -> raise "Empty page !"
   | x -> x in

338
 let right : H:Xtd =
339
340
341
342
343
344
345
346
347
348
349
  <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">[
350
       <table width="100%" cellpadding="0" cellspacing="17">
351
352
353
354
         (map main with x -> <tr>[ <td>[x] ])
      ] ]
  ] ] in

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

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

390

391
;;
392

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

397