Mercurial > urweb

annotate src/main.mlton.sml @ 1726:4df4521fbd3b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Removed excess zero byte from empty pages. Zero byte sometimes breaks http tunneling in Safari. Empty page is a "Not Modified" response for app.js
author Vladimir Shabanov <vshabanoff@gmail.com>
date Wed, 25 Apr 2012 03:07:07 +0400
parents 5ecf67553da8
children ab24a7cb2a64
rev   line source
adam@1677 1 (* Copyright (c) 2008-2012, Adam Chlipala
adamc@0 2 * All rights reserved.
adamc@0 3 *
adamc@0 4 * Redistribution and use in source and binary forms, with or without
adamc@0 5 * modification, are permitted provided that the following conditions are met:
adamc@0 6 *
adamc@0 7 * - Redistributions of source code must retain the above copyright notice,
adamc@0 8 * this list of conditions and the following disclaimer.
adamc@0 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@0 10 * this list of conditions and the following disclaimer in the documentation
adamc@0 11 * and/or other materials provided with the distribution.
adamc@0 12 * - The names of contributors may not be used to endorse or promote products
adamc@0 13 * derived from this software without specific prior written permission.
adamc@0 14 *
adamc@0 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@0 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@0 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@0 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@0 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@0 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@0 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@0 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@0 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@0 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@0 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@0 26 *)
adamc@0 27
adamc@857 28 val timing = ref false
adamc@1086 29 val tc = ref false
adamc@857 30 val sources = ref ([] : string list)
adamc@857 31 val demo = ref (NONE : (string * bool) option)
adam@1493 32 val tutorial = ref false
adamc@1170 33 val css = ref false
adamc@857 34
adam@1540 35 val () = Compiler.beforeC := MLton.GC.pack
adam@1540 36
adam@1520 37 fun printVersion () = (print (Config.versionString ^ "\n");
adam@1520 38 OS.Process.exit OS.Process.success)
adam@1520 39 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
adam@1520 40 OS.Process.exit OS.Process.success)
adam@1520 41
adamc@857 42 fun doArgs args =
adamc@208 43 case args of
adamc@857 44 [] => ()
adam@1520 45 | "-version" :: rest =>
adam@1520 46 printVersion ()
adam@1520 47 | "-numeric-version" :: rest =>
adam@1520 48 printNumericVersion ()
adamc@1170 49 | "-css" :: rest =>
adamc@1170 50 (css := true;
adamc@1170 51 doArgs rest)
adamc@384 52 | "-demo" :: prefix :: rest =>
adamc@857 53 (demo := SOME (prefix, false);
adamc@857 54 doArgs rest)
adamc@501 55 | "-guided-demo" :: prefix :: rest =>
adamc@857 56 (demo := SOME (prefix, true);
adamc@857 57 doArgs rest)
adam@1493 58 | "-tutorial" :: rest =>
adam@1493 59 (tutorial := true;
adam@1493 60 doArgs rest)
adamc@856 61 | "-protocol" :: name :: rest =>
adamc@856 62 (Settings.setProtocol name;
adamc@857 63 doArgs rest)
adam@1335 64 | "-prefix" :: prefix :: rest =>
adam@1335 65 (Settings.setUrlPrefix prefix;
adam@1335 66 doArgs rest)
adamc@891 67 | "-db" :: s :: rest =>
adamc@891 68 (Settings.setDbstring (SOME s);
adamc@891 69 doArgs rest)
adamc@866 70 | "-dbms" :: name :: rest =>
adamc@866 71 (Settings.setDbms name;
adamc@866 72 doArgs rest)
adamc@857 73 | "-debug" :: rest =>
adamc@857 74 (Settings.setDebug true;
adamc@857 75 doArgs rest)
adamc@1178 76 | "-verbose" :: rest =>
adamc@1178 77 (Compiler.debug := true;
adamc@1178 78 doArgs rest)
adamc@857 79 | "-timing" :: rest =>
adamc@857 80 (timing := true;
adamc@857 81 doArgs rest)
adamc@1086 82 | "-tc" :: rest =>
adamc@1086 83 (tc := true;
adamc@1086 84 doArgs rest)
adam@1531 85 | "-dumpTypes" :: rest =>
adam@1531 86 (Elaborate.dumpTypes := true;
adam@1531 87 doArgs rest)
adam@1723 88 | "-unifyMore" :: rest =>
adam@1723 89 (Elaborate.unifyMore := true;
adam@1723 90 doArgs rest)
adam@1677 91 | "-dumpSource" :: rest =>
adam@1677 92 (Compiler.dumpSource := true;
adam@1677 93 doArgs rest)
adamc@891 94 | "-output" :: s :: rest =>
adamc@891 95 (Settings.setExe (SOME s);
adamc@891 96 doArgs rest)
adamc@891 97 | "-sql" :: s :: rest =>
adamc@891 98 (Settings.setSql (SOME s);
adamc@891 99 doArgs rest)
adamc@1095 100 | "-static" :: rest =>
adamc@1095 101 (Settings.setStaticLinking true;
adamc@1095 102 doArgs rest)
adamc@1126 103 | "-path" :: name :: path :: rest =>
adamc@1126 104 (Compiler.addPath (name, path);
adamc@1126 105 doArgs rest)
adamc@1126 106 | "-root" :: name :: root :: rest =>
adamc@1126 107 (Compiler.addModuleRoot (root, name);
adamc@1126 108 doArgs rest)
adamc@1164 109 | "-sigfile" :: name :: rest =>
adamc@1164 110 (Settings.setSigFile (SOME name);
adamc@1164 111 doArgs rest)
adamc@1235 112 | "-iflow" :: rest =>
adamc@1235 113 (Compiler.doIflow := true;
adamc@1235 114 doArgs rest)
adamc@1266 115 | "-moduleOf" :: fname :: _ =>
adamc@1266 116 (print (Compiler.moduleOf fname ^ "\n");
adamc@1266 117 OS.Process.exit OS.Process.success)
adam@1301 118 | "-noEmacs" :: rest =>
adam@1301 119 (Demo.noEmacs := true;
adam@1301 120 doArgs rest)
adam@1307 121 | "-limit" :: class :: num :: rest =>
adam@1307 122 (case Int.fromString num of
adam@1307 123 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1307 124 | SOME n =>
adam@1307 125 if n < 0 then
adam@1307 126 raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1307 127 else
adam@1307 128 Settings.addLimit (class, n);
adam@1307 129 doArgs rest)
adamc@208 130 | arg :: rest =>
adamc@857 131 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adamc@857 132 raise Fail ("Unknown flag " ^ arg)
adamc@857 133 else
adamc@857 134 sources := arg :: !sources;
adamc@857 135 doArgs rest)
adamc@208 136
adamc@857 137 val () = doArgs (CommandLine.arguments ())
adamc@208 138
adamc@279 139 val job =
adamc@857 140 case !sources of
adamc@279 141 [file] => file
adam@1520 142 | _ => printVersion ()
adamc@279 143
adamc@208 144 val () =
adam@1493 145 case (!css, !demo, !tutorial) of
adam@1493 146 (true, _, _) =>
adamc@1170 147 (case Compiler.run Compiler.toCss job of
adamc@1170 148 NONE => OS.Process.exit OS.Process.failure
adamc@1170 149 | SOME {Overall = ov, Classes = cl} =>
adamc@1170 150 (app (print o Css.inheritableToString) ov;
adamc@1170 151 print "\n";
adamc@1170 152 app (fn (x, (ins, ots)) =>
adamc@1170 153 (print x;
adamc@1170 154 print " ";
adamc@1170 155 app (print o Css.inheritableToString) ins;
adamc@1170 156 app (print o Css.othersToString) ots;
adamc@1170 157 print "\n")) cl))
adam@1493 158 | (_, SOME (prefix, guided), _) =>
adamc@501 159 Demo.make {prefix = prefix, dirname = job, guided = guided}
adam@1493 160 | (_, _, true) => Tutorial.make job
adamc@1170 161 | _ =>
adamc@1086 162 if !tc then
adamc@1086 163 (Compiler.check Compiler.toElaborate job;
adamc@1086 164 if ErrorMsg.anyErrors () then
adamc@1086 165 OS.Process.exit OS.Process.failure
adamc@1086 166 else
adamc@1086 167 ())
adamc@1086 168 else if !timing then
adamc@384 169 Compiler.time Compiler.toCjrize job
adamc@384 170 else
adamc@1045 171 Compiler.compiler job