site.cd 10.6 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
20
type Page =  <page name=String>[ <title>String <banner>[InlineText*]? Item* ]
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
135
let link_to (Page -> Xa)
 <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
136

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

190
191
(* Main transformation function *)

192

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

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

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

258
259
260
261
262
263

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

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

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

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

361

362
;;
363

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