trunk/tests/memento.cd

(* An approximation of HTML *)

type Flow = Char | Block | Inline | Misc;;
type Block = P | Heading | Div | Lists | Table | Blocktext;;
type Lists = Ul;;
type Blocktext = Pre | Hr | Blockquote | Address;;
type Inline = Char | A | Special | Fontstyle | Phrase;;
type Fontstyle = Tt | I | B | Big | Small;;
type Phrase = Em | Strong | Code;;
type Special = Br;;
type Misc = Empty;;

type Html = <html>[ Head Body ];;
type Head = <head>[ Title ];;
type Title = <title>[ PCDATA ];;
type Body = <body bgcolor=String>[ Block* ];;

type Div = <div>[ Flow* ];;
type P = <p>[ Inline* ];;
type Heading = <(`h1 | `h2)>[ Inline* ];;

type Ul = <ul>[Li+];;
type Li = <li>[ Flow* ];;

type Address = <address>[ Inline* ];;
type Hr = <hr>[];;
type Pre = <pre>[ (PCDATA | A | Fontstyle | Phrase | Br)* ];;
type Blockquote = <blockquote>[ Block* ];;

type A = <a ({ name = String } | { href = String })>[ (Inline \ A)* ];;
type Br = <br>[];;
type Em = <em>[ Inline* ];;
type Code = <code>[ Inline* ];;
type Strong = <strong>[ Inline* ];;
type Tt = <tt>[ Inline* ];;
type I = <i>[ Inline* ];;
type B = <b>[ Inline* ];;
type Big = <big>[ Inline* ];;
type Small = <small>[ Inline* ];;

type Table = <table border=?String; bgcolor=String; width=String>
     [ <tr>[ <td>[ Flow* ]+ ]+ ];;


(* Input document *)

type Page = <page filename=String>[ <title>String; Content ];;
type Content = [ (Box | Section)* ];;
type Content' = [ (Box | Section')* ];;
type Box = <box>Text;;
type Section = <section>[ <title>String ; Text ];;
type Section' = <section no=Int>[ <title>String ; Text ];;
type Text = [ (Char | <duce>String | <ul>[<li>Text +] 
              | <a href=String>String | <br>[])* ];;


let fun box(c : [Flow*]) : [Block*] = 
 [ <table bgcolor="white"; width="100%"; border="1">[ <tr>[ <td>c ] ] 
    <p>[] ];;

let fun format (Box | Section' | Content' -> [Block*]; Text -> [Flow*])
 | <box>s -> box (format s)
 | <section no=i>[ <title>t ; s ] -> 
            box [ <h2>[!(string_of i) '. ' !t] <a name=string_of i>[];
                  format s ]
 | txt & Text -> (map txt with 
                   | <duce>c -> <b>[<tt>c]
                   | <ul>l -> <ul>(map l with <li>c -> <li>(format c) )
                   | c -> c)
 | c & Content' -> (transform c with x -> format x);;

let fun summary (Content' -> [Block*])
 c -> 
    let s = transform c with <section no=i>[<title>t; _] -> 
       [<li>[<a href="#" @ string_of i>t]] in
    match s with  lis -> box [<ul>lis];;


let (fname, title, content) =
  match load_xml "tests/memento.xml" with
  | <page filename=f>[ <title>t ; c ] & Page ->
          let fun aux ((Int,Content) -> Content')
            | (_,[]) -> []
            | (i,(<section>s,rem)) -> [ <section no=i>s !(aux (i+1,rem)) ]
            | (i,(x,rem)) -> [ x !(aux (i,rem)) ]
          in
          (f,t,aux (1,c))
  | _ -> raise "Invalid input document!";;

let out : Html = 
 <html>[
   <head>[ <title>title ]
   <body bgcolor="#BBDDFF">
     [ !(box [<h1>title]) !(summary content) !(format content) ]
 ];;

dump_to_file fname (print_xml out);;
1	abate	131	(* An approximation of HTML *)
2
3			type Flow = Char \| Block \| Inline \| Misc;;
4			type Block = P \| Heading \| Div \| Lists \| Table \| Blocktext;;
5			type Lists = Ul;;
6			type Blocktext = Pre \| Hr \| Blockquote \| Address;;
7			type Inline = Char \| A \| Special \| Fontstyle \| Phrase;;
8			type Fontstyle = Tt \| I \| B \| Big \| Small;;
9			type Phrase = Em \| Strong \| Code;;
10			type Special = Br;;
11			type Misc = Empty;;
12
13			type Html = <html>[ Head Body ];;
14			type Head = <head>[ Title ];;
15			type Title = <title>[ PCDATA ];;
16	abate	133	type Body = <body bgcolor=String>[ Block* ];;
17	abate	131
18			type Div = <div>[ Flow* ];;
19			type P = <p>[ Inline* ];;
20			type Heading = <(`h1 \| `h2)>[ Inline* ];;
21
22			type Ul = <ul>[Li+];;
23			type Li = <li>[ Flow* ];;
24
25			type Address = <address>[ Inline* ];;
26			type Hr = <hr>[];;
27			type Pre = <pre>[ (PCDATA \| A \| Fontstyle \| Phrase \| Br)* ];;
28			type Blockquote = <blockquote>[ Block* ];;
29
30			type A = <a ({ name = String } \| { href = String })>[ (Inline \ A)* ];;
31			type Br = <br>[];;
32			type Em = <em>[ Inline* ];;
33			type Code = <code>[ Inline* ];;
34			type Strong = <strong>[ Inline* ];;
35			type Tt = <tt>[ Inline* ];;
36			type I = <i>[ Inline* ];;
37			type B = <b>[ Inline* ];;
38			type Big = <big>[ Inline* ];;
39			type Small = <small>[ Inline* ];;
40
41	abate	133	type Table = <table border=?String; bgcolor=String; width=String>
42			[ <tr>[ <td>[ Flow* ]+ ]+ ];;
43	abate	131
44
45	abate	133
46	abate	131	(* Input document *)
47
48			type Page = <page filename=String>[ <title>String; Content ];;
49			type Content = [ (Box \| Section)* ];;
50	abate	133	type Content' = [ (Box \| Section')* ];;
51	abate	131	type Box = <box>Text;;
52			type Section = <section>[ <title>String ; Text ];;
53	abate	133	type Section' = <section no=Int>[ <title>String ; Text ];;
54			type Text = [ (Char \| <duce>String \| <ul>[<li>Text +]
55			\| <a href=String>String \| <br>[])* ];;
56	abate	131
57
58	abate	133	let fun box(c : [Flow]) : [Block] =
59			[ <table bgcolor="white"; width="100%"; border="1">[ <tr>[ <td>c ] ]
60			<p>[] ];;
61	abate	131
62	abate	133	let fun format (Box \| Section' \| Content' -> [Block]; Text -> [Flow])
63	abate	131	\| <box>s -> box (format s)
64	abate	133	\| <section no=i>[ <title>t ; s ] ->
65			box [ <h2>[!(string_of i) '. ' !t] <a name=string_of i>[];
66			format s ]
67	abate	131	\| txt & Text -> (map txt with
68			\| <duce>c -> <b>[<tt>c]
69			\| <ul>l -> <ul>(map l with <li>c -> <li>(format c) )
70			\| c -> c)
71	abate	133	\| c & Content' -> (transform c with x -> format x);;
72	abate	131
73	abate	133	let fun summary (Content' -> [Block*])
74	abate	132	c ->
75	abate	133	let s = transform c with <section no=i>[<title>t; _] ->
76			[<li>[<a href="#" @ string_of i>t]] in
77	abate	170	match s with lis -> box [<ul>lis];;
78	abate	132
79
80	abate	133	let (fname, title, content) =
81			match load_xml "tests/memento.xml" with
82			\| <page filename=f>[ <title>t ; c ] & Page ->
83			let fun aux ((Int,Content) -> Content')
84			\| (_,[]) -> []
85			\| (i,(<section>s,rem)) -> [ <section no=i>s !(aux (i+1,rem)) ]
86			\| (i,(x,rem)) -> [ x !(aux (i,rem)) ]
87			in
88			(f,t,aux (1,c))
89			\| _ -> raise "Invalid input document!";;
90
91	abate	131	let out : Html =
92			<html>[
93			<head>[ <title>title ]
94	abate	133	<body bgcolor="#BBDDFF">
95			[ !(box [<h1>title]) !(summary content) !(format content) ]
96	abate	131	];;
97
98			dump_to_file fname (print_xml out);;