| 1 |
abate |
284 |
(* This CDuce script produces CDuce web site. *) |
| 2 |
|
|
|
| 3 |
abate |
369 |
(** Command line **) |
| 4 |
|
|
|
| 5 |
abate |
580 |
let input = |
| 6 |
abate |
369 |
match argv with |
| 7 |
abate |
580 |
| [ s ] -> s |
| 8 |
abate |
431 |
| _ -> raise "Please specify an input file on the command line" |
| 9 |
abate |
369 |
|
| 10 |
|
|
|
| 11 |
abate |
343 |
(** Output types **) |
| 12 |
abate |
284 |
|
| 13 |
abate |
488 |
include "xhtml-strict.cd" (* XHTML 1 Strict DTD *) |
| 14 |
|
|
include "xhtml-categ.cd" (* Categories (Inline, ...) from this DTD *) |
| 15 |
abate |
250 |
|
| 16 |
abate |
336 |
|
| 17 |
abate |
343 |
(** Input types **) |
| 18 |
|
|
|
| 19 |
abate |
488 |
type Page = <page name=String>[ <title>String <banner>[InlineText*]? Item* ] |
| 20 |
|
|
type External = <external {|href=String; title=String; name=String |}>[] |
| 21 |
abate |
343 |
|
| 22 |
|
|
type Item = |
| 23 |
abate |
580 |
<box title=String link=String>Content |
| 24 |
abate |
343 |
| <meta>Content |
| 25 |
|
|
| <left>Content |
| 26 |
|
|
| Page |
| 27 |
abate |
488 |
| External |
| 28 |
abate |
343 |
|
| 29 |
abate |
488 |
type Author = <author>String |
| 30 |
abate |
343 |
type Paper = |
| 31 |
|
|
<paper file=?String>[ |
| 32 |
abate |
488 |
<title>String Author+ <comment>[InlineText*] <abstract>Content ] |
| 33 |
abate |
343 |
|
| 34 |
|
|
type Slides = |
| 35 |
abate |
488 |
<slides file=String>[ <title>String Author+ <comment>[InlineText*] ] |
| 36 |
abate |
343 |
|
| 37 |
|
|
type Link = |
| 38 |
abate |
561 |
<link url=String title=String>[ InlineText* ] |
| 39 |
abate |
343 |
|
| 40 |
|
|
type Content = |
| 41 |
|
|
[ ( <p {||}>[InlineText*] |
| 42 |
|
|
| <ul {||}>[<li {||}>Content +] |
| 43 |
|
|
| <section title=String>Content |
| 44 |
abate |
344 |
| <sample highlight=?"true"|"false">String |
| 45 |
abate |
343 |
| Xtable |
| 46 |
|
|
| Paper | Slides | Link |
| 47 |
|
|
| <boxes-toc>[] |
| 48 |
|
|
| <pages-toc>[] |
| 49 |
|
|
| <site-toc>[] |
| 50 |
|
|
| <local-links href=String>[] |
| 51 |
abate |
356 |
| <two-columns>[ <left>Content <right>Content ] |
| 52 |
abate |
343 |
| InlineText |
| 53 |
abate |
488 |
)* ] |
| 54 |
abate |
343 |
|
| 55 |
|
|
type InlineText = |
| 56 |
|
|
Char |
| 57 |
|
|
| <(`b|`i|`tt|`em) {||}>[InlineText*] |
| 58 |
|
|
| <code>String |
| 59 |
abate |
347 |
| <local href=String>String |
| 60 |
abate |
488 |
| Xa | Ximg | Xbr |
| 61 |
abate |
343 |
|
| 62 |
|
|
|
| 63 |
|
|
(** Generic purpose functions **) |
| 64 |
|
|
|
| 65 |
|
|
(* Recursive inclusion of XML files and verbatim text files *) |
| 66 |
|
|
|
| 67 |
abate |
488 |
let load_include (String -> [Any*]) |
| 68 |
abate |
336 |
name -> |
| 69 |
abate |
368 |
(* let _ = print [ 'Loading ' !name '... \n' ] in *) |
| 70 |
abate |
336 |
xtransform [ (load_xml name) ] with |
| 71 |
abate |
341 |
| <include file=(s & String)>[] -> load_include s |
| 72 |
abate |
488 |
| <include-verbatim file=(s & String)>[] -> load_file s |
| 73 |
abate |
336 |
|
| 74 |
abate |
343 |
(* Highlighting text between {{...}} *) |
| 75 |
abate |
336 |
|
| 76 |
abate |
488 |
let highlight (String -> [ (Char | Xvar | Xi)* ] ) |
| 77 |
abate |
340 |
| [ '{{' h ::(Char *?) '}}' ; rest ] -> |
| 78 |
|
|
[ <var class="highlight">h; highlight rest ] |
| 79 |
abate |
381 |
| [ '%%' h ::(Char *?) '%%' ; rest ] -> |
| 80 |
abate |
370 |
[ <i>h; highlight rest ] |
| 81 |
abate |
340 |
| [ c; rest ] -> [ c; highlight rest ] |
| 82 |
abate |
488 |
| [] -> [] |
| 83 |
abate |
336 |
|
| 84 |
abate |
343 |
(* Split a comma-separated string *) |
| 85 |
|
|
|
| 86 |
abate |
488 |
let split_comma (String -> [String*]) |
| 87 |
abate |
341 |
| [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest) |
| 88 |
abate |
488 |
| s -> [ s ] |
| 89 |
abate |
336 |
|
| 90 |
abate |
253 |
|
| 91 |
abate |
343 |
(** Internal types **) |
| 92 |
abate |
341 |
|
| 93 |
abate |
488 |
type Path = [ { url = String; title = String }* ] |
| 94 |
abate |
341 |
type Tree = { name = String; url = String; title = String; |
| 95 |
abate |
488 |
children = [Tree*] } |
| 96 |
abate |
250 |
|
| 97 |
abate |
488 |
let url_of_name (String -> String) |
| 98 |
abate |
346 |
"index" -> "/" |
| 99 |
abate |
488 |
| s -> s @ ".html" |
| 100 |
abate |
346 |
|
| 101 |
abate |
488 |
let authors ([Author+] -> String) |
| 102 |
abate |
250 |
| [ <author>a ] -> a |
| 103 |
|
|
| [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2 |
| 104 |
abate |
488 |
| [ <author>a; rem ] -> a @ ", " @ authors rem |
| 105 |
abate |
250 |
|
| 106 |
abate |
488 |
let find_local_link (sitemap : [Tree*], l : String) : Tree = |
| 107 |
abate |
341 |
match sitemap with |
| 108 |
|
|
| (h,t) -> |
| 109 |
abate |
347 |
if (h . name = l) then h |
| 110 |
abate |
341 |
else |
| 111 |
|
|
(try find_local_link (t,l) with `Not_found -> |
| 112 |
|
|
find_local_link (h . children,l)) |
| 113 |
abate |
488 |
| [] -> raise `Not_found |
| 114 |
abate |
341 |
|
| 115 |
abate |
488 |
let local_link (sitemap : Tree, l : String, txt : String) : Inline = |
| 116 |
abate |
347 |
try |
| 117 |
|
|
let h = find_local_link ([sitemap],l) in |
| 118 |
|
|
let txt = if txt = "" then h . title else txt in |
| 119 |
|
|
<a href=(h . url)>txt |
| 120 |
abate |
488 |
with `Not_found -> raise [ 'Local link not found: ' !l ] |
| 121 |
abate |
341 |
|
| 122 |
abate |
488 |
let compute_sitemap ((Page|External) -> Tree) |
| 123 |
abate |
341 |
<page name=name>[ <title>title (c::(Page|External) | _)* ] -> |
| 124 |
|
|
let children = map c with p -> compute_sitemap p in |
| 125 |
abate |
346 |
{ name = name; url = url_of_name name; title = title; children =children } |
| 126 |
abate |
561 |
|<external name=name href=h title=t>[] -> |
| 127 |
abate |
488 |
{ name = name; url = h; title = t; children = [] } |
| 128 |
abate |
341 |
|
| 129 |
abate |
488 |
let display_sitemap (h : Tree) : Xli = |
| 130 |
abate |
341 |
let ch = map h . children with x -> display_sitemap x in |
| 131 |
|
|
let ch = match ch with [] -> [] | l -> [ <ul>l ] in |
| 132 |
abate |
488 |
<li>[ <a href=(h . url)>(h . title); ch ] |
| 133 |
abate |
341 |
|
| 134 |
abate |
488 |
let link_to (Page -> Xa) |
| 135 |
|
|
<page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t |
| 136 |
abate |
351 |
|
| 137 |
abate |
580 |
let box (x : Flow) : Block = |
| 138 |
|
|
<table cellpadding="2" |
| 139 |
abate |
581 |
style="font-size:11px ; font-family:arial,sans-serif; border: solid 2px black; background: #ffffff" width="100%"> |
| 140 |
abate |
580 |
[ <tr> [<td>x] ] |
| 141 |
|
|
|
| 142 |
|
|
let meta (x : Flow) : Block = |
| 143 |
|
|
<table cellpadding="2" |
| 144 |
|
|
style="border: solid 1px #b0b0b0; background: #e0e0e0; font-size: 80%" |
| 145 |
|
|
width="100%"> |
| 146 |
|
|
[ <tr> [<td>x] ] |
| 147 |
|
|
|
| 148 |
|
|
let box_title (x : Flow, t : String) : Block = |
| 149 |
|
|
<table cellpadding="5" |
| 150 |
|
|
style="border: solid 2px black; background: #ffffff" width="100%"> |
| 151 |
|
|
[ <tr>[ <td style="background: #fff0f0; color: #0000ff; font: bold |
| 152 |
|
|
100% helvetica">t ] <tr> [<td>x] ] |
| 153 |
|
|
|
| 154 |
|
|
let style = " |
| 155 |
|
|
a:link:hover, a:visited:hover { |
| 156 |
|
|
text-decoration: none; |
| 157 |
|
|
background: #FFFFD0; |
| 158 |
|
|
color: #FF0000; |
| 159 |
|
|
} |
| 160 |
|
|
p { |
| 161 |
|
|
text-align: justify; |
| 162 |
|
|
margin: 1ex 1em 0 1em; |
| 163 |
|
|
} |
| 164 |
|
|
pre { |
| 165 |
|
|
margin: 1ex 1em 0 1em; |
| 166 |
|
|
} |
| 167 |
|
|
var.highlight { |
| 168 |
|
|
color: #FF0000; |
| 169 |
|
|
} |
| 170 |
|
|
img.icon { |
| 171 |
|
|
border: 0; |
| 172 |
|
|
} |
| 173 |
|
|
div.code { |
| 174 |
|
|
background: #E0E0E0; |
| 175 |
|
|
margin: 0.5ex 0.5em 0 0.5em; |
| 176 |
|
|
padding: 0.2ex; |
| 177 |
|
|
} |
| 178 |
|
|
div.abstract { |
| 179 |
|
|
font: bold 80% helvetica; |
| 180 |
|
|
margin: 1ex 1em 1ex 1em; |
| 181 |
|
|
padding: 1ex 1em 1ex 1em; |
| 182 |
|
|
background: #F0F0F0; |
| 183 |
|
|
} |
| 184 |
|
|
div.abstract p { |
| 185 |
|
|
font: 100% sans-serif; |
| 186 |
|
|
} |
| 187 |
|
|
" |
| 188 |
|
|
|
| 189 |
abate |
343 |
(* Main transformation function *) |
| 190 |
|
|
|
| 191 |
abate |
580 |
|
| 192 |
abate |
386 |
(* returns the last page of the descendance *) |
| 193 |
abate |
488 |
let gen_page (prev : Page|[], page : Page, next : Page|[], |
| 194 |
abate |
386 |
path : Path, sitemap : Tree) : (Page|[]) = |
| 195 |
abate |
341 |
match page with |
| 196 |
abate |
381 |
<page name=name>[ |
| 197 |
|
|
<title>title <banner>banner | <title>(title & banner); items ] -> |
| 198 |
abate |
341 |
|
| 199 |
abate |
488 |
let text (t : [InlineText*]) : Inlines = |
| 200 |
abate |
284 |
map t with |
| 201 |
abate |
341 |
| <code>x -> <b>[ <tt>(highlight x) ] |
| 202 |
abate |
347 |
| <local href=l>txt -> local_link (sitemap,l,txt) |
| 203 |
abate |
336 |
| <(tag & (`b|`i|`tt|`em))>x -> <(tag)>(text x) |
| 204 |
abate |
368 |
(* | <a href=url>_ & z -> let [] = print [ 'Link: ' !url '\n'] in z *) |
| 205 |
abate |
341 |
| z -> z |
| 206 |
|
|
in |
| 207 |
abate |
254 |
|
| 208 |
abate |
488 |
let content (t : Content) : Flow = |
| 209 |
abate |
250 |
transform t with |
| 210 |
abate |
284 |
| <section title=title>c -> |
| 211 |
abate |
580 |
[ <p>[ <b style="color: #008000">title ] !(content c) ] |
| 212 |
abate |
250 |
| <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab ] -> |
| 213 |
abate |
284 |
[ (match r with { file = f } -> <a href=f>tit | _ -> <b>tit) '. ' |
| 214 |
abate |
250 |
!(authors aut) '. ' |
| 215 |
abate |
254 |
!(text com) |
| 216 |
abate |
250 |
<div class="abstract">[ 'Abstract:' !(content ab) ] |
| 217 |
|
|
] |
| 218 |
|
|
| <slides file=f>[ <title>tit aut::Author* <comment>com ] -> |
| 219 |
abate |
254 |
[ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ] |
| 220 |
abate |
344 |
| <sample highlight="false">s -> |
| 221 |
|
|
[ <div class="code">[ <pre>s ] ] |
| 222 |
abate |
336 |
| <sample>s -> |
| 223 |
abate |
340 |
[ <div class="code">[ <pre>(highlight s) ] ] |
| 224 |
abate |
561 |
| <link url=url title=title>com -> |
| 225 |
abate |
284 |
[ <a href=url>title '. ' !(text com) ] |
| 226 |
|
|
| <ul>lis -> |
| 227 |
|
|
[ <ul>(map lis with <li>x -> <li>(content x)) ] |
| 228 |
|
|
| Xtable & x -> |
| 229 |
|
|
[ x ] |
| 230 |
abate |
254 |
| <p>x -> [ <p>(text x) ] |
| 231 |
abate |
341 |
| <pages-toc>[] -> |
| 232 |
|
|
let toc = |
| 233 |
|
|
transform items with |
| 234 |
abate |
351 |
| Page & p -> [ <li>[ (link_to p) ] ] |
| 235 |
abate |
561 |
| <external href=l title=t>[] -> [ <li>[ <a href=l>t ] ] in |
| 236 |
abate |
341 |
(match toc with [] -> [] | lis -> [ <ul>lis ]) |
| 237 |
|
|
| <boxes-toc>[] -> |
| 238 |
|
|
let toc = |
| 239 |
|
|
transform items with |
| 240 |
abate |
561 |
<box title=t link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in |
| 241 |
abate |
341 |
(match toc with [] -> [] | lis -> [ <ul>lis ]) |
| 242 |
|
|
| <site-toc>[] -> |
| 243 |
|
|
[ <ul>[ (display_sitemap sitemap) ] ] |
| 244 |
|
|
| <local-links href=s>[] -> |
| 245 |
|
|
(match (split_comma s) with |
| 246 |
|
|
| [] -> [] |
| 247 |
abate |
347 |
| l -> let l = map l with x -> <li>[ (local_link(sitemap,x,"")) ] |
| 248 |
abate |
341 |
in [ <ul>l ]) |
| 249 |
abate |
356 |
| <two-columns>[ <left>x <right>y ] -> |
| 250 |
|
|
[ <table width="100%">[ |
| 251 |
|
|
<tr>[ |
| 252 |
|
|
<td valign="top">(content x) |
| 253 |
|
|
<td valign="top">(content y) ] ] ] |
| 254 |
abate |
341 |
| t -> text [ t ] |
| 255 |
|
|
in |
| 256 |
abate |
250 |
|
| 257 |
abate |
580 |
|
| 258 |
|
|
(* Preparing left panel *) |
| 259 |
|
|
let navig = transform items with <left>c -> [ c ] in |
| 260 |
|
|
let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in |
| 261 |
|
|
let left = |
| 262 |
|
|
<td valign="top" align="left">[ |
| 263 |
abate |
581 |
<table cellpadding="13" cellspacing="2" |
| 264 |
abate |
580 |
width="200" style="font-size:80%; border: 1px dashed black; background: #ffcd72"> |
| 265 |
|
|
(map left with x -> <tr>[ <td>[ (box (content x)) ] ]) ] in |
| 266 |
|
|
|
| 267 |
abate |
341 |
let dpath : Inlines = transform path with |
| 268 |
abate |
391 |
| { url = f; title = t } -> [ <a href=f>t ': '] |
| 269 |
abate |
341 |
in |
| 270 |
abate |
351 |
let npath = path @ [ { url = url_of_name name; title = title } ] in |
| 271 |
|
|
let subpages = transform items with p & Page -> [ p ] in |
| 272 |
abate |
386 |
let (next,last) = gen_page_seq (page, subpages, next, npath, sitemap) in |
| 273 |
abate |
391 |
let next = match next with [] -> [] |
| 274 |
|
|
| <page name=n>[ <title>t; _ ] -> |
| 275 |
|
|
[ <a href=(url_of_name n)>[ |
| 276 |
abate |
561 |
<img width="16" height="16" class="icon" alt="Next page" src="img/right.gif">[] |
| 277 |
abate |
391 |
' ' !t |
| 278 |
|
|
] ] in |
| 279 |
|
|
let prev = match prev with [] -> [] |
| 280 |
|
|
| <page name=n>[ <title>t; _ ] -> |
| 281 |
|
|
[ <a href=(url_of_name n)>[ |
| 282 |
abate |
561 |
<img width="16" height="16" class="icon" alt="Previous page" src="img/left.gif">[] |
| 283 |
abate |
391 |
' ' !t |
| 284 |
|
|
] ] in |
| 285 |
abate |
580 |
let navig = |
| 286 |
abate |
391 |
if prev = [] then [] else |
| 287 |
abate |
580 |
[ (box [ |
| 288 |
abate |
391 |
<p>[ !dpath !title ] |
| 289 |
abate |
580 |
<p>[ !prev ' ' !next ] ]) ] in |
| 290 |
|
|
|
| 291 |
|
|
(* Preparing main panel *) |
| 292 |
|
|
let main = transform items with |
| 293 |
|
|
| <box (r)>c -> |
| 294 |
|
|
let b = [ |
| 295 |
|
|
<a name=(r . link)>[] |
| 296 |
|
|
!(content c) ] in |
| 297 |
|
|
[ (box_title (b,r . title)) ] |
| 298 |
|
|
| <meta>c -> [ (meta (content c)) ] |
| 299 |
|
|
in |
| 300 |
|
|
let main = match (navig @ main @ navig) with |
| 301 |
|
|
| [] -> raise "Empty page !" |
| 302 |
|
|
| x -> x in |
| 303 |
|
|
|
| 304 |
|
|
let right : Xtd = |
| 305 |
|
|
<td valign="top" align="left" style="width:100%">[ |
| 306 |
|
|
<table width="100%">[ |
| 307 |
|
|
<tr>[ <td valign="top" align="left" |
| 308 |
|
|
style="border: 2px solid black; background: #ffffff; |
| 309 |
|
|
text-align:center; color: #aa0000; font: bold 200% helvetica" > |
| 310 |
|
|
(text banner) |
| 311 |
|
|
] |
| 312 |
|
|
|
| 313 |
|
|
<tr>[ |
| 314 |
|
|
<td valign="top" align="left" |
| 315 |
|
|
style="border: 1px solid black; background: #fccead">[ |
| 316 |
|
|
<table width="100%" cellpadding="15"> |
| 317 |
|
|
(map main with x -> <tr>[ <td>[x] ]) |
| 318 |
|
|
] ] |
| 319 |
|
|
] ] in |
| 320 |
|
|
|
| 321 |
abate |
341 |
let html : Xhtml = |
| 322 |
abate |
250 |
<html>[ |
| 323 |
|
|
<head>[ |
| 324 |
abate |
350 |
<title>[ 'CDuce: ' !title ] |
| 325 |
abate |
561 |
<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">[] |
| 326 |
abate |
580 |
<style type="text/css">style |
| 327 |
abate |
250 |
] |
| 328 |
abate |
580 |
<body style="margin: 0; padding : 0; background: #fcb333">[ |
| 329 |
|
|
<table cellspacing="10" cellpadding="0" width="100%" border="0">[ |
| 330 |
|
|
<tr>[ left right ] |
| 331 |
|
|
] |
| 332 |
abate |
250 |
] |
| 333 |
abate |
341 |
] |
| 334 |
|
|
in |
| 335 |
abate |
391 |
let txt : Latin1 = |
| 336 |
abate |
351 |
[ '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"' |
| 337 |
abate |
341 |
' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">' |
| 338 |
abate |
580 |
!(print_xml html) ] in |
| 339 |
|
|
let fn = "www/" @ name @ ".html" in |
| 340 |
abate |
386 |
let [] = dump_to_file fn txt in |
| 341 |
abate |
488 |
last |
| 342 |
abate |
386 |
|
| 343 |
abate |
250 |
|
| 344 |
abate |
488 |
let gen_page_seq |
| 345 |
abate |
351 |
(prev : Page|[], pages : [Page*], next : Page|[], |
| 346 |
abate |
386 |
path : Path, sitemap : Tree) : (Page|[], Page|[]) = |
| 347 |
abate |
351 |
match pages with |
| 348 |
|
|
| [ p1 p2 ; _ ] & [ _; rest ] -> |
| 349 |
abate |
386 |
let last = gen_page (prev,p1,p2, path, sitemap) in |
| 350 |
|
|
let (_,last) = gen_page_seq (last, rest, next, path, sitemap) in |
| 351 |
|
|
(p1,last) |
| 352 |
abate |
351 |
| [ p ] -> |
| 353 |
abate |
386 |
let last = gen_page (prev,p,next, path, sitemap) in (p,last) |
| 354 |
abate |
488 |
| [] -> (next,prev) |
| 355 |
abate |
351 |
|
| 356 |
|
|
|
| 357 |
abate |
488 |
;; |
| 358 |
abate |
284 |
|
| 359 |
abate |
369 |
match load_include input with |
| 360 |
abate |
386 |
| [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in [] |
| 361 |
abate |
488 |
| _ -> raise ("Invalid input document " @ input) |
| 362 |
abate |
369 |
|