Mercurial > urweb

annotate src/demo.sml @ 768:3b7e46790fa7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Path rewriting
author Adam Chlipala <adamc@hcoop.net>
date Sat, 02 May 2009 13:23:07 -0400
parents df09c95085f8
children efceae06df17
rev   line source
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@501 30 fun make {prefix, dirname, guided} =
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@502 95 debug = false,
adamc@673 96 timeout = Int.max (#timeout combined, #timeout urp),
adamc@764 97 profile = false,
adamc@764 98 ffi = [],
adamc@764 99 link = [],
adamc@765 100 headers = [],
adamc@766 101 scripts = [],
adamc@765 102 clientToServer = [],
adamc@765 103 effectful = [],
adamc@765 104 clientOnly = [],
adamc@765 105 serverOnly = [],
adamc@768 106 jsFuncs = [],
adamc@768 107 rewrites = []
adamc@380 108 }
adamc@380 109
adamc@380 110 val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
adamc@380 111
adamc@380 112 fun capitalize "" = ""
adamc@380 113 | capitalize s = str (Char.toUpper (String.sub (s, 0)))
adamc@380 114 ^ String.extract (s, 1, NONE)
adamc@380 115
adamc@380 116 fun startUrp urp =
adamc@380 117 let
adamc@380 118 val base = OS.Path.base urp
adamc@380 119 val name = capitalize base
adamc@380 120
adamc@380 121 val () = (TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"");
adamc@380 122 TextIO.output (demosOut, base);
adamc@380 123 TextIO.output (demosOut, ".html\">");
adamc@380 124 TextIO.output (demosOut, name);
adamc@380 125 TextIO.output (demosOut, "</a></li>\n"))
adamc@380 126
adamc@384 127 val () = (TextIO.output (urOut, " <li> <a link={");
adamc@384 128 TextIO.output (urOut, name);
adamc@384 129 TextIO.output (urOut, ".main ()}>");
adamc@384 130 TextIO.output (urOut, name);
adamc@384 131 TextIO.output (urOut, "</a></li>\n"))
adamc@384 132
adamc@380 133 val urp_file = OS.Path.joinDirFile {dir = dirname,
adamc@380 134 file = urp}
adamc@380 135
adamc@380 136 val out = OS.Path.joinBaseExt {base = base,
adamc@380 137 ext = SOME "html"}
adamc@380 138 val out = OS.Path.joinDirFile {dir = outDir,
adamc@380 139 file = out}
adamc@380 140 val out = TextIO.openOut out
adamc@380 141
adamc@501 142 val () = (TextIO.output (out, "<frameset rows=\"");
adamc@501 143 TextIO.output (out, if guided then
adamc@501 144 "*,100"
adamc@501 145 else
adamc@501 146 "50%,*");
adamc@501 147 TextIO.output (out, "\">\n");
adamc@380 148 TextIO.output (out, "<frame src=\"");
adamc@380 149 TextIO.output (out, prefix);
adamc@380 150 TextIO.output (out, "/");
adamc@380 151 TextIO.output (out, name);
adamc@380 152 TextIO.output (out, "/main\" name=\"showcase\">\n");
adamc@380 153 TextIO.output (out, "<frame src=\"");
adamc@380 154 TextIO.output (out, base);
adamc@380 155 TextIO.output (out, ".desc.html\">\n");
adamc@380 156 TextIO.output (out, "</frameset>\n");
adamc@380 157 TextIO.closeOut out)
adamc@380 158 val () = TextIO.closeOut out
adamc@380 159
adamc@380 160 val out = OS.Path.joinBaseExt {base = base,
adamc@380 161 ext = SOME "desc"}
adamc@380 162 val out = OS.Path.joinBaseExt {base = out,
adamc@380 163 ext = SOME "html"}
adamc@380 164 val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
adamc@380 165 file = out})
adamc@380 166 in
adamc@380 167 case parse (OS.Path.base urp_file) of
adamc@380 168 NONE => raise Fail ("Can't parse " ^ urp_file)
adamc@380 169 | SOME urpData =>
adamc@380 170 (TextIO.output (out, "<html><head>\n<title>");
adamc@380 171 TextIO.output (out, name);
adamc@380 172 TextIO.output (out, "</title>\n</head><body>\n\n<h1>");
adamc@380 173 TextIO.output (out, name);
adamc@380 174 TextIO.output (out, "</h1>\n\n<center>[ <a target=\"showcase\" href=\"");
adamc@382 175 TextIO.output (out, prefix);
adamc@382 176 TextIO.output (out, "/");
adamc@382 177 TextIO.output (out, name);
adamc@382 178 TextIO.output (out, "/main\">Application</a>");
adamc@382 179 TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 180 TextIO.output (out, urp);
adamc@380 181 TextIO.output (out, ".html\"><tt>");
adamc@380 182 TextIO.output (out, urp);
adamc@380 183 TextIO.output (out, "</tt></a>");
adamc@380 184 app (fn file =>
adamc@380 185 let
adamc@380 186 fun ifEx s =
adamc@380 187 let
adamc@380 188 val src = OS.Path.joinBaseExt {base = file,
adamc@380 189 ext = SOME s}
adamc@380 190 val src' = OS.Path.file src
adamc@380 191 in
adamc@380 192 if OS.FileSys.access (src, []) then
adamc@380 193 (TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 194 TextIO.output (out, src');
adamc@380 195 TextIO.output (out, ".html\"><tt>");
adamc@380 196 TextIO.output (out, src');
adamc@380 197 TextIO.output (out, "</tt></a>"))
adamc@380 198 else
adamc@380 199 ()
adamc@380 200 end
adamc@380 201 in
adamc@380 202 ifEx "urs";
adamc@380 203 ifEx "ur"
adamc@380 204 end) (#sources urpData);
adamc@380 205 TextIO.output (out, " ]</center>\n\n");
adamc@380 206
adamc@380 207 (urpData, out))
adamc@380 208 end
adamc@380 209
adamc@380 210 fun endUrp out =
adamc@380 211 (TextIO.output (out, "\n</body></html>\n");
adamc@380 212 TextIO.closeOut out)
adamc@380 213
adamc@380 214 fun readUrp (combined, out) =
adamc@380 215 let
adamc@380 216 fun finished () = endUrp out
adamc@380 217
adamc@380 218 fun readUrp' () =
adamc@380 219 case TextIO.inputLine inf of
adamc@384 220 NONE => (finished ();
adamc@384 221 combined)
adamc@380 222 | SOME line =>
adamc@380 223 if String.isSuffix ".urp\n" line then
adamc@380 224 let
adamc@380 225 val urp = String.substring (line, 0, size line - 1)
adamc@380 226 val (urpData, out) = startUrp urp
adamc@380 227 in
adamc@380 228 finished ();
adamc@380 229
adamc@380 230 readUrp (combiner (combined, urpData),
adamc@380 231 out)
adamc@380 232 end
adamc@380 233 else
adamc@380 234 (TextIO.output (out, line);
adamc@380 235 readUrp' ())
adamc@380 236 in
adamc@380 237 readUrp' ()
adamc@380 238 end
adamc@380 239
adamc@380 240 val indexFile = OS.Path.joinDirFile {dir = outDir,
adamc@380 241 file = "intro.html"}
adamc@380 242
adamc@380 243 val out = TextIO.openOut indexFile
adamc@380 244 val () = TextIO.output (out, "<html><head>\n<title>Ur/Web Demo</title>\n</head><body>\n\n")
adamc@380 245
adamc@380 246 fun readIndex () =
adamc@380 247 let
adamc@380 248 fun finished () = (TextIO.output (out, "\n</body></html>\n");
adamc@380 249 TextIO.closeOut out)
adamc@380 250 in
adamc@380 251 case TextIO.inputLine inf of
adamc@384 252 NONE => (finished ();
adamc@384 253 NONE)
adamc@380 254 | SOME line =>
adamc@380 255 if String.isSuffix ".urp\n" line then
adamc@380 256 let
adamc@380 257 val urp = String.substring (line, 0, size line - 1)
adamc@380 258 val (urpData, out) = startUrp urp
adamc@380 259 in
adamc@380 260 finished ();
adamc@380 261
adamc@384 262 SOME (readUrp (urpData,
adamc@384 263 out))
adamc@380 264 end
adamc@380 265 else
adamc@380 266 (TextIO.output (out, line);
adamc@380 267 readIndex ())
adamc@380 268 end
adamc@381 269
adamc@381 270 fun prettyPrint () =
adamc@381 271 let
adamc@381 272 val dir = Posix.FileSys.opendir dirname
adamc@381 273
adamc@381 274 fun loop () =
adamc@381 275 case Posix.FileSys.readdir dir of
adamc@381 276 NONE => Posix.FileSys.closedir dir
adamc@381 277 | SOME file =>
adamc@381 278 let
adamc@381 279 fun doit f =
adamc@381 280 f (OS.Path.joinDirFile {dir = dirname,
adamc@381 281 file = file},
adamc@382 282 OS.Path.mkAbsolute
adamc@382 283 {relativeTo = OS.FileSys.getDir (),
adamc@382 284 path = OS.Path.joinDirFile {dir = outDir,
adamc@382 285 file = OS.Path.joinBaseExt {base = file,
adamc@382 286 ext = SOME "html"}}})
adamc@382 287
adamc@382 288 fun highlight () =
adamc@382 289 doit (fn (src, html) =>
adamc@382 290 let
adamc@410 291 val dirty =
adamc@410 292 let
adamc@410 293 val srcSt = Posix.FileSys.stat src
adamc@410 294 val htmlSt = Posix.FileSys.stat html
adamc@410 295 in
adamc@410 296 Time.> (Posix.FileSys.ST.mtime srcSt,
adamc@410 297 Posix.FileSys.ST.mtime htmlSt)
adamc@410 298 end handle OS.SysErr _ => true
adamc@410 299
adamc@382 300 val cmd = "emacs --eval \"(progn "
adamc@382 301 ^ "(global-font-lock-mode t) "
adamc@382 302 ^ "(add-to-list 'load-path \\\""
adamc@382 303 ^ Config.sitelisp
adamc@382 304 ^ "/\\\") "
adamc@382 305 ^ "(load \\\"urweb-mode-startup\\\") "
adamc@382 306 ^ "(urweb-mode) "
adamc@382 307 ^ "(find-file \\\""
adamc@382 308 ^ src
adamc@382 309 ^ "\\\") "
adamc@382 310 ^ "(switch-to-buffer (htmlize-buffer)) "
adamc@382 311 ^ "(write-file \\\""
adamc@382 312 ^ html
adamc@382 313 ^ "\\\") "
adamc@382 314 ^ "(kill-emacs))\""
adamc@382 315 in
adamc@410 316 if dirty then
adamc@410 317 (print (">>> " ^ cmd ^ "\n");
adamc@410 318 ignore (OS.Process.system cmd))
adamc@410 319 else
adamc@410 320 ()
adamc@382 321 end)
adamc@381 322 in
adamc@384 323 if OS.Path.base file = "demo" then
adamc@384 324 ()
adamc@384 325 else case OS.Path.ext file of
adamc@384 326 SOME "urp" =>
adamc@384 327 doit (fn (src, html) =>
adamc@384 328 let
adamc@384 329 val inf = TextIO.openIn src
adamc@384 330 val out = TextIO.openOut html
adamc@381 331
adamc@384 332 fun loop () =
adamc@384 333 case TextIO.inputLine inf of
adamc@384 334 NONE => ()
adamc@384 335 | SOME line => (TextIO.output (out, line);
adamc@384 336 loop ())
adamc@384 337 in
adamc@384 338 TextIO.output (out, "<html><body>\n\n<pre>");
adamc@384 339 loop ();
adamc@384 340 TextIO.output (out, "</pre>\n\n</body></html>");
adamc@381 341
adamc@384 342 TextIO.closeIn inf;
adamc@384 343 TextIO.closeOut out
adamc@384 344 end)
adamc@384 345 | SOME "urs" => highlight ()
adamc@384 346 | SOME "ur" => highlight ()
adamc@384 347 | _ => ();
adamc@381 348 loop ()
adamc@381 349 end
adamc@381 350 in
adamc@381 351 loop ()
adamc@381 352 end
adamc@380 353 in
adamc@384 354 case readIndex () of
adamc@384 355 NONE => raise Fail "No demo applications!"
adamc@384 356 | SOME combined =>
adamc@384 357 let
adamc@384 358 val () = (TextIO.output (urOut, "</body></xml>\n");
adamc@384 359 TextIO.closeOut urOut)
adamc@384 360
adamc@384 361 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 362 file = "demo.urp"}
adamc@384 363 val outf = TextIO.openOut fname
adamc@384 364 in
adamc@384 365 Option.app (fn db => (TextIO.output (outf, "database ");
adamc@384 366 TextIO.output (outf, db);
adamc@384 367 TextIO.output (outf, "\n")))
adamc@384 368 (#database combined);
adamc@384 369 TextIO.output (outf, "sql demo.sql\n");
adamc@385 370 TextIO.output (outf, "prefix ");
adamc@385 371 TextIO.output (outf, prefix);
adamc@385 372 TextIO.output (outf, "\n");
adamc@384 373 TextIO.output (outf, "\n");
adamc@384 374
adamc@384 375 app (fn s =>
adamc@384 376 let
adamc@384 377 val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
adamc@384 378 path = s}
adamc@384 379 in
adamc@384 380 TextIO.output (outf, s);
adamc@384 381 TextIO.output (outf, "\n")
adamc@384 382 end)
adamc@384 383 (#sources combined);
adamc@384 384 TextIO.output (outf, "\n");
adamc@384 385 TextIO.output (outf, "demo\n");
adamc@384 386
adamc@384 387 TextIO.closeOut outf;
adamc@384 388
adamc@384 389 Compiler.compile (OS.Path.base fname)
adamc@384 390 end;
adamc@380 391
adamc@381 392 TextIO.output (demosOut, "\n</body></html>\n");
adamc@381 393 TextIO.closeOut demosOut;
adamc@381 394
adamc@381 395 prettyPrint ()
adamc@380 396 end
adamc@380 397
adamc@380 398 end