Mercurial > urweb

annotate src/demo.sml @ 2050:04d7d563a36f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
MonoReduce bug involving 'error'
author Adam Chlipala <adam@chlipala.net>
date Wed, 06 Aug 2014 09:50:02 -0400
parents e4051315263e
children
rev   line source
adamc@1151 1 (* Copyright (c) 2008-2010, 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
adam@1301 30 val noEmacs = ref false
adam@1301 31
adamc@1079 32 fun make' {prefix, dirname, guided} =
adamc@380 33 let
adamc@380 34 val prose = OS.Path.joinDirFile {dir = dirname,
adamc@380 35 file = "prose"}
adamc@380 36 val inf = TextIO.openIn prose
adamc@380 37
adamc@380 38 val outDir = OS.Path.concat (dirname, "out")
adamc@380 39
adamc@380 40 val () = if OS.FileSys.access (outDir, []) then
adamc@380 41 ()
adamc@380 42 else
adamc@380 43 OS.FileSys.mkDir outDir
adamc@380 44
adamc@380 45 val fname = OS.Path.joinDirFile {dir = outDir,
adamc@380 46 file = "index.html"}
adamc@380 47
adamc@380 48 val out = TextIO.openOut fname
adamc@773 49 val () = (TextIO.output (out, "<frameset cols=\"15%,85%\">\n");
adamc@380 50 TextIO.output (out, "<frame src=\"demos.html\">\n");
adamc@380 51 TextIO.output (out, "<frame src=\"intro.html\" name=\"staging\">\n");
adamc@380 52 TextIO.output (out, "</frameset>\n");
adamc@380 53 TextIO.closeOut out)
adamc@380 54
adamc@380 55 val fname = OS.Path.joinDirFile {dir = outDir,
adamc@380 56 file = "demos.html"}
adamc@380 57
adamc@380 58 val demosOut = TextIO.openOut fname
adamc@381 59 val () = (TextIO.output (demosOut, "<html><body>\n\n");
adamc@380 60 TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"intro.html\">Intro</a></li>\n\n"))
adamc@380 61
adamc@384 62 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 63 file = "demo.urs"}
adamc@384 64 val ursOut = TextIO.openOut fname
adamc@384 65 val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n");
adamc@384 66 TextIO.closeOut ursOut)
adamc@384 67
adamc@384 68 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 69 file = "demo.ur"}
adamc@384 70 val urOut = TextIO.openOut fname
adamc@384 71 val () = TextIO.output (urOut, "fun main () = return <xml><body>\n")
adamc@384 72
adamc@380 73 fun mergeWith f (o1, o2) =
adamc@380 74 case (o1, o2) of
adamc@380 75 (NONE, _) => o2
adamc@380 76 | (_, NONE) => o1
adamc@380 77 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adamc@380 78
adamc@380 79 fun combiner (combined : Compiler.job, urp : Compiler.job) = {
adamc@385 80 prefix = prefix,
adamc@380 81 database = mergeWith (fn (v1, v2) =>
adamc@380 82 if v1 = v2 then
adamc@380 83 v1
adamc@380 84 else
adamc@380 85 raise Fail "Different demos want to use different database strings")
adamc@380 86 (#database combined, #database urp),
adamc@380 87 sources = foldl (fn (file, files) =>
adamc@380 88 if List.exists (fn x => x = file) files then
adamc@380 89 files
adamc@380 90 else
adamc@380 91 files @ [file])
adamc@380 92 (#sources combined) (#sources urp),
adamc@891 93 exe = case Settings.getExe () of
adamc@891 94 NONE => OS.Path.joinDirFile {dir = dirname,
adamc@891 95 file = "demo.exe"}
adamc@891 96 | SOME s => s,
adamc@891 97 sql = SOME (case Settings.getSql () of
adamc@891 98 NONE => OS.Path.joinDirFile {dir = dirname,
adamc@891 99 file = "demo.sql"}
adamc@891 100 | SOME s => s),
adamc@863 101 debug = Settings.getDebug (),
adamc@673 102 timeout = Int.max (#timeout combined, #timeout urp),
adamc@764 103 profile = false,
adamc@764 104 ffi = [],
adamc@764 105 link = [],
adam@1725 106 linker = NONE,
adamc@765 107 headers = [],
adamc@766 108 scripts = [],
adamc@765 109 clientToServer = [],
adamc@765 110 effectful = [],
adamc@1171 111 benignEffectful = [],
adamc@765 112 clientOnly = [],
adamc@765 113 serverOnly = [],
adamc@768 114 jsFuncs = [],
adamc@774 115 rewrites = #rewrites combined @ #rewrites urp,
adamc@769 116 filterUrl = #filterUrl combined @ #filterUrl urp,
adamc@866 117 filterMime = #filterMime combined @ #filterMime urp,
adam@1465 118 filterRequest = #filterRequest combined @ #filterRequest urp,
adam@1465 119 filterResponse = #filterResponse combined @ #filterResponse urp,
adam@1799 120 filterEnv = #filterEnv combined @ #filterEnv urp,
adamc@866 121 protocol = mergeWith #2 (#protocol combined, #protocol urp),
adamc@1164 122 dbms = mergeWith #2 (#dbms combined, #dbms urp),
adamc@1183 123 sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
adam@1614 124 safeGets = #safeGets combined @ #safeGets urp,
adam@1332 125 onError = NONE,
adam@1332 126 minHeap = 0
adamc@380 127 }
adamc@380 128
adamc@380 129 val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
adamc@380 130
adamc@380 131 fun capitalize "" = ""
adamc@380 132 | capitalize s = str (Char.toUpper (String.sub (s, 0)))
adamc@380 133 ^ String.extract (s, 1, NONE)
adamc@380 134
adamc@380 135 fun startUrp urp =
adamc@380 136 let
adamc@380 137 val base = OS.Path.base urp
adamc@380 138 val name = capitalize base
adamc@380 139
adamc@380 140 val () = (TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"");
adamc@380 141 TextIO.output (demosOut, base);
adamc@380 142 TextIO.output (demosOut, ".html\">");
adamc@380 143 TextIO.output (demosOut, name);
adamc@380 144 TextIO.output (demosOut, "</a></li>\n"))
adamc@380 145
adamc@384 146 val () = (TextIO.output (urOut, " <li> <a link={");
adamc@384 147 TextIO.output (urOut, name);
adamc@384 148 TextIO.output (urOut, ".main ()}>");
adamc@384 149 TextIO.output (urOut, name);
adamc@384 150 TextIO.output (urOut, "</a></li>\n"))
adamc@384 151
adamc@380 152 val urp_file = OS.Path.joinDirFile {dir = dirname,
adamc@380 153 file = urp}
adamc@380 154
adamc@380 155 val out = OS.Path.joinBaseExt {base = base,
adamc@380 156 ext = SOME "html"}
adamc@380 157 val out = OS.Path.joinDirFile {dir = outDir,
adamc@380 158 file = out}
adamc@380 159 val out = TextIO.openOut out
adamc@380 160
adamc@501 161 val () = (TextIO.output (out, "<frameset rows=\"");
adamc@501 162 TextIO.output (out, if guided then
adamc@501 163 "*,100"
adamc@501 164 else
adamc@501 165 "50%,*");
adamc@501 166 TextIO.output (out, "\">\n");
adamc@380 167 TextIO.output (out, "<frame src=\"");
adamc@380 168 TextIO.output (out, prefix);
adamc@380 169 TextIO.output (out, "/");
adamc@380 170 TextIO.output (out, name);
adamc@380 171 TextIO.output (out, "/main\" name=\"showcase\">\n");
adamc@380 172 TextIO.output (out, "<frame src=\"");
adamc@380 173 TextIO.output (out, base);
adamc@380 174 TextIO.output (out, ".desc.html\">\n");
adamc@380 175 TextIO.output (out, "</frameset>\n");
adamc@380 176 TextIO.closeOut out)
adamc@380 177 val () = TextIO.closeOut out
adamc@380 178
adamc@380 179 val out = OS.Path.joinBaseExt {base = base,
adamc@380 180 ext = SOME "desc"}
adamc@380 181 val out = OS.Path.joinBaseExt {base = out,
adamc@380 182 ext = SOME "html"}
adamc@380 183 val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
adamc@380 184 file = out})
adamc@380 185 in
adamc@380 186 case parse (OS.Path.base urp_file) of
adamc@380 187 NONE => raise Fail ("Can't parse " ^ urp_file)
adamc@380 188 | SOME urpData =>
adamc@380 189 (TextIO.output (out, "<html><head>\n<title>");
adamc@380 190 TextIO.output (out, name);
adamc@380 191 TextIO.output (out, "</title>\n</head><body>\n\n<h1>");
adamc@380 192 TextIO.output (out, name);
adamc@380 193 TextIO.output (out, "</h1>\n\n<center>[ <a target=\"showcase\" href=\"");
adamc@382 194 TextIO.output (out, prefix);
adamc@382 195 TextIO.output (out, "/");
adamc@382 196 TextIO.output (out, name);
adamc@382 197 TextIO.output (out, "/main\">Application</a>");
adamc@382 198 TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 199 TextIO.output (out, urp);
adamc@380 200 TextIO.output (out, ".html\"><tt>");
adamc@380 201 TextIO.output (out, urp);
adamc@380 202 TextIO.output (out, "</tt></a>");
adamc@380 203 app (fn file =>
adamc@380 204 let
adamc@380 205 fun ifEx s =
adamc@380 206 let
adamc@380 207 val src = OS.Path.joinBaseExt {base = file,
adamc@380 208 ext = SOME s}
adamc@380 209 val src' = OS.Path.file src
adamc@380 210 in
adamc@1151 211 if String.isPrefix (OS.Path.mkAbsolute {path = dirname,
adamc@1151 212 relativeTo = OS.FileSys.getDir ()}) src
adamc@943 213 andalso OS.FileSys.access (src, []) then
adamc@380 214 (TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 215 TextIO.output (out, src');
adamc@380 216 TextIO.output (out, ".html\"><tt>");
adamc@380 217 TextIO.output (out, src');
adamc@380 218 TextIO.output (out, "</tt></a>"))
adamc@380 219 else
adamc@1156 220 ()
adamc@380 221 end
adamc@380 222 in
adamc@380 223 ifEx "urs";
adamc@380 224 ifEx "ur"
adamc@380 225 end) (#sources urpData);
adamc@380 226 TextIO.output (out, " ]</center>\n\n");
adamc@380 227
adamc@380 228 (urpData, out))
adamc@380 229 end
adamc@380 230
adamc@380 231 fun endUrp out =
adamc@380 232 (TextIO.output (out, "\n</body></html>\n");
adamc@380 233 TextIO.closeOut out)
adamc@380 234
adamc@380 235 fun readUrp (combined, out) =
adamc@380 236 let
adamc@380 237 fun finished () = endUrp out
adamc@380 238
adamc@380 239 fun readUrp' () =
adamc@380 240 case TextIO.inputLine inf of
adamc@384 241 NONE => (finished ();
adamc@384 242 combined)
adamc@380 243 | SOME line =>
adamc@380 244 if String.isSuffix ".urp\n" line then
adamc@380 245 let
adamc@380 246 val urp = String.substring (line, 0, size line - 1)
adamc@380 247 val (urpData, out) = startUrp urp
adamc@380 248 in
adamc@380 249 finished ();
adamc@380 250
adamc@380 251 readUrp (combiner (combined, urpData),
adamc@380 252 out)
adamc@380 253 end
adamc@380 254 else
adamc@380 255 (TextIO.output (out, line);
adamc@380 256 readUrp' ())
adamc@380 257 in
adamc@380 258 readUrp' ()
adamc@380 259 end
adamc@380 260
adamc@380 261 val indexFile = OS.Path.joinDirFile {dir = outDir,
adamc@380 262 file = "intro.html"}
adamc@380 263
adamc@380 264 val out = TextIO.openOut indexFile
adamc@380 265 val () = TextIO.output (out, "<html><head>\n<title>Ur/Web Demo</title>\n</head><body>\n\n")
adamc@380 266
adamc@380 267 fun readIndex () =
adamc@380 268 let
adamc@380 269 fun finished () = (TextIO.output (out, "\n</body></html>\n");
adamc@380 270 TextIO.closeOut out)
adamc@380 271 in
adamc@380 272 case TextIO.inputLine inf of
adamc@384 273 NONE => (finished ();
adamc@384 274 NONE)
adamc@380 275 | SOME line =>
adamc@380 276 if String.isSuffix ".urp\n" line then
adamc@380 277 let
adamc@380 278 val urp = String.substring (line, 0, size line - 1)
adamc@380 279 val (urpData, out) = startUrp urp
adamc@380 280 in
adamc@380 281 finished ();
adamc@380 282
adamc@384 283 SOME (readUrp (urpData,
adamc@384 284 out))
adamc@380 285 end
adamc@380 286 else
adamc@380 287 (TextIO.output (out, line);
adamc@380 288 readIndex ())
adamc@380 289 end
adamc@381 290
adamc@381 291 fun prettyPrint () =
adamc@381 292 let
adamc@381 293 val dir = Posix.FileSys.opendir dirname
adamc@381 294
adamc@381 295 fun loop () =
adamc@381 296 case Posix.FileSys.readdir dir of
adamc@381 297 NONE => Posix.FileSys.closedir dir
adamc@381 298 | SOME file =>
adamc@381 299 let
adamc@381 300 fun doit f =
adamc@381 301 f (OS.Path.joinDirFile {dir = dirname,
adamc@381 302 file = file},
adamc@382 303 OS.Path.mkAbsolute
adamc@382 304 {relativeTo = OS.FileSys.getDir (),
adamc@382 305 path = OS.Path.joinDirFile {dir = outDir,
adamc@382 306 file = OS.Path.joinBaseExt {base = file,
adamc@382 307 ext = SOME "html"}}})
adamc@382 308
adamc@382 309 fun highlight () =
adamc@382 310 doit (fn (src, html) =>
adamc@382 311 let
adamc@410 312 val dirty =
adamc@410 313 let
adamc@410 314 val srcSt = Posix.FileSys.stat src
adamc@410 315 val htmlSt = Posix.FileSys.stat html
adamc@410 316 in
adamc@410 317 Time.> (Posix.FileSys.ST.mtime srcSt,
adamc@410 318 Posix.FileSys.ST.mtime htmlSt)
adamc@410 319 end handle OS.SysErr _ => true
adamc@410 320
adamc@382 321 val cmd = "emacs --eval \"(progn "
adamc@382 322 ^ "(global-font-lock-mode t) "
adamc@382 323 ^ "(add-to-list 'load-path \\\""
ezyang@1739 324 ^ !Settings.configSitelisp
adamc@382 325 ^ "/\\\") "
adamc@382 326 ^ "(load \\\"urweb-mode-startup\\\") "
adamc@382 327 ^ "(urweb-mode) "
adamc@382 328 ^ "(find-file \\\""
adamc@382 329 ^ src
adamc@382 330 ^ "\\\") "
adamc@382 331 ^ "(switch-to-buffer (htmlize-buffer)) "
adamc@382 332 ^ "(write-file \\\""
adamc@382 333 ^ html
adamc@382 334 ^ "\\\") "
adamc@382 335 ^ "(kill-emacs))\""
adamc@382 336 in
adamc@410 337 if dirty then
adamc@410 338 (print (">>> " ^ cmd ^ "\n");
adamc@410 339 ignore (OS.Process.system cmd))
adamc@410 340 else
adamc@410 341 ()
adamc@382 342 end)
adam@1301 343
adam@1301 344 val highlight = fn () => if !noEmacs then () else highlight ()
adamc@381 345 in
adamc@384 346 if OS.Path.base file = "demo" then
adamc@384 347 ()
adamc@384 348 else case OS.Path.ext file of
adamc@384 349 SOME "urp" =>
adamc@384 350 doit (fn (src, html) =>
adamc@384 351 let
adamc@384 352 val inf = TextIO.openIn src
adamc@384 353 val out = TextIO.openOut html
adamc@381 354
adamc@384 355 fun loop () =
adamc@384 356 case TextIO.inputLine inf of
adamc@384 357 NONE => ()
adamc@384 358 | SOME line => (TextIO.output (out, line);
adamc@384 359 loop ())
adamc@384 360 in
adamc@384 361 TextIO.output (out, "<html><body>\n\n<pre>");
adamc@384 362 loop ();
adamc@384 363 TextIO.output (out, "</pre>\n\n</body></html>");
adamc@381 364
adamc@384 365 TextIO.closeIn inf;
adamc@384 366 TextIO.closeOut out
adamc@384 367 end)
adamc@384 368 | SOME "urs" => highlight ()
adamc@384 369 | SOME "ur" => highlight ()
adamc@384 370 | _ => ();
adamc@381 371 loop ()
adamc@381 372 end
adamc@381 373 in
adamc@381 374 loop ()
adamc@381 375 end
adamc@380 376 in
adamc@384 377 case readIndex () of
adamc@384 378 NONE => raise Fail "No demo applications!"
adamc@384 379 | SOME combined =>
adamc@384 380 let
adamc@384 381 val () = (TextIO.output (urOut, "</body></xml>\n");
adamc@384 382 TextIO.closeOut urOut)
adamc@384 383
adamc@384 384 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 385 file = "demo.urp"}
adamc@384 386 val outf = TextIO.openOut fname
adamc@776 387
adamc@776 388 fun filters kind =
adamc@776 389 app (fn rule : Settings.rule =>
adamc@776 390 (TextIO.output (outf, case #action rule of
adamc@776 391 Settings.Allow => "allow"
adamc@776 392 | Settings.Deny => "deny");
adamc@776 393 TextIO.output (outf, " ");
adamc@776 394 TextIO.output (outf, kind);
adamc@776 395 TextIO.output (outf, " ");
adamc@776 396 TextIO.output (outf, #pattern rule);
adamc@776 397 case #kind rule of
adamc@776 398 Settings.Exact => ()
adamc@776 399 | Settings.Prefix => TextIO.output (outf, "*");
adamc@776 400 TextIO.output (outf, "\n")))
adamc@384 401 in
adamc@384 402 Option.app (fn db => (TextIO.output (outf, "database ");
adamc@384 403 TextIO.output (outf, db);
adamc@384 404 TextIO.output (outf, "\n")))
adamc@384 405 (#database combined);
adamc@384 406 TextIO.output (outf, "sql demo.sql\n");
adamc@385 407 TextIO.output (outf, "prefix ");
adamc@385 408 TextIO.output (outf, prefix);
adamc@385 409 TextIO.output (outf, "\n");
adamc@774 410 app (fn rule =>
adamc@774 411 (TextIO.output (outf, "rewrite ");
adamc@774 412 TextIO.output (outf, case #pkind rule of
adam@2023 413 Settings.Any => "all"
adamc@774 414 | Settings.Url => "url"
adamc@774 415 | Settings.Table => "table"
adamc@774 416 | Settings.Sequence => "sequence"
adamc@774 417 | Settings.View => "view"
adamc@774 418 | Settings.Relation => "relation"
adamc@774 419 | Settings.Cookie => "cookie"
adamc@774 420 | Settings.Style => "style");
adamc@774 421 TextIO.output (outf, " ");
adamc@774 422 TextIO.output (outf, #from rule);
adamc@774 423 case #kind rule of
adamc@774 424 Settings.Exact => ()
adamc@774 425 | Settings.Prefix => TextIO.output (outf, "*");
adamc@774 426 TextIO.output (outf, " ");
adamc@774 427 TextIO.output (outf, #to rule);
adam@1761 428 if #hyphenate rule then
adam@1761 429 TextIO.output (outf, " [-]")
adam@1761 430 else
adam@1761 431 ();
adamc@774 432 TextIO.output (outf, "\n"))) (#rewrites combined);
adamc@776 433 filters "url" (#filterUrl combined);
adamc@776 434 filters "mime" (#filterMime combined);
adam@1614 435 app (fn path =>
adam@1614 436 (TextIO.output (outf, "safeGet ");
adam@1614 437 TextIO.output (outf, path);
adam@1614 438 TextIO.output (outf, "\n"))) (#safeGets combined);
adamc@384 439 TextIO.output (outf, "\n");
adamc@384 440
adamc@384 441 app (fn s =>
adamc@384 442 let
adamc@384 443 val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
adamc@384 444 path = s}
adamc@384 445 in
adamc@384 446 TextIO.output (outf, s);
adamc@384 447 TextIO.output (outf, "\n")
adamc@384 448 end)
adamc@384 449 (#sources combined);
adamc@384 450 TextIO.output (outf, "\n");
adamc@384 451 TextIO.output (outf, "demo\n");
adamc@384 452
adamc@384 453 TextIO.closeOut outf;
adamc@384 454
adamc@1079 455 let
adamc@1079 456 val b = Compiler.compile (OS.Path.base fname)
adamc@1079 457 in
adamc@1079 458 TextIO.output (demosOut, "\n</body></html>\n");
adamc@1079 459 TextIO.closeOut demosOut;
adamc@1079 460 if b then
adamc@1079 461 prettyPrint ()
adamc@1079 462 else
adamc@1079 463 ();
adamc@1079 464 b
adamc@1079 465 end
adamc@1079 466 end
adamc@380 467 end
adamc@380 468
adamc@1079 469 fun make args = if make' args then
adamc@1079 470 ()
adamc@1079 471 else
adamc@1079 472 OS.Process.exit OS.Process.failure
adamc@1079 473
adamc@380 474 end