HCoop / hcoop / debian / mlton.git / blame
| Commit | Line | Data |
|---|---|---|
| 7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
| 2 | * Jagannathan, and Stephen Weeks. | |
| 3 | * | |
| 4 | * MLton is released under a BSD-style license. | |
| 5 | * See the file MLton-LICENSE for details. | |
| 6 | *) | |
| 7 | ||
| 8 | structure Html:> HTML = | |
| 9 | struct | |
| 10 | ||
| 11 | fun tag (name: string, | |
| 12 | attributes: (string * string) list, | |
| 13 | body: Layout.t) = | |
| 14 | let open Layout | |
| 15 | in seq [str "<", str name, | |
| 16 | seq (List.map (attributes, fn (name, value) => | |
| 17 | str (concat [" ", name, " = ", value]))), | |
| 18 | str ">", | |
| 19 | body, | |
| 20 | str (concat ["</", name, ">"])] | |
| 21 | end | |
| 22 | ||
| 23 | structure Align = | |
| 24 | struct | |
| 25 | datatype t = Left | Center | Right | |
| 26 | ||
| 27 | fun toString a = | |
| 28 | case a of | |
| 29 | Left => "left" | |
| 30 | | Center => "center" | |
| 31 | | Right => "right" | |
| 32 | ||
| 33 | fun attribute a = ("align", toString a) | |
| 34 | end | |
| 35 | ||
| 36 | structure Element = | |
| 37 | struct | |
| 38 | datatype tableOption = | |
| 39 | Border of int | |
| 40 | | CellPadding of int | |
| 41 | | CellSpacing of int | |
| 42 | ||
| 43 | datatype t = | |
| 44 | A of Url.t * t | |
| 45 | | Br | |
| 46 | | H1 of Align.t * t | |
| 47 | | Img of {src: Url.t} | |
| 48 | | P of Align.t * t | |
| 49 | | Pre of t | |
| 50 | | Seq of t list | |
| 51 | | String of string | |
| 52 | | Table of tableOption list * t list list | |
| 53 | | Tt of t | |
| 54 | ||
| 55 | val a = A | |
| 56 | val br = Br | |
| 57 | val h1 = H1 | |
| 58 | val img = Img | |
| 59 | val p = P | |
| 60 | val pre = Pre | |
| 61 | val seq = Seq | |
| 62 | val str = String | |
| 63 | val table = Table | |
| 64 | val tt = Tt | |
| 65 | ||
| 66 | fun layoutAe ((a, e), s) = tag (s, [Align.attribute a], layout e) | |
| 67 | and layout e = | |
| 68 | let open Layout | |
| 69 | in case e of | |
| 70 | A (u, e) => tag ("A", [("href", Url.toString u)], layout e) | |
| 71 | | Br => align [empty, tag ("BR", [], empty)] | |
| 72 | | H1 ae => layoutAe (ae, "H1") | |
| 73 | | Img {src, ...} => tag ("IMAGE", [("src", Url.toString src)], empty) | |
| 74 | | P ae => layoutAe (ae, "P") | |
| 75 | | Pre t => tag ("PRE", [], layout t) | |
| 76 | | Seq es => seq (List.map (es, layout)) | |
| 77 | | String s => str s | |
| 78 | | Table (options, rows) => | |
| 79 | tag ("TABLE", | |
| 80 | List.map (options, | |
| 81 | fn Border n => ("BORDER", Int.toString n) | |
| 82 | | CellPadding n => ("CELLPADDING", Int.toString n) | |
| 83 | | CellSpacing n => ("CELLSPACING", Int.toString n)), | |
| 84 | seq (List.map (rows, fn cols => | |
| 85 | tag ("TR", [], | |
| 86 | seq (List.map (cols, fn c => | |
| 87 | tag ("TH", [], layout c))))))) | |
| 88 | | Tt t => tag ("TT", [], layout t) | |
| 89 | end | |
| 90 | end | |
| 91 | ||
| 92 | structure Option = | |
| 93 | struct | |
| 94 | datatype t = | |
| 95 | Redirect of {seconds: int, | |
| 96 | uri: Url.t} | |
| 97 | | Title of string | |
| 98 | ||
| 99 | fun layout (opt: t): Layout.t = | |
| 100 | case opt of | |
| 101 | Redirect {seconds, uri} => | |
| 102 | tag ("META", [("HTTP-EQUIV", "Refresh"), | |
| 103 | ("Content", | |
| 104 | concat [String.dquote, | |
| 105 | Int.toString seconds, | |
| 106 | "; URL=", Url.toString uri, | |
| 107 | String.dquote])], | |
| 108 | Layout.empty) | |
| 109 | | Title s => tag ("TITLE", [], Layout.str s) | |
| 110 | end | |
| 111 | ||
| 112 | datatype t = | |
| 113 | T of {options: Option.t list, | |
| 114 | body: Element.t} | |
| 115 | ||
| 116 | fun layout (T {options, body}) = | |
| 117 | let open Layout | |
| 118 | in align | |
| 119 | [str "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\">", | |
| 120 | tag ("HTML", [], | |
| 121 | align [tag ("HEAD", [], align (List.map (options, Option.layout))), | |
| 122 | tag ("BODY", [], Element.layout (body))])] | |
| 123 | end | |
| 124 | ||
| 125 | end |