site.cd 10.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
41
42
43

type Content =      
   [ ( <p {||}>[InlineText*]
     | <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
   | Xa | Ximg | Xbr 
61
62
63
64
65
66


(** Generic purpose functions **)

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

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

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

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

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

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


91
(** Internal types **)
92

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

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

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

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

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

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

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

138
139
let box (x : Flow) : Block =
 <table cellpadding="2" 
140
141
    style="font-size:11px ; font-family:arial,sans-serif;
           border: solid 2px black; background: #ffffff" width="100%">
142
143
144
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
   [ <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;
}
"

191
192
(* Main transformation function *)

193

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

201
 let text (t : [InlineText*]) : Inlines =
202
  map t with
203
   | <code>x -> <b>[ <tt>(highlight x) ]
204
   | <local href=l>txt -> local_link (sitemap,l,txt)
205
   | <(tag & (`b|`i|`tt|`em)) (attr)>x -> <(tag) (attr)>(text x)
206
(*   | <a href=url>_ & z -> let [] = print [ 'Link: ' !url '\n'] in z *)
207
208
   | z -> z
 in
209

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

259
260
261
262
263
264

(* 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">[
265
     <table cellpadding="0" cellspacing="15" 
266
267
268
            width="200"
            style="font-size:80%; border: 1px dashed black;
                   background: #ffcd72">
269
270
     (map left with x -> <tr>[ <td>[ (box (content x)) ] ]) ] in

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

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

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

362

363
;;
364

365
match load_include input with
366
 | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
367
 | _ -> raise ("Invalid input document " @ input)
368