site.cd 10.4 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
57
58

type InlineText =
     Char
   | <(`b|`i|`tt|`em) {||}>[InlineText*]
   | <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
    style="font-size:11px ; font-family:arial,sans-serif; border: solid 2px black; background: #ffffff" width="100%">
140
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
   [ <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;
}
"

189
190
(* Main transformation function *)

191

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

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

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

257
258
259
260
261
262

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

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

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

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

356

357
;;
358

359
match load_include input with
360
 | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
361
 | _ -> raise ("Invalid input document " @ input)
362