include "xhtml-strict.cd";; (* XHTML 1 Strict DTD *)
include "xhtml-categ.cd";; (* Categories (Inline, ...) from this DTD *)
type SitePage =
[]
| [];;
type Site = [ SitePage* ];;
type Page =
[
String
<banner>[InlineText*]
<navig>[ NavigBox* ] <main>[ Box* ] ];;
type Author = <author>String;;
type Paper =
<paper file=?String>[
<title>String
Author+
<comment>[InlineText*]
<abstract>Content ];;
type Slides =
<slides file=String>[
<title>String
Author+
<comment>[InlineText*] ];;
type Link =
<link url=String; title=String>[ InlineText* ];;
type Content =
[ ( <p {||}>[InlineText*]
| <ul {||}>[<li {||}>Content +]
| <section title=String>Content
| Xtable
| Paper | Slides | Link
| <include-verbatim file=String>[]
| InlineText )* ];;
type InlineText =
Char
| <(`b|`i) {||}>[InlineText*]
| <duce>[InlineText*]
| Xa
| Ximg | Xbr ;;
type Box = <box title=String; subtitle=?String; link=String>Content
| <meta>Content;;
type NavigBox = <box>Content | <toc>[];;
let fun authors ([Author+] -> String)
| [ <author>a ] -> a
| [ <author>a1 <author>a2 ] -> a1 @ ", and " @ a2
| [ <author>a; rem ] -> a @ ", " @ authors rem;;
let fun text (t : [InlineText*]) : Inlines =
map t with
<duce>x -> <b>[ <tt>(text x) ]
| <b>x -> <b>(text x)
| <i>x -> <i>(text x)
| z -> z;;
let fun content (t : Content) : Flow =
transform t with
| <section title=title>c -> [ <h4>title !(content c) ]
| <paper (r)>[ <title>tit aut::Author* <comment>com <abstract>ab ] ->
[
(match r with
| { file = f } -> <a href=f>tit
| _ -> <b>tit
) '. '
!(authors aut) '. '
!(text com)
<div class="abstract">[ 'Abstract:' !(content ab) ]
]
| <slides file=f>[ <title>tit aut::Author* <comment>com ] ->
[ <a href=f>tit '. ' !(authors aut) '. ' !(text com) ]
| <include-verbatim file=f>[] ->
let code = load_file f in
(* let code = transform code with
| '\n' -> [ '\n' <br>[] ]
| ' ' -> "\160"
| c -> [c] in *)
[
<div class="code">[ <pre>code ]
]
| <link url=url; title=title>com -> [ <a href=url>title '. ' !(text com) ]
| <ul>lis -> [ <ul>(map lis with <li>x -> <li>(content x)) ]
| Xtable & x -> [ x ]
| <p>x -> [ <p>(text x) ]
| <ul>x -> [ <ul>(text x) ]
| x -> text [ x ];;
let fun main2html (Box -> Flow)
<box (r)>c ->
[ <div class="box">[
<h2>(r.title)
!(match r with { subtitle = t } -> [<b>t] | _ -> [])
<a name=r.link>[]
!(content c) ] ]
| <meta>c -> [ <div class="meta">(content c) ];;
let fun page2html (Page -> Xhtml)
<page>[ <title>title <banner>banner <navig>navig <main>main ] ->
let toc =
transform main with <box title=t; link=l>_ -> [ <li>[ <a href=('#',l)>t ] ] in
let toc = match toc with [] -> [] | lis -> [ <ul>lis ] in
let navig : Flow = transform navig with
| <box>c -> [ <div class="box">(content c) ]
| <toc>[] -> [ <div class="box">toc ]
in
<html>[
<head>[
<title>title
<meta content="text/html; charset=iso-8859-1"; http-equiv="Content-Type">[]
<link rel="stylesheet"; href="cduce.css"; type="text/css"> []
]
<body>[
<div class="title">[ <h1>(text banner) ]
<div id="Sidelog">navig
<div id="Content">(transform main with b -> main2html b)
]
];;
type P = (String,<title>String);;
let fun make_plan (l : [ P+ ]) : Page =
<page>[ <title>"CDuce site"
<banner>"CDuce site"
<navig>[ <box>[ <a href="/">"Home" ] ]
<main>[
<box title="Pages"; link="pages">[
<ul>(map l with (file,<title>t) -> <li>[<a href=file>t]) ]
<meta>[
'This page was automatically generated by a CDuce program.'
]
]
];;
let fun do_page((Page,String) -> [])
(page,outf) ->
let _ = print [ 'Generating html ... ' ] in
let html : String =
[ '<?xml version="1.0" encoding="iso-8859-1"?>'
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'
' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'
!(print_xml (page2html page)) ] in
let _ = print [ 'Saving to ' !outf '...\n' ] in
dump_to_file outf html;;
let fun do_file((String,String) -> P)
(inf,outf) ->
let _ = print [ 'Loading ' !inf '... ' ] in
let page = match load_xml inf with
| Page & p -> p
| _ -> raise ("Invalid input document: " @ inf) in
let _ = do_page (page,outf) in
let tit = match [page]/<title>_ with [t] -> t in
(outf, tit);;
let site =
let _ = print [ 'Loading site.xml ...\n' ] in
match load_xml "site.xml" with
| Site & <site>s ->
let ts = map s with
| <page input=inf; output=outf>_ -> do_file(inf,outf)
| <external href=url; title=t>_ -> (url,<title>t) in
let _ = print [ 'Create plan... ' ] in
let plan = make_plan (ts @ [("plan.html", <title>"CDuce site")]) in
do_page(plan,"plan.html")
| _ -> raise "Invalid site.xml";;