adamc@380
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@380
|
2 * All rights reserved.
|
adamc@380
|
3 *
|
adamc@380
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@380
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@380
|
6 *
|
adamc@380
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@380
|
8 * this list of conditions and the following disclaimer.
|
adamc@380
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@380
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@380
|
11 * and/or other materials provided with the distribution.
|
adamc@380
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@380
|
13 * derived from this software without specific prior written permission.
|
adamc@380
|
14 *
|
adamc@380
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@380
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@380
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@380
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@380
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@380
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@380
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@380
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@380
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@380
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@380
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@380
|
26 *)
|
adamc@380
|
27
|
adamc@380
|
28 structure Demo :> DEMO = struct
|
adamc@380
|
29
|
adamc@380
|
30 fun make {prefix, dirname} =
|
adamc@380
|
31 let
|
adamc@380
|
32 val prose = OS.Path.joinDirFile {dir = dirname,
|
adamc@380
|
33 file = "prose"}
|
adamc@380
|
34 val inf = TextIO.openIn prose
|
adamc@380
|
35
|
adamc@380
|
36 val outDir = OS.Path.concat (dirname, "out")
|
adamc@380
|
37
|
adamc@380
|
38 val () = if OS.FileSys.access (outDir, []) then
|
adamc@380
|
39 ()
|
adamc@380
|
40 else
|
adamc@380
|
41 OS.FileSys.mkDir outDir
|
adamc@380
|
42
|
adamc@380
|
43 val fname = OS.Path.joinDirFile {dir = outDir,
|
adamc@380
|
44 file = "index.html"}
|
adamc@380
|
45
|
adamc@380
|
46 val out = TextIO.openOut fname
|
adamc@381
|
47 val () = (TextIO.output (out, "<frameset cols=\"10%,90%\">\n");
|
adamc@380
|
48 TextIO.output (out, "<frame src=\"demos.html\">\n");
|
adamc@380
|
49 TextIO.output (out, "<frame src=\"intro.html\" name=\"staging\">\n");
|
adamc@380
|
50 TextIO.output (out, "</frameset>\n");
|
adamc@380
|
51 TextIO.closeOut out)
|
adamc@380
|
52
|
adamc@380
|
53 val fname = OS.Path.joinDirFile {dir = outDir,
|
adamc@380
|
54 file = "demos.html"}
|
adamc@380
|
55
|
adamc@380
|
56 val demosOut = TextIO.openOut fname
|
adamc@381
|
57 val () = (TextIO.output (demosOut, "<html><body>\n\n");
|
adamc@380
|
58 TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"intro.html\">Intro</a></li>\n\n"))
|
adamc@380
|
59
|
adamc@384
|
60 val fname = OS.Path.joinDirFile {dir = dirname,
|
adamc@384
|
61 file = "demo.urs"}
|
adamc@384
|
62 val ursOut = TextIO.openOut fname
|
adamc@384
|
63 val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n");
|
adamc@384
|
64 TextIO.closeOut ursOut)
|
adamc@384
|
65
|
adamc@384
|
66 val fname = OS.Path.joinDirFile {dir = dirname,
|
adamc@384
|
67 file = "demo.ur"}
|
adamc@384
|
68 val urOut = TextIO.openOut fname
|
adamc@384
|
69 val () = TextIO.output (urOut, "fun main () = return <xml><body>\n")
|
adamc@384
|
70
|
adamc@380
|
71 fun mergeWith f (o1, o2) =
|
adamc@380
|
72 case (o1, o2) of
|
adamc@380
|
73 (NONE, _) => o2
|
adamc@380
|
74 | (_, NONE) => o1
|
adamc@380
|
75 | (SOME v1, SOME v2) => SOME (f (v1, v2))
|
adamc@380
|
76
|
adamc@380
|
77 fun combiner (combined : Compiler.job, urp : Compiler.job) = {
|
adamc@385
|
78 prefix = prefix,
|
adamc@380
|
79 database = mergeWith (fn (v1, v2) =>
|
adamc@380
|
80 if v1 = v2 then
|
adamc@380
|
81 v1
|
adamc@380
|
82 else
|
adamc@380
|
83 raise Fail "Different demos want to use different database strings")
|
adamc@380
|
84 (#database combined, #database urp),
|
adamc@380
|
85 sources = foldl (fn (file, files) =>
|
adamc@380
|
86 if List.exists (fn x => x = file) files then
|
adamc@380
|
87 files
|
adamc@380
|
88 else
|
adamc@380
|
89 files @ [file])
|
adamc@380
|
90 (#sources combined) (#sources urp),
|
adamc@380
|
91 exe = OS.Path.joinDirFile {dir = dirname,
|
adamc@380
|
92 file = "demo.exe"},
|
adamc@380
|
93 sql = SOME (OS.Path.joinDirFile {dir = dirname,
|
adamc@380
|
94 file = "demo.sql"}),
|
adamc@380
|
95 debug = false
|
adamc@380
|
96 }
|
adamc@380
|
97
|
adamc@380
|
98 val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
|
adamc@380
|
99
|
adamc@380
|
100 fun capitalize "" = ""
|
adamc@380
|
101 | capitalize s = str (Char.toUpper (String.sub (s, 0)))
|
adamc@380
|
102 ^ String.extract (s, 1, NONE)
|
adamc@380
|
103
|
adamc@380
|
104 fun startUrp urp =
|
adamc@380
|
105 let
|
adamc@380
|
106 val base = OS.Path.base urp
|
adamc@380
|
107 val name = capitalize base
|
adamc@380
|
108
|
adamc@380
|
109 val () = (TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"");
|
adamc@380
|
110 TextIO.output (demosOut, base);
|
adamc@380
|
111 TextIO.output (demosOut, ".html\">");
|
adamc@380
|
112 TextIO.output (demosOut, name);
|
adamc@380
|
113 TextIO.output (demosOut, "</a></li>\n"))
|
adamc@380
|
114
|
adamc@384
|
115 val () = (TextIO.output (urOut, " <li> <a link={");
|
adamc@384
|
116 TextIO.output (urOut, name);
|
adamc@384
|
117 TextIO.output (urOut, ".main ()}>");
|
adamc@384
|
118 TextIO.output (urOut, name);
|
adamc@384
|
119 TextIO.output (urOut, "</a></li>\n"))
|
adamc@384
|
120
|
adamc@380
|
121 val urp_file = OS.Path.joinDirFile {dir = dirname,
|
adamc@380
|
122 file = urp}
|
adamc@380
|
123
|
adamc@380
|
124 val out = OS.Path.joinBaseExt {base = base,
|
adamc@380
|
125 ext = SOME "html"}
|
adamc@380
|
126 val out = OS.Path.joinDirFile {dir = outDir,
|
adamc@380
|
127 file = out}
|
adamc@380
|
128 val out = TextIO.openOut out
|
adamc@380
|
129
|
adamc@383
|
130 val () = (TextIO.output (out, "<frameset rows=\"50%,*\">\n");
|
adamc@380
|
131 TextIO.output (out, "<frame src=\"");
|
adamc@380
|
132 TextIO.output (out, prefix);
|
adamc@380
|
133 TextIO.output (out, "/");
|
adamc@380
|
134 TextIO.output (out, name);
|
adamc@380
|
135 TextIO.output (out, "/main\" name=\"showcase\">\n");
|
adamc@380
|
136 TextIO.output (out, "<frame src=\"");
|
adamc@380
|
137 TextIO.output (out, base);
|
adamc@380
|
138 TextIO.output (out, ".desc.html\">\n");
|
adamc@380
|
139 TextIO.output (out, "</frameset>\n");
|
adamc@380
|
140 TextIO.closeOut out)
|
adamc@380
|
141 val () = TextIO.closeOut out
|
adamc@380
|
142
|
adamc@380
|
143 val out = OS.Path.joinBaseExt {base = base,
|
adamc@380
|
144 ext = SOME "desc"}
|
adamc@380
|
145 val out = OS.Path.joinBaseExt {base = out,
|
adamc@380
|
146 ext = SOME "html"}
|
adamc@380
|
147 val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
|
adamc@380
|
148 file = out})
|
adamc@380
|
149 in
|
adamc@380
|
150 case parse (OS.Path.base urp_file) of
|
adamc@380
|
151 NONE => raise Fail ("Can't parse " ^ urp_file)
|
adamc@380
|
152 | SOME urpData =>
|
adamc@380
|
153 (TextIO.output (out, "<html><head>\n<title>");
|
adamc@380
|
154 TextIO.output (out, name);
|
adamc@380
|
155 TextIO.output (out, "</title>\n</head><body>\n\n<h1>");
|
adamc@380
|
156 TextIO.output (out, name);
|
adamc@380
|
157 TextIO.output (out, "</h1>\n\n<center>[ <a target=\"showcase\" href=\"");
|
adamc@382
|
158 TextIO.output (out, prefix);
|
adamc@382
|
159 TextIO.output (out, "/");
|
adamc@382
|
160 TextIO.output (out, name);
|
adamc@382
|
161 TextIO.output (out, "/main\">Application</a>");
|
adamc@382
|
162 TextIO.output (out, " | <a target=\"showcase\" href=\"");
|
adamc@380
|
163 TextIO.output (out, urp);
|
adamc@380
|
164 TextIO.output (out, ".html\"><tt>");
|
adamc@380
|
165 TextIO.output (out, urp);
|
adamc@380
|
166 TextIO.output (out, "</tt></a>");
|
adamc@380
|
167 app (fn file =>
|
adamc@380
|
168 let
|
adamc@380
|
169 fun ifEx s =
|
adamc@380
|
170 let
|
adamc@380
|
171 val src = OS.Path.joinBaseExt {base = file,
|
adamc@380
|
172 ext = SOME s}
|
adamc@380
|
173 val src' = OS.Path.file src
|
adamc@380
|
174 in
|
adamc@380
|
175 if OS.FileSys.access (src, []) then
|
adamc@380
|
176 (TextIO.output (out, " | <a target=\"showcase\" href=\"");
|
adamc@380
|
177 TextIO.output (out, src');
|
adamc@380
|
178 TextIO.output (out, ".html\"><tt>");
|
adamc@380
|
179 TextIO.output (out, src');
|
adamc@380
|
180 TextIO.output (out, "</tt></a>"))
|
adamc@380
|
181 else
|
adamc@380
|
182 ()
|
adamc@380
|
183 end
|
adamc@380
|
184 in
|
adamc@380
|
185 ifEx "urs";
|
adamc@380
|
186 ifEx "ur"
|
adamc@380
|
187 end) (#sources urpData);
|
adamc@380
|
188 TextIO.output (out, " ]</center>\n\n");
|
adamc@380
|
189
|
adamc@380
|
190 (urpData, out))
|
adamc@380
|
191 end
|
adamc@380
|
192
|
adamc@380
|
193 fun endUrp out =
|
adamc@380
|
194 (TextIO.output (out, "\n</body></html>\n");
|
adamc@380
|
195 TextIO.closeOut out)
|
adamc@380
|
196
|
adamc@380
|
197 fun readUrp (combined, out) =
|
adamc@380
|
198 let
|
adamc@380
|
199 fun finished () = endUrp out
|
adamc@380
|
200
|
adamc@380
|
201 fun readUrp' () =
|
adamc@380
|
202 case TextIO.inputLine inf of
|
adamc@384
|
203 NONE => (finished ();
|
adamc@384
|
204 combined)
|
adamc@380
|
205 | SOME line =>
|
adamc@380
|
206 if String.isSuffix ".urp\n" line then
|
adamc@380
|
207 let
|
adamc@380
|
208 val urp = String.substring (line, 0, size line - 1)
|
adamc@380
|
209 val (urpData, out) = startUrp urp
|
adamc@380
|
210 in
|
adamc@380
|
211 finished ();
|
adamc@380
|
212
|
adamc@380
|
213 readUrp (combiner (combined, urpData),
|
adamc@380
|
214 out)
|
adamc@380
|
215 end
|
adamc@380
|
216 else
|
adamc@380
|
217 (TextIO.output (out, line);
|
adamc@380
|
218 readUrp' ())
|
adamc@380
|
219 in
|
adamc@380
|
220 readUrp' ()
|
adamc@380
|
221 end
|
adamc@380
|
222
|
adamc@380
|
223 val indexFile = OS.Path.joinDirFile {dir = outDir,
|
adamc@380
|
224 file = "intro.html"}
|
adamc@380
|
225
|
adamc@380
|
226 val out = TextIO.openOut indexFile
|
adamc@380
|
227 val () = TextIO.output (out, "<html><head>\n<title>Ur/Web Demo</title>\n</head><body>\n\n")
|
adamc@380
|
228
|
adamc@380
|
229 fun readIndex () =
|
adamc@380
|
230 let
|
adamc@380
|
231 fun finished () = (TextIO.output (out, "\n</body></html>\n");
|
adamc@380
|
232 TextIO.closeOut out)
|
adamc@380
|
233 in
|
adamc@380
|
234 case TextIO.inputLine inf of
|
adamc@384
|
235 NONE => (finished ();
|
adamc@384
|
236 NONE)
|
adamc@380
|
237 | SOME line =>
|
adamc@380
|
238 if String.isSuffix ".urp\n" line then
|
adamc@380
|
239 let
|
adamc@380
|
240 val urp = String.substring (line, 0, size line - 1)
|
adamc@380
|
241 val (urpData, out) = startUrp urp
|
adamc@380
|
242 in
|
adamc@380
|
243 finished ();
|
adamc@380
|
244
|
adamc@384
|
245 SOME (readUrp (urpData,
|
adamc@384
|
246 out))
|
adamc@380
|
247 end
|
adamc@380
|
248 else
|
adamc@380
|
249 (TextIO.output (out, line);
|
adamc@380
|
250 readIndex ())
|
adamc@380
|
251 end
|
adamc@381
|
252
|
adamc@381
|
253 fun prettyPrint () =
|
adamc@381
|
254 let
|
adamc@381
|
255 val dir = Posix.FileSys.opendir dirname
|
adamc@381
|
256
|
adamc@381
|
257 fun loop () =
|
adamc@381
|
258 case Posix.FileSys.readdir dir of
|
adamc@381
|
259 NONE => Posix.FileSys.closedir dir
|
adamc@381
|
260 | SOME file =>
|
adamc@381
|
261 let
|
adamc@381
|
262 fun doit f =
|
adamc@381
|
263 f (OS.Path.joinDirFile {dir = dirname,
|
adamc@381
|
264 file = file},
|
adamc@382
|
265 OS.Path.mkAbsolute
|
adamc@382
|
266 {relativeTo = OS.FileSys.getDir (),
|
adamc@382
|
267 path = OS.Path.joinDirFile {dir = outDir,
|
adamc@382
|
268 file = OS.Path.joinBaseExt {base = file,
|
adamc@382
|
269 ext = SOME "html"}}})
|
adamc@382
|
270
|
adamc@382
|
271 fun highlight () =
|
adamc@382
|
272 doit (fn (src, html) =>
|
adamc@382
|
273 let
|
adamc@410
|
274 val dirty =
|
adamc@410
|
275 let
|
adamc@410
|
276 val srcSt = Posix.FileSys.stat src
|
adamc@410
|
277 val htmlSt = Posix.FileSys.stat html
|
adamc@410
|
278 in
|
adamc@410
|
279 Time.> (Posix.FileSys.ST.mtime srcSt,
|
adamc@410
|
280 Posix.FileSys.ST.mtime htmlSt)
|
adamc@410
|
281 end handle OS.SysErr _ => true
|
adamc@410
|
282
|
adamc@382
|
283 val cmd = "emacs --eval \"(progn "
|
adamc@382
|
284 ^ "(global-font-lock-mode t) "
|
adamc@382
|
285 ^ "(add-to-list 'load-path \\\""
|
adamc@382
|
286 ^ Config.sitelisp
|
adamc@382
|
287 ^ "/\\\") "
|
adamc@382
|
288 ^ "(load \\\"urweb-mode-startup\\\") "
|
adamc@382
|
289 ^ "(urweb-mode) "
|
adamc@382
|
290 ^ "(find-file \\\""
|
adamc@382
|
291 ^ src
|
adamc@382
|
292 ^ "\\\") "
|
adamc@382
|
293 ^ "(switch-to-buffer (htmlize-buffer)) "
|
adamc@382
|
294 ^ "(write-file \\\""
|
adamc@382
|
295 ^ html
|
adamc@382
|
296 ^ "\\\") "
|
adamc@382
|
297 ^ "(kill-emacs))\""
|
adamc@382
|
298 in
|
adamc@410
|
299 if dirty then
|
adamc@410
|
300 (print (">>> " ^ cmd ^ "\n");
|
adamc@410
|
301 ignore (OS.Process.system cmd))
|
adamc@410
|
302 else
|
adamc@410
|
303 ()
|
adamc@382
|
304 end)
|
adamc@381
|
305 in
|
adamc@384
|
306 if OS.Path.base file = "demo" then
|
adamc@384
|
307 ()
|
adamc@384
|
308 else case OS.Path.ext file of
|
adamc@384
|
309 SOME "urp" =>
|
adamc@384
|
310 doit (fn (src, html) =>
|
adamc@384
|
311 let
|
adamc@384
|
312 val inf = TextIO.openIn src
|
adamc@384
|
313 val out = TextIO.openOut html
|
adamc@381
|
314
|
adamc@384
|
315 fun loop () =
|
adamc@384
|
316 case TextIO.inputLine inf of
|
adamc@384
|
317 NONE => ()
|
adamc@384
|
318 | SOME line => (TextIO.output (out, line);
|
adamc@384
|
319 loop ())
|
adamc@384
|
320 in
|
adamc@384
|
321 TextIO.output (out, "<html><body>\n\n<pre>");
|
adamc@384
|
322 loop ();
|
adamc@384
|
323 TextIO.output (out, "</pre>\n\n</body></html>");
|
adamc@381
|
324
|
adamc@384
|
325 TextIO.closeIn inf;
|
adamc@384
|
326 TextIO.closeOut out
|
adamc@384
|
327 end)
|
adamc@384
|
328 | SOME "urs" => highlight ()
|
adamc@384
|
329 | SOME "ur" => highlight ()
|
adamc@384
|
330 | _ => ();
|
adamc@381
|
331 loop ()
|
adamc@381
|
332 end
|
adamc@381
|
333 in
|
adamc@381
|
334 loop ()
|
adamc@381
|
335 end
|
adamc@380
|
336 in
|
adamc@384
|
337 case readIndex () of
|
adamc@384
|
338 NONE => raise Fail "No demo applications!"
|
adamc@384
|
339 | SOME combined =>
|
adamc@384
|
340 let
|
adamc@384
|
341 val () = (TextIO.output (urOut, "</body></xml>\n");
|
adamc@384
|
342 TextIO.closeOut urOut)
|
adamc@384
|
343
|
adamc@384
|
344 val fname = OS.Path.joinDirFile {dir = dirname,
|
adamc@384
|
345 file = "demo.urp"}
|
adamc@384
|
346 val outf = TextIO.openOut fname
|
adamc@384
|
347 in
|
adamc@384
|
348 Option.app (fn db => (TextIO.output (outf, "database ");
|
adamc@384
|
349 TextIO.output (outf, db);
|
adamc@384
|
350 TextIO.output (outf, "\n")))
|
adamc@384
|
351 (#database combined);
|
adamc@384
|
352 TextIO.output (outf, "sql demo.sql\n");
|
adamc@385
|
353 TextIO.output (outf, "prefix ");
|
adamc@385
|
354 TextIO.output (outf, prefix);
|
adamc@385
|
355 TextIO.output (outf, "\n");
|
adamc@384
|
356 TextIO.output (outf, "\n");
|
adamc@384
|
357
|
adamc@384
|
358 app (fn s =>
|
adamc@384
|
359 let
|
adamc@384
|
360 val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
|
adamc@384
|
361 path = s}
|
adamc@384
|
362 in
|
adamc@384
|
363 TextIO.output (outf, s);
|
adamc@384
|
364 TextIO.output (outf, "\n")
|
adamc@384
|
365 end)
|
adamc@384
|
366 (#sources combined);
|
adamc@384
|
367 TextIO.output (outf, "\n");
|
adamc@384
|
368 TextIO.output (outf, "demo\n");
|
adamc@384
|
369
|
adamc@384
|
370 TextIO.closeOut outf;
|
adamc@384
|
371
|
adamc@384
|
372 Compiler.compile (OS.Path.base fname)
|
adamc@384
|
373 end;
|
adamc@380
|
374
|
adamc@381
|
375 TextIO.output (demosOut, "\n</body></html>\n");
|
adamc@381
|
376 TextIO.closeOut demosOut;
|
adamc@381
|
377
|
adamc@381
|
378 prettyPrint ()
|
adamc@380
|
379 end
|
adamc@380
|
380
|
adamc@380
|
381 end
|