/[svn]/web/site.cd
ViewVC logotype

Diff of /web/site.cd

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 487 by abate, Tue Jul 10 17:34:25 2007 UTC revision 488 by abate, Tue Jul 10 17:38:30 2007 UTC
# Line 11  Line 11 
11    
12  (** Output types **)  (** Output types **)
13    
14  include "xhtml-strict.cd";;  (* XHTML 1 Strict DTD *)  include "xhtml-strict.cd"  (* XHTML 1 Strict DTD *)
15  include "xhtml-categ.cd";;   (* Categories (Inline, ...) from this DTD *)  include "xhtml-categ.cd"   (* Categories (Inline, ...) from this DTD *)
16    
17    
18  (** Input types **)  (** Input types **)
19    
20  type Page =  <page name=String>[ <title>String <banner>[InlineText*]? Item* ];;  type Page =  <page name=String>[ <title>String <banner>[InlineText*]? Item* ]
21  type External = <external {|href=String; title=String; name=String |}>[];;  type External = <external {|href=String; title=String; name=String |}>[]
22    
23  type Item =  type Item =
24     <box title=String; subtitle=?String; link=String>Content     <box title=String; subtitle=?String; link=String>Content
25   | <meta>Content   | <meta>Content
26   | <left>Content   | <left>Content
27   | Page   | Page
28   | External;;   | External
29    
30  type Author = <author>String;;  type Author = <author>String
31  type Paper =  type Paper =
32    <paper file=?String>[    <paper file=?String>[
33       <title>String Author+ <comment>[InlineText*] <abstract>Content ];;       <title>String Author+ <comment>[InlineText*] <abstract>Content ]
34    
35  type Slides =  type Slides =
36    <slides file=String>[ <title>String Author+ <comment>[InlineText*] ];;    <slides file=String>[ <title>String Author+ <comment>[InlineText*] ]
37    
38  type Link =  type Link =
39    <link url=String; title=String>[ InlineText* ];;    <link url=String; title=String>[ InlineText* ]
40    
41  type Content =  type Content =
42     [ ( <p {||}>[InlineText*]     [ ( <p {||}>[InlineText*]
# Line 51  Line 51 
51       | <local-links href=String>[]       | <local-links href=String>[]
52       | <two-columns>[ <left>Content <right>Content ]       | <two-columns>[ <left>Content <right>Content ]
53       | InlineText       | InlineText
54       )* ];;       )* ]
55    
56  type InlineText =  type InlineText =
57       Char       Char
58     | <(`b|`i|`tt|`em) {||}>[InlineText*]     | <(`b|`i|`tt|`em) {||}>[InlineText*]
59     | <code>String     | <code>String
60     | <local href=String>String     | <local href=String>String
61     | Xa | Ximg | Xbr ;;     | Xa | Ximg | Xbr
62    
63    
64  (** Generic purpose functions **)  (** Generic purpose functions **)
65    
66  (* Recursive inclusion of XML files and verbatim text files *)  (* Recursive inclusion of XML files and verbatim text files *)
67    
68  let fun load_include (String -> [Any*])  let load_include (String -> [Any*])
69   name ->   name ->
70  (*   let _ = print [ 'Loading ' !name '... \n' ] in *)  (*   let _ = print [ 'Loading ' !name '... \n' ] in *)
71     xtransform [ (load_xml name) ] with     xtransform [ (load_xml name) ] with
72     | <include file=(s & String)>[] -> load_include s     | <include file=(s & String)>[] -> load_include s
73     | <include-verbatim file=(s & String)>[] -> load_file s;;     | <include-verbatim file=(s & String)>[] -> load_file s
74    
75  (* Highlighting text between {{...}} *)  (* Highlighting text between {{...}} *)
76    
77  let fun highlight (String -> [ (Char | Xvar | Xi)* ] )  let highlight (String -> [ (Char | Xvar | Xi)* ] )
78   | [ '{{' h ::(Char *?) '}}' ; rest ] ->   | [ '{{' h ::(Char *?) '}}' ; rest ] ->
79            [ <var class="highlight">h; highlight rest ]            [ <var class="highlight">h; highlight rest ]
80   | [ '%%' h ::(Char *?) '%%' ; rest ] ->   | [ '%%' h ::(Char *?) '%%' ; rest ] ->
81            [ <i>h; highlight rest ]            [ <i>h; highlight rest ]
82   | [ c; rest ] -> [ c; highlight rest ]   | [ c; rest ] -> [ c; highlight rest ]
83   | [] -> [];;   | [] -> []
84    
85  (* Split a comma-separated string *)  (* Split a comma-separated string *)
86    
87  let fun split_comma (String -> [String*])  let split_comma (String -> [String*])
88   | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)   | [ x::(Char*?) ',' ; rest ] -> (x, split_comma rest)
89   | s -> [ s ];;   | s -> [ s ]
90    
91    
92  (** Ugly hack to introduce PHP code ...  (** Ugly hack to introduce PHP code ...
# Line 95  Line 95 
95      element and replace it with the PHP code. **)      element and replace it with the PHP code. **)
96    
97  let css : Latin1 =  let css : Latin1 =
98    ['<link rel="stylesheet" href="cduce.css" type="text/css">'];;    ['<link rel="stylesheet" href="cduce.css" type="text/css">']
99    
100  let fun protect_quote (s : Latin1) : Latin1 =  let protect_quote (s : Latin1) : Latin1 =
101    transform s with '"' -> [ '\\"' ] | c -> [c];;    transform s with '"' -> [ '\\"' ] | c -> [c]
102    
103  let php_css : Latin1 =  let php_css : Latin1 =
104  if php then  if php then
# Line 119  Line 119 
119  }  }
120  echo "$css";  echo "$css";
121  ?> ']  ?> ']
122  else css;;  else css
123    
124  (** It does not work with IE  (** It does not work with IE
125  if php then  if php then
# Line 131  Line 131 
131  }  }
132  else { echo "' !(protect_quote css) '"; }  else { echo "' !(protect_quote css) '"; }
133  ?> ']  ?> ']
134  else css;;  else css
135  **)  **)
136    
137  let fun patch_css (Latin1 -> Latin1)  let patch_css (Latin1 -> Latin1)
138  | [ a::_*? '<meta content="css"/>'; rem ] -> a @ php_css @ rem  | [ a::_*? '<meta content="css"/>'; rem ] -> a @ php_css @ rem
139  | s -> s;;  | s -> s
140    
141    
142    
143  (** Internal types **)  (** Internal types **)
144    
145  type Path = [ { url = String; title = String }* ];;  type Path = [ { url = String; title = String }* ]
146  type Tree = { name = String; url = String; title = String;  type Tree = { name = String; url = String; title = String;
147                children = [Tree*] } ;;                children = [Tree*] }
148    
149  let fun url_of_name (String -> String)  let url_of_name (String -> String)
150     "index" -> "/"     "index" -> "/"
151   | s -> s @ ".html";;   | s -> s @ ".html"
152    
153  let fun authors ([Author+] -> String)  let authors ([Author+] -> String)
154     | [ <author>a ] -> a     | [ <author>a ] -> a
155     | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2     | [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
156     | [ <author>a; rem ] -> a @ ", " @ authors rem;;     | [ <author>a; rem ] -> a @ ", " @ authors rem
157    
158  let fun find_local_link (sitemap : [Tree*], l : String) : Tree =  let find_local_link (sitemap : [Tree*], l : String) : Tree =
159  match sitemap with  match sitemap with
160   | (h,t) ->   | (h,t) ->
161     if (h . name = l) then h     if (h . name = l) then h
162     else     else
163      (try find_local_link (t,l) with `Not_found ->      (try find_local_link (t,l) with `Not_found ->
164           find_local_link (h . children,l))           find_local_link (h . children,l))
165   | [] -> raise `Not_found;;   | [] -> raise `Not_found
166    
167  let fun local_link (sitemap : Tree, l : String, txt : String) : Inline =  let local_link (sitemap : Tree, l : String, txt : String) : Inline =
168   try   try
169    let h = find_local_link ([sitemap],l)  in    let h = find_local_link ([sitemap],l)  in
170    let txt = if txt = "" then h . title else txt in    let txt = if txt = "" then h . title else txt in
171    <a href=(h . url)>txt    <a href=(h . url)>txt
172   with `Not_found -> raise [ 'Local link not found: ' !l ];;   with `Not_found -> raise [ 'Local link not found: ' !l ]
173    
174  let fun compute_sitemap ((Page|External) -> Tree)  let compute_sitemap ((Page|External) -> Tree)
175   <page name=name>[ <title>title (c::(Page|External) | _)* ] ->   <page name=name>[ <title>title (c::(Page|External) | _)* ] ->
176     let children = map c with p -> compute_sitemap p in     let children = map c with p -> compute_sitemap p in
177     { name = name; url = url_of_name name; title = title; children =children }     { name = name; url = url_of_name name; title = title; children =children }
178  |<external name=name; href=h; title=t>[] ->  |<external name=name; href=h; title=t>[] ->
179     { name = name; url = h; title = t; children = [] };;     { name = name; url = h; title = t; children = [] }
180    
181  let fun display_sitemap (h : Tree) :  Xli =  let display_sitemap (h : Tree) :  Xli =
182    let ch = map h . children with x -> display_sitemap x in    let ch = map h . children with x -> display_sitemap x in
183    let ch = match ch with [] -> [] | l -> [ <ul>l ] in    let ch = match ch with [] -> [] | l -> [ <ul>l ] in
184    <li>[ <a href=(h . url)>(h . title); ch ];;    <li>[ <a href=(h . url)>(h . title); ch ]
185    
186  let fun link_to (Page -> Xa)  let link_to (Page -> Xa)
187   <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t;;   <page name=n>[<title>t ; _ ] -> <a href=(url_of_name n)>t
188    
189  (* Main transformation function *)  (* Main transformation function *)
190    
191  (* returns the last page of the descendance *)  (* returns the last page of the descendance *)
192  let fun gen_page (prev : Page|[], page : Page, next : Page|[],  let gen_page (prev : Page|[], page : Page, next : Page|[],
193                    path : Path, sitemap : Tree) : (Page|[]) =                    path : Path, sitemap : Tree) : (Page|[]) =
194  match page with  match page with
195  <page name=name>[  <page name=name>[
196          <title>title <banner>banner | <title>(title & banner); items ] ->          <title>title <banner>banner | <title>(title & banner); items ] ->
197    
198   let fun text (t : [InlineText*]) : Inlines =   let text (t : [InlineText*]) : Inlines =
199    map t with    map t with
200     | <code>x -> <b>[ <tt>(highlight x) ]     | <code>x -> <b>[ <tt>(highlight x) ]
201     | <local href=l>txt -> local_link (sitemap,l,txt)     | <local href=l>txt -> local_link (sitemap,l,txt)
# Line 204  Line 204 
204     | z -> z     | z -> z
205   in   in
206    
207   let fun content (t : Content) : Flow =   let content (t : Content) : Flow =
208    transform t with    transform t with
209     | <section title=title>c ->     | <section title=title>c ->
210           [ <h4>title !(content c) ]           [ <h4>title !(content c) ]
# Line 311  Line 311 
311       !(patch_css (print_xml html)) ] in       !(patch_css (print_xml html)) ] in
312   let fn = "www/" @ name @ (if php then ".html.php" else ".html") in   let fn = "www/" @ name @ (if php then ".html.php" else ".html") in
313   let [] = dump_to_file fn txt in   let [] = dump_to_file fn txt in
314   last;;   last
315    
316    
317  let fun gen_page_seq  let gen_page_seq
318   (prev : Page|[], pages : [Page*], next : Page|[],   (prev : Page|[], pages : [Page*], next : Page|[],
319    path : Path, sitemap : Tree) : (Page|[], Page|[]) =    path : Path, sitemap : Tree) : (Page|[], Page|[]) =
320   match pages with   match pages with
# Line 324  Line 324 
324       (p1,last)       (p1,last)
325   | [ p ] ->   | [ p ] ->
326       let last = gen_page (prev,p,next, path, sitemap) in (p,last)       let last = gen_page (prev,p,next, path, sitemap) in (p,last)
327   | [] -> (next,prev);;   | [] -> (next,prev)
328    
329    
330  (* Entry point *)  ;;
331    
332  match load_include input with  match load_include input with
333   | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []   | [ Page & p ] -> let _ = gen_page ([],p,[], [], compute_sitemap p) in []
334   | _ -> raise ("Invalid input document " @ input);;   | _ -> raise ("Invalid input document " @ input)
335    
Legend:
Removed from v.487  
changed lines
  Added in v.488
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5