Mercurial > urweb

annotate src/compiler.sml @ 853:19fdeef40ada

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out common request functionality, in preparation for supporting different protocols
author Adam Chlipala <adamc@hcoop.net>
date Tue, 23 Jun 2009 14:05:12 -0400
parents 74e9e7642f08
children 28e42b22424d
rev   line source
adamc@764 1 (* Copyright (c) 2008-2009, Adam Chlipala
adamc@1 2 * All rights reserved.
adamc@1 3 *
adamc@1 4 * Redistribution and use in source and binary forms, with or without
adamc@1 5 * modification, are permitted provided that the following conditions are met:
adamc@1 6 *
adamc@1 7 * - Redistributions of source code must retain the above copyright notice,
adamc@1 8 * this list of conditions and the following disclaimer.
adamc@1 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1 10 * this list of conditions and the following disclaimer in the documentation
adamc@1 11 * and/or other materials provided with the distribution.
adamc@1 12 * - The names of contributors may not be used to endorse or promote products
adamc@1 13 * derived from this software without specific prior written permission.
adamc@1 14 *
adamc@1 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@1 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@1 26 *)
adamc@1 27
adamc@1 28 structure Compiler :> COMPILER = struct
adamc@1 29
adamc@244 30 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
adamc@244 31 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
adamc@244 32 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
adamc@1 33 structure Lex = Lex
adamc@1 34 structure LrParser = LrParser)
adamc@1 35
adamc@270 36 type job = {
adamc@385 37 prefix : string,
adamc@270 38 database : string option,
adamc@274 39 sources : string list,
adamc@274 40 exe : string,
adamc@274 41 sql : string option,
adamc@502 42 debug : bool,
adamc@673 43 profile : bool,
adamc@764 44 timeout : int,
adamc@764 45 ffi : string list,
adamc@764 46 link : string list,
adamc@765 47 headers : string list,
adamc@766 48 scripts : string list,
adamc@765 49 clientToServer : Settings.ffi list,
adamc@765 50 effectful : Settings.ffi list,
adamc@765 51 clientOnly : Settings.ffi list,
adamc@765 52 serverOnly : Settings.ffi list,
adamc@768 53 jsFuncs : (Settings.ffi * string) list,
adamc@769 54 rewrites : Settings.rewrite list,
adamc@769 55 filterUrl : Settings.rule list,
adamc@769 56 filterMime : Settings.rule list
adamc@270 57 }
adamc@201 58
adamc@201 59 type ('src, 'dst) phase = {
adamc@201 60 func : 'src -> 'dst,
adamc@201 61 print : 'dst -> Print.PD.pp_desc
adamc@201 62 }
adamc@201 63
adamc@201 64 type pmap = (string * Time.time) list
adamc@201 65
adamc@201 66 type ('src, 'dst) transform = {
adamc@201 67 func : 'src -> 'dst option,
adamc@201 68 print : 'dst -> Print.PD.pp_desc,
adamc@201 69 time : 'src * pmap -> 'dst option * pmap
adamc@201 70 }
adamc@201 71
adamc@201 72 fun transform (ph : ('src, 'dst) phase) name = {
adamc@201 73 func = fn input => let
adamc@201 74 val v = #func ph input
adamc@201 75 in
adamc@201 76 if ErrorMsg.anyErrors () then
adamc@201 77 NONE
adamc@201 78 else
adamc@201 79 SOME v
adamc@201 80 end,
adamc@201 81 print = #print ph,
adamc@201 82 time = fn (input, pmap) => let
adamc@201 83 val befor = Time.now ()
adamc@201 84 val v = #func ph input
adamc@201 85 val elapsed = Time.- (Time.now (), befor)
adamc@201 86 in
adamc@201 87 (if ErrorMsg.anyErrors () then
adamc@201 88 NONE
adamc@201 89 else
adamc@201 90 SOME v,
adamc@201 91 (name, elapsed) :: pmap)
adamc@201 92 end
adamc@201 93 }
adamc@201 94
adamc@270 95 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
adamc@201 96 func = fn input => case #func tr1 input of
adamc@201 97 NONE => NONE
adamc@201 98 | SOME v => #func tr2 v,
adamc@201 99 print = #print tr2,
adamc@201 100 time = fn (input, pmap) => let
adamc@201 101 val (ro, pmap) = #time tr1 (input, pmap)
adamc@201 102 in
adamc@201 103 case ro of
adamc@201 104 NONE => (NONE, pmap)
adamc@201 105 | SOME v => #time tr2 (v, pmap)
adamc@201 106 end
adamc@201 107 }
adamc@201 108
adamc@346 109 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@346 110 ignore (#func tr x))
adamc@346 111
adamc@280 112 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@280 113 #func tr x)
adamc@201 114
adamc@201 115 fun runPrint (tr : ('src, 'dst) transform) input =
adamc@280 116 (ErrorMsg.resetErrors ();
adamc@280 117 case #func tr input of
adamc@280 118 NONE => print "Failure\n"
adamc@280 119 | SOME v =>
adamc@280 120 (print "Success\n";
adamc@280 121 Print.print (#print tr v);
adamc@280 122 print "\n"))
adamc@201 123
adamc@201 124 fun time (tr : ('src, 'dst) transform) input =
adamc@55 125 let
adamc@201 126 val (_, pmap) = #time tr (input, [])
adamc@201 127 in
adamc@201 128 app (fn (name, time) =>
adamc@201 129 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 130 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 131 print "\n"
adamc@201 132 end
adamc@55 133
adamc@201 134 fun timePrint (tr : ('src, 'dst) transform) input =
adamc@201 135 let
adamc@201 136 val (ro, pmap) = #time tr (input, [])
adamc@55 137 in
adamc@201 138 app (fn (name, time) =>
adamc@201 139 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 140 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 141 print "\n";
adamc@201 142 case ro of
adamc@201 143 NONE => print "Failure\n"
adamc@201 144 | SOME v =>
adamc@201 145 (print "Success\n";
adamc@201 146 Print.print (#print tr v);
adamc@201 147 print "\n")
adamc@55 148 end
adamc@55 149
adamc@244 150 val parseUrs =
adamc@201 151 {func = fn filename => let
adamc@201 152 val fname = OS.FileSys.tmpName ()
adamc@201 153 val outf = TextIO.openOut fname
adamc@201 154 val () = TextIO.output (outf, "sig\n")
adamc@201 155 val inf = TextIO.openIn filename
adamc@201 156 fun loop () =
adamc@201 157 case TextIO.inputLine inf of
adamc@201 158 NONE => ()
adamc@201 159 | SOME line => (TextIO.output (outf, line);
adamc@201 160 loop ())
adamc@201 161 val () = loop ()
adamc@201 162 val () = TextIO.closeIn inf
adamc@201 163 val () = TextIO.closeOut outf
adamc@201 164
adamc@201 165 val () = (ErrorMsg.resetErrors ();
adamc@201 166 ErrorMsg.resetPositioning filename;
adamc@201 167 Lex.UserDeclarations.initialize ())
adamc@201 168 val file = TextIO.openIn fname
adamc@201 169 fun get _ = TextIO.input file
adamc@201 170 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 171 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 172 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 173 in
adamc@201 174 TextIO.closeIn file;
adamc@201 175 case absyn of
adamc@201 176 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
adamc@201 177 | _ => (ErrorMsg.errorAt {file = filename,
adamc@201 178 first = {line = 0,
adamc@201 179 char = 0},
adamc@201 180 last = {line = 0,
adamc@201 181 char = 0}} "Not a signature";
adamc@201 182 [])
adamc@201 183 end
adamc@201 184 handle LrParser.ParseError => [],
adamc@201 185 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
adamc@55 186
adamc@1 187 (* The main parsing routine *)
adamc@244 188 val parseUr = {
adamc@201 189 func = fn filename =>
adamc@201 190 let
adamc@201 191 val () = (ErrorMsg.resetErrors ();
adamc@201 192 ErrorMsg.resetPositioning filename;
adamc@201 193 Lex.UserDeclarations.initialize ())
adamc@201 194 val file = TextIO.openIn filename
adamc@201 195 fun get _ = TextIO.input file
adamc@201 196 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 197 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 198 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 199 in
adamc@201 200 TextIO.closeIn file;
adamc@201 201 case absyn of
adamc@201 202 [(Source.DSgn ("?", _), _)] =>
adamc@201 203 (ErrorMsg.errorAt {file = filename,
adamc@201 204 first = {line = 0,
adamc@201 205 char = 0},
adamc@201 206 last = {line = 0,
adamc@201 207 char = 0}} "File starts with 'sig'";
adamc@201 208 [])
adamc@201 209 | _ => absyn
adamc@201 210 end
adamc@201 211 handle LrParser.ParseError => [],
adamc@201 212 print = SourcePrint.p_file}
adamc@56 213
adamc@768 214 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
adamc@768 215 timeout, ffi, link, headers, scripts,
adamc@768 216 clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
adamc@270 217 let
adamc@270 218 open Print.PD
adamc@270 219 open Print
adamc@765 220
adamc@765 221 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
adamc@765 222 box [string name, space, string m, string ".", string s, newline])
adamc@270 223 in
adamc@274 224 box [if debug then
adamc@274 225 box [string "DEBUG", newline]
adamc@274 226 else
adamc@274 227 box [],
adamc@502 228 if profile then
adamc@502 229 box [string "PROFILE", newline]
adamc@502 230 else
adamc@502 231 box [],
adamc@274 232 case database of
adamc@270 233 NONE => string "No database."
adamc@270 234 | SOME db => string ("Database: " ^ db),
adamc@270 235 newline,
adamc@274 236 string "Exe: ",
adamc@274 237 string exe,
adamc@274 238 newline,
adamc@274 239 case sql of
adamc@274 240 NONE => string "No SQL file."
adamc@274 241 | SOME sql => string ("SQL fle: " ^ sql),
adamc@673 242 newline,
adamc@673 243 string "Timeout: ",
adamc@673 244 string (Int.toString timeout),
adamc@673 245 newline,
adamc@764 246 p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
adamc@764 247 p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
adamc@766 248 p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
adamc@764 249 p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
adamc@765 250 p_ffi "ClientToServer" clientToServer,
adamc@765 251 p_ffi "Effectful" effectful,
adamc@765 252 p_ffi "ClientOnly" clientOnly,
adamc@765 253 p_ffi "ServerOnly" serverOnly,
adamc@765 254 p_list_sep (box []) (fn ((m, s), s') =>
adamc@765 255 box [string "JsFunc", space, string m, string ".", string s,
adamc@765 256 space, string "=", space, string s', newline]) jsFuncs,
adamc@270 257 string "Sources:",
adamc@270 258 p_list string sources,
adamc@270 259 newline]
adamc@270 260 end
adamc@270 261
adamc@270 262 fun trim s =
adamc@270 263 let
adamc@270 264 val (_, s) = Substring.splitl Char.isSpace s
adamc@270 265 val (s, _) = Substring.splitr Char.isSpace s
adamc@270 266 in
adamc@270 267 s
adamc@270 268 end
adamc@270 269
adamc@794 270 structure M = BinaryMapFn(struct
adamc@794 271 type ord_key = string
adamc@794 272 val compare = String.compare
adamc@794 273 end)
adamc@794 274
adamc@794 275 fun parseUrp' fname =
adamc@767 276 let
adamc@794 277 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
adamc@767 278
adamc@794 279 fun pu filename =
adamc@794 280 let
adamc@794 281 val dir = OS.Path.dir filename
adamc@794 282 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
adamc@767 283
adamc@794 284 fun pathify fname =
adamc@794 285 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
adamc@794 286 let
adamc@794 287 val fname' = Substring.extract (fname, 1, NONE)
adamc@794 288 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
adamc@794 289 in
adamc@794 290 if Substring.isEmpty after then
adamc@794 291 fname
adamc@794 292 else
adamc@794 293 case M.find (!pathmap, Substring.string befor) of
adamc@794 294 NONE => fname
adamc@794 295 | SOME rep => rep ^ Substring.string after
adamc@794 296 end
adamc@794 297 else
adamc@794 298 fname
adamc@767 299
adamc@794 300 fun relify fname =
adamc@794 301 let
adamc@794 302 val fname = pathify fname
adamc@794 303 in
adamc@794 304 OS.Path.concat (dir, fname)
adamc@794 305 handle OS.Path.Path => fname
adamc@794 306 end
adamc@767 307
adamc@794 308 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
adamc@767 309
adamc@794 310 fun relifyA fname =
adamc@794 311 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
adamc@767 312
adamc@794 313 fun readSources acc =
adamc@794 314 case TextIO.inputLine inf of
adamc@794 315 NONE => rev acc
adamc@794 316 | SOME line =>
adamc@794 317 let
adamc@794 318 val acc = if CharVector.all Char.isSpace line then
adamc@794 319 acc
adamc@794 320 else
adamc@794 321 let
adamc@794 322 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
adamc@794 323 (String.explode line))
adamc@794 324 val fname = relify fname
adamc@794 325 in
adamc@794 326 fname :: acc
adamc@794 327 end
adamc@794 328 in
adamc@794 329 readSources acc
adamc@794 330 end
adamc@767 331
adamc@794 332 val prefix = ref NONE
adamc@794 333 val database = ref NONE
adamc@794 334 val exe = ref NONE
adamc@794 335 val sql = ref NONE
adamc@794 336 val debug = ref false
adamc@794 337 val profile = ref false
adamc@794 338 val timeout = ref NONE
adamc@794 339 val ffi = ref []
adamc@794 340 val link = ref []
adamc@794 341 val headers = ref []
adamc@794 342 val scripts = ref []
adamc@794 343 val clientToServer = ref []
adamc@794 344 val effectful = ref []
adamc@794 345 val clientOnly = ref []
adamc@794 346 val serverOnly = ref []
adamc@794 347 val jsFuncs = ref []
adamc@794 348 val rewrites = ref []
adamc@794 349 val url = ref []
adamc@794 350 val mime = ref []
adamc@794 351 val libs = ref []
adamc@767 352
adamc@794 353 fun finish sources =
adamc@794 354 let
adamc@794 355 val job = {
adamc@794 356 prefix = Option.getOpt (!prefix, "/"),
adamc@794 357 database = !database,
adamc@794 358 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
adamc@794 359 ext = SOME "exe"}),
adamc@794 360 sql = !sql,
adamc@794 361 debug = !debug,
adamc@794 362 profile = !profile,
adamc@794 363 timeout = Option.getOpt (!timeout, 60),
adamc@794 364 ffi = rev (!ffi),
adamc@794 365 link = rev (!link),
adamc@794 366 headers = rev (!headers),
adamc@794 367 scripts = rev (!scripts),
adamc@794 368 clientToServer = rev (!clientToServer),
adamc@794 369 effectful = rev (!effectful),
adamc@794 370 clientOnly = rev (!clientOnly),
adamc@794 371 serverOnly = rev (!serverOnly),
adamc@794 372 jsFuncs = rev (!jsFuncs),
adamc@794 373 rewrites = rev (!rewrites),
adamc@794 374 filterUrl = rev (!url),
adamc@794 375 filterMime = rev (!mime),
adamc@794 376 sources = sources
adamc@794 377 }
adamc@767 378
adamc@794 379 fun mergeO f (old, new) =
adamc@794 380 case (old, new) of
adamc@794 381 (NONE, _) => new
adamc@794 382 | (_, NONE) => old
adamc@794 383 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adamc@794 384
adamc@794 385 fun same desc = mergeO (fn (x : string, y) =>
adamc@794 386 (if x = y then
adamc@794 387 ()
adamc@794 388 else
adamc@794 389 ErrorMsg.error ("Multiple "
adamc@794 390 ^ desc ^ " values that don't agree");
adamc@794 391 x))
adamc@794 392
adamc@794 393 fun merge (old : job, new : job) = {
adamc@794 394 prefix = #prefix old,
adamc@794 395 database = #database old,
adamc@794 396 exe = #exe old,
adamc@794 397 sql = #sql old,
adamc@794 398 debug = #debug old orelse #debug new,
adamc@794 399 profile = #profile old orelse #profile new,
adamc@794 400 timeout = #timeout old,
adamc@794 401 ffi = #ffi old @ #ffi new,
adamc@794 402 link = #link old @ #link new,
adamc@794 403 headers = #headers old @ #headers new,
adamc@794 404 scripts = #scripts old @ #scripts new,
adamc@794 405 clientToServer = #clientToServer old @ #clientToServer new,
adamc@794 406 effectful = #effectful old @ #effectful new,
adamc@794 407 clientOnly = #clientOnly old @ #clientOnly new,
adamc@794 408 serverOnly = #serverOnly old @ #serverOnly new,
adamc@794 409 jsFuncs = #jsFuncs old @ #jsFuncs new,
adamc@794 410 rewrites = #rewrites old @ #rewrites new,
adamc@794 411 filterUrl = #filterUrl old @ #filterUrl new,
adamc@794 412 filterMime = #filterMime old @ #filterMime new,
adamc@794 413 sources = #sources new @ #sources old
adamc@794 414 }
adamc@794 415 in
adamc@832 416 foldr (fn (fname, job) => merge (job, pu fname)) job (!libs)
adamc@794 417 end
adamc@794 418
adamc@794 419 fun parsePkind s =
adamc@794 420 case s of
adamc@794 421 "all" => Settings.Any
adamc@794 422 | "url" => Settings.Url
adamc@794 423 | "table" => Settings.Table
adamc@794 424 | "sequence" => Settings.Sequence
adamc@794 425 | "view" => Settings.View
adamc@794 426 | "relation" => Settings.Relation
adamc@794 427 | "cookie" => Settings.Cookie
adamc@794 428 | "style" => Settings.Style
adamc@794 429 | _ => (ErrorMsg.error "Bad path kind spec";
adamc@794 430 Settings.Any)
adamc@794 431
adamc@794 432 fun parseFrom s =
adamc@794 433 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
adamc@794 434 (Settings.Prefix, String.substring (s, 0, size s - 1))
adamc@794 435 else
adamc@794 436 (Settings.Exact, s)
adamc@794 437
adamc@794 438 fun parseFkind s =
adamc@794 439 case s of
adamc@794 440 "url" => url
adamc@794 441 | "mime" => mime
adamc@794 442 | _ => (ErrorMsg.error "Bad filter kind";
adamc@794 443 url)
adamc@794 444
adamc@794 445 fun parsePattern s =
adamc@794 446 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
adamc@794 447 (Settings.Prefix, String.substring (s, 0, size s - 1))
adamc@794 448 else
adamc@794 449 (Settings.Exact, s)
adamc@794 450
adamc@794 451 fun read () =
adamc@794 452 case TextIO.inputLine inf of
adamc@794 453 NONE => finish []
adamc@794 454 | SOME "\n" => finish (readSources [])
adamc@794 455 | SOME line =>
adamc@794 456 let
adamc@794 457 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
adamc@794 458 val cmd = Substring.string (trim cmd)
adamc@794 459 val arg = Substring.string (trim arg)
adamc@794 460
adamc@794 461 fun ffiS () =
adamc@794 462 case String.fields (fn ch => ch = #".") arg of
adamc@794 463 [m, x] => (m, x)
adamc@794 464 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
adamc@794 465 ("", ""))
adamc@794 466
adamc@794 467 fun ffiM () =
adamc@794 468 case String.fields (fn ch => ch = #"=") arg of
adamc@794 469 [f, s] =>
adamc@794 470 (case String.fields (fn ch => ch = #".") f of
adamc@794 471 [m, x] => ((m, x), s)
adamc@794 472 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adamc@794 473 (("", ""), "")))
adamc@794 474 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adamc@794 475 (("", ""), ""))
adamc@794 476 in
adamc@794 477 case cmd of
adamc@794 478 "prefix" =>
adamc@794 479 (case !prefix of
adamc@794 480 NONE => ()
adamc@794 481 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
adamc@794 482 prefix := SOME arg)
adamc@794 483 | "database" =>
adamc@794 484 (case !database of
adamc@794 485 NONE => ()
adamc@794 486 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
adamc@794 487 database := SOME arg)
adamc@794 488 | "exe" =>
adamc@794 489 (case !exe of
adamc@794 490 NONE => ()
adamc@794 491 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
adamc@794 492 exe := SOME (relify arg))
adamc@794 493 | "sql" =>
adamc@794 494 (case !sql of
adamc@794 495 NONE => ()
adamc@794 496 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
adamc@794 497 sql := SOME (relify arg))
adamc@794 498 | "debug" => debug := true
adamc@794 499 | "profile" => profile := true
adamc@794 500 | "timeout" =>
adamc@794 501 (case !timeout of
adamc@794 502 NONE => ()
adamc@794 503 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
adamc@794 504 timeout := SOME (valOf (Int.fromString arg)))
adamc@794 505 | "ffi" => ffi := relify arg :: !ffi
adamc@794 506 | "link" => link := relifyA arg :: !link
adamc@794 507 | "include" => headers := relifyA arg :: !headers
adamc@794 508 | "script" => scripts := arg :: !scripts
adamc@794 509 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
adamc@794 510 | "effectful" => effectful := ffiS () :: !effectful
adamc@794 511 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
adamc@794 512 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
adamc@794 513 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
adamc@794 514 | "rewrite" =>
adamc@794 515 let
adamc@794 516 fun doit (pkind, from, to) =
adamc@794 517 let
adamc@794 518 val pkind = parsePkind pkind
adamc@794 519 val (kind, from) = parseFrom from
adamc@794 520 in
adamc@794 521 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
adamc@794 522 end
adamc@794 523 in
adamc@794 524 case String.tokens Char.isSpace arg of
adamc@794 525 [pkind, from, to] => doit (pkind, from, to)
adamc@794 526 | [pkind, from] => doit (pkind, from, "")
adamc@794 527 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
adamc@794 528 end
adamc@794 529 | "allow" =>
adamc@794 530 (case String.tokens Char.isSpace arg of
adamc@794 531 [fkind, pattern] =>
adamc@794 532 let
adamc@794 533 val fkind = parseFkind fkind
adamc@794 534 val (kind, pattern) = parsePattern pattern
adamc@794 535 in
adamc@794 536 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
adamc@794 537 end
adamc@794 538 | _ => ErrorMsg.error "Bad 'allow' syntax")
adamc@794 539 | "deny" =>
adamc@794 540 (case String.tokens Char.isSpace arg of
adamc@794 541 [fkind, pattern] =>
adamc@794 542 let
adamc@794 543 val fkind = parseFkind fkind
adamc@794 544 val (kind, pattern) = parsePattern pattern
adamc@794 545 in
adamc@794 546 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
adamc@794 547 end
adamc@794 548 | _ => ErrorMsg.error "Bad 'deny' syntax")
adamc@794 549 | "library" => libs := relify arg :: !libs
adamc@794 550 | "path" =>
adamc@794 551 (case String.fields (fn ch => ch = #"=") arg of
adamc@794 552 [n, v] => pathmap := M.insert (!pathmap, n, v)
adamc@794 553 | _ => ErrorMsg.error "path argument not of the form name=value'")
adamc@794 554 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
adamc@794 555 read ()
adamc@794 556 end
adamc@794 557
adamc@794 558 val job = read ()
adamc@767 559 in
adamc@794 560 TextIO.closeIn inf;
adamc@794 561 Settings.setUrlPrefix (#prefix job);
adamc@794 562 Settings.setTimeout (#timeout job);
adamc@794 563 Settings.setHeaders (#headers job);
adamc@794 564 Settings.setScripts (#scripts job);
adamc@794 565 Settings.setClientToServer (#clientToServer job);
adamc@794 566 Settings.setEffectful (#effectful job);
adamc@794 567 Settings.setClientOnly (#clientOnly job);
adamc@794 568 Settings.setServerOnly (#serverOnly job);
adamc@794 569 Settings.setJsFuncs (#jsFuncs job);
adamc@794 570 Settings.setRewriteRules (#rewrites job);
adamc@794 571 Settings.setUrlRules (#filterUrl job);
adamc@794 572 Settings.setMimeRules (#filterMime job);
adamc@794 573 job
adamc@767 574 end
adamc@767 575 in
adamc@794 576 pu fname
adamc@767 577 end
adamc@767 578
adamc@270 579 val parseUrp = {
adamc@767 580 func = parseUrp',
adamc@270 581 print = p_job
adamc@270 582 }
adamc@270 583
adamc@270 584 val toParseJob = transform parseUrp "parseJob"
adamc@270 585
adamc@56 586 fun capitalize "" = ""
adamc@56 587 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@56 588
adamc@201 589 val parse = {
adamc@764 590 func = fn {database, sources = fnames, ffi, ...} : job =>
adamc@201 591 let
adamc@834 592 val anyErrors = ref false
adamc@834 593 fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
adamc@201 594 fun nameOf fname = capitalize (OS.Path.file fname)
adamc@109 595
adamc@764 596 fun parseFfi fname =
adamc@764 597 let
adamc@764 598 val mname = nameOf fname
adamc@764 599 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@764 600
adamc@764 601 val loc = {file = urs,
adamc@764 602 first = ErrorMsg.dummyPos,
adamc@764 603 last = ErrorMsg.dummyPos}
adamc@764 604
adamc@764 605 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
adamc@764 606 in
adamc@834 607 checkErrors ();
adamc@764 608 (Source.DFfiStr (mname, sgn), loc)
adamc@764 609 end
adamc@764 610
adamc@201 611 fun parseOne fname =
adamc@201 612 let
adamc@201 613 val mname = nameOf fname
adamc@244 614 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
adamc@244 615 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@56 616
adamc@201 617 val sgnO =
adamc@244 618 if Posix.FileSys.access (urs, []) then
adamc@244 619 SOME (Source.SgnConst (#func parseUrs urs),
adamc@244 620 {file = urs,
adamc@201 621 first = ErrorMsg.dummyPos,
adamc@201 622 last = ErrorMsg.dummyPos})
adamc@834 623 before checkErrors ()
adamc@201 624 else
adamc@201 625 NONE
adamc@56 626
adamc@244 627 val loc = {file = ur,
adamc@201 628 first = ErrorMsg.dummyPos,
adamc@201 629 last = ErrorMsg.dummyPos}
adamc@56 630
adamc@244 631 val ds = #func parseUr ur
adamc@201 632 in
adamc@834 633 checkErrors ();
adamc@201 634 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
adamc@201 635 end
adamc@56 636
adamc@764 637 val dsFfi = map parseFfi ffi
adamc@201 638 val ds = map parseOne fnames
adamc@201 639 in
adamc@834 640 if !anyErrors then
adamc@834 641 ErrorMsg.error "Parse failure"
adamc@834 642 else
adamc@834 643 ();
adamc@834 644
adamc@201 645 let
adamc@201 646 val final = nameOf (List.last fnames)
adamc@271 647
adamc@764 648 val ds = dsFfi @ ds
adamc@764 649 @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
adamc@201 650 in
adamc@271 651 case database of
adamc@271 652 NONE => ds
adamc@271 653 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
adamc@201 654 end handle Empty => ds
adamc@201 655 end,
adamc@201 656 print = SourcePrint.p_file
adamc@201 657 }
adamc@56 658
adamc@270 659 val toParse = transform parse "parse" o toParseJob
adamc@38 660
adamc@378 661 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
adamc@378 662 file = s}
adamc@378 663 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@378 664 file = s}
adamc@378 665
adamc@201 666 val elaborate = {
adamc@201 667 func = fn file => let
adamc@378 668 val basis = #func parseUrs (libFile "basis.urs")
adamc@378 669 val topSgn = #func parseUrs (libFile "top.urs")
adamc@378 670 val topStr = #func parseUr (libFile "top.ur")
adamc@201 671 in
adamc@325 672 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
adamc@201 673 end,
adamc@201 674 print = ElabPrint.p_file ElabEnv.empty
adamc@201 675 }
adamc@5 676
adamc@270 677 val toElaborate = transform elaborate "elaborate" o toParse
adamc@201 678
adamc@448 679 val unnest = {
adamc@448 680 func = Unnest.unnest,
adamc@448 681 print = ElabPrint.p_file ElabEnv.empty
adamc@448 682 }
adamc@448 683
adamc@448 684 val toUnnest = transform unnest "unnest" o toElaborate
adamc@448 685
adamc@313 686 val termination = {
adamc@313 687 func = (fn file => (Termination.check file; file)),
adamc@313 688 print = ElabPrint.p_file ElabEnv.empty
adamc@313 689 }
adamc@313 690
adamc@448 691 val toTermination = transform termination "termination" o toUnnest
adamc@313 692
adamc@201 693 val explify = {
adamc@201 694 func = Explify.explify,
adamc@201 695 print = ExplPrint.p_file ExplEnv.empty
adamc@201 696 }
adamc@201 697
adamc@625 698 val toExplify = transform explify "explify" o toUnnest
adamc@201 699
adamc@201 700 val corify = {
adamc@201 701 func = Corify.corify,
adamc@201 702 print = CorePrint.p_file CoreEnv.empty
adamc@201 703 }
adamc@201 704
adamc@270 705 val toCorify = transform corify "corify" o toExplify
adamc@201 706
adamc@482 707 (*val reduce_local = {
adamc@482 708 func = ReduceLocal.reduce,
adamc@482 709 print = CorePrint.p_file CoreEnv.empty
adamc@482 710 }
adamc@482 711
adamc@482 712 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
adamc@482 713
adamc@443 714 val especialize = {
adamc@443 715 func = ESpecialize.specialize,
adamc@443 716 print = CorePrint.p_file CoreEnv.empty
adamc@443 717 }
adamc@443 718
adamc@454 719 val core_untangle = {
adamc@454 720 func = CoreUntangle.untangle,
adamc@454 721 print = CorePrint.p_file CoreEnv.empty
adamc@454 722 }
adamc@454 723
adamc@794 724 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
adamc@454 725
adamc@202 726 val shake = {
adamc@202 727 func = Shake.shake,
adamc@202 728 print = CorePrint.p_file CoreEnv.empty
adamc@202 729 }
adamc@39 730
adamc@454 731 val toShake1 = transform shake "shake1" o toCore_untangle
adamc@110 732
adamc@607 733 val rpcify = {
adamc@607 734 func = Rpcify.frob,
adamc@607 735 print = CorePrint.p_file CoreEnv.empty
adamc@607 736 }
adamc@607 737
adamc@607 738 val toRpcify = transform rpcify "rpcify" o toShake1
adamc@607 739
adamc@642 740 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
adamc@642 741 val toShake2 = transform shake "shake2" o toCore_untangle2
adamc@642 742
adamc@202 743 val tag = {
adamc@202 744 func = Tag.tag,
adamc@202 745 print = CorePrint.p_file CoreEnv.empty
adamc@202 746 }
adamc@193 747
adamc@642 748 val toTag = transform tag "tag" o toCore_untangle2
adamc@20 749
adamc@202 750 val reduce = {
adamc@202 751 func = Reduce.reduce,
adamc@202 752 print = CorePrint.p_file CoreEnv.empty
adamc@202 753 }
adamc@25 754
adamc@692 755 val toReduce = transform reduce "reduce" o toTag
adamc@23 756
adamc@315 757 val unpoly = {
adamc@315 758 func = Unpoly.unpoly,
adamc@315 759 print = CorePrint.p_file CoreEnv.empty
adamc@315 760 }
adamc@315 761
adamc@315 762 val toUnpoly = transform unpoly "unpoly" o toReduce
adamc@315 763
adamc@202 764 val specialize = {
adamc@202 765 func = Specialize.specialize,
adamc@202 766 print = CorePrint.p_file CoreEnv.empty
adamc@202 767 }
adamc@132 768
adamc@315 769 val toSpecialize = transform specialize "specialize" o toUnpoly
adamc@131 770
adamc@642 771 val toShake3 = transform shake "shake3" o toSpecialize
adamc@133 772
adamc@794 773 val toEspecialize = transform especialize "especialize" o toShake3
adamc@794 774
adamc@794 775 val toShake4 = transform shake "shake4" o toEspecialize
adamc@794 776
adamc@692 777 val marshalcheck = {
adamc@692 778 func = (fn file => (MarshalCheck.check file; file)),
adamc@692 779 print = CorePrint.p_file CoreEnv.empty
adamc@692 780 }
adamc@692 781
adamc@794 782 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake4
adamc@692 783
adamc@732 784 val effectize = {
adamc@732 785 func = Effective.effectize,
adamc@732 786 print = CorePrint.p_file CoreEnv.empty
adamc@732 787 }
adamc@732 788
adamc@732 789 val toEffectize = transform effectize "effectize" o toMarshalcheck
adamc@732 790
adamc@202 791 val monoize = {
adamc@202 792 func = Monoize.monoize CoreEnv.empty,
adamc@202 793 print = MonoPrint.p_file MonoEnv.empty
adamc@202 794 }
adamc@134 795
adamc@732 796 val toMonoize = transform monoize "monoize" o toEffectize
adamc@96 797
adamc@202 798 val mono_opt = {
adamc@202 799 func = MonoOpt.optimize,
adamc@202 800 print = MonoPrint.p_file MonoEnv.empty
adamc@202 801 }
adamc@29 802
adamc@270 803 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
adamc@5 804
adamc@202 805 val untangle = {
adamc@202 806 func = Untangle.untangle,
adamc@202 807 print = MonoPrint.p_file MonoEnv.empty
adamc@202 808 }
adamc@1 809
adamc@270 810 val toUntangle = transform untangle "untangle" o toMono_opt1
adamc@38 811
adamc@202 812 val mono_reduce = {
adamc@202 813 func = MonoReduce.reduce,
adamc@202 814 print = MonoPrint.p_file MonoEnv.empty
adamc@202 815 }
adamc@16 816
adamc@270 817 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
adamc@39 818
adamc@202 819 val mono_shake = {
adamc@202 820 func = MonoShake.shake,
adamc@202 821 print = MonoPrint.p_file MonoEnv.empty
adamc@202 822 }
adamc@110 823
adamc@270 824 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
adamc@193 825
adamc@572 826 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
adamc@572 827
adamc@567 828 val jscomp = {
adamc@567 829 func = JsComp.process,
adamc@567 830 print = MonoPrint.p_file MonoEnv.empty
adamc@567 831 }
adamc@567 832
adamc@572 833 val toJscomp = transform jscomp "jscomp" o toMono_opt2
adamc@567 834
adamc@572 835 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
adamc@20 836
adamc@506 837 val fuse = {
adamc@506 838 func = Fuse.fuse,
adamc@506 839 print = MonoPrint.p_file MonoEnv.empty
adamc@506 840 }
adamc@506 841
adamc@572 842 val toFuse = transform fuse "fuse" o toMono_opt3
adamc@506 843
adamc@506 844 val toUntangle2 = transform untangle "untangle2" o toFuse
adamc@506 845
adamc@601 846 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
adamc@601 847 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
adamc@506 848
adamc@377 849 val pathcheck = {
adamc@377 850 func = (fn file => (PathCheck.check file; file)),
adamc@377 851 print = MonoPrint.p_file MonoEnv.empty
adamc@377 852 }
adamc@377 853
adamc@506 854 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2
adamc@377 855
adamc@202 856 val cjrize = {
adamc@202 857 func = Cjrize.cjrize,
adamc@202 858 print = CjrPrint.p_file CjrEnv.empty
adamc@202 859 }
adamc@23 860
adamc@377 861 val toCjrize = transform cjrize "cjrize" o toPathcheck
adamc@29 862
adamc@643 863 val scriptcheck = {
adamc@643 864 func = ScriptCheck.classify,
adamc@643 865 print = CjrPrint.p_file CjrEnv.empty
adamc@643 866 }
adamc@643 867
adamc@643 868 val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
adamc@643 869
adamc@282 870 val prepare = {
adamc@282 871 func = Prepare.prepare,
adamc@282 872 print = CjrPrint.p_file CjrEnv.empty
adamc@282 873 }
adamc@282 874
adamc@643 875 val toPrepare = transform prepare "prepare" o toScriptcheck
adamc@282 876
adamc@274 877 val sqlify = {
adamc@274 878 func = Cjrize.cjrize,
adamc@274 879 print = CjrPrint.p_sql CjrEnv.empty
adamc@274 880 }
adamc@274 881
adamc@274 882 val toSqlify = transform sqlify "sqlify" o toMono_opt2
adamc@274 883
adamc@764 884 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
adamc@183 885 let
adamc@378 886 val urweb_o = clibFile "urweb.o"
adamc@853 887 val request_o = clibFile "request.o"
adamc@378 888 val driver_o = clibFile "driver.o"
adamc@378 889
adamc@832 890 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I " ^ Config.includ
adamc@832 891 ^ " -c " ^ cname ^ " -o " ^ oname
adamc@853 892 val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname
adamc@853 893 ^ " " ^ request_o ^ " " ^ driver_o ^ " -o " ^ ename
adamc@502 894
adamc@502 895 val (compile, link) =
adamc@502 896 if profile then
adamc@502 897 (compile ^ " -pg", link ^ " -pg")
adamc@502 898 else
adamc@502 899 (compile, link)
adamc@742 900
adamc@742 901 val (compile, link) =
adamc@742 902 if debug then
adamc@742 903 (compile ^ " -g", link ^ " -g")
adamc@742 904 else
adamc@742 905 (compile, link)
adamc@764 906
adamc@764 907 val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
adamc@183 908 in
adamc@183 909 if not (OS.Process.isSuccess (OS.Process.system compile)) then
adamc@183 910 print "C compilation failed\n"
adamc@183 911 else if not (OS.Process.isSuccess (OS.Process.system link)) then
adamc@186 912 print "C linking failed\n"
adamc@183 913 else
adamc@673 914 ()
adamc@183 915 end
adamc@183 916
adamc@202 917 fun compile job =
adamc@282 918 case run toPrepare job of
adamc@244 919 NONE => print "Ur compilation failed\n"
adamc@29 920 | SOME file =>
adamc@202 921 let
adamc@274 922 val job = valOf (run (transform parseUrp "parseUrp") job)
adamc@102 923
adamc@274 924 val (cname, oname, cleanup) =
adamc@274 925 if #debug job then
adamc@457 926 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
adamc@274 927 else
adamc@274 928 let
adamc@274 929 val dir = OS.FileSys.tmpName ()
adamc@403 930 val () = if OS.FileSys.access (dir, []) then
adamc@403 931 OS.FileSys.remove dir
adamc@403 932 else
adamc@403 933 ()
adamc@457 934 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
adamc@457 935 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
adamc@274 936 in
adamc@274 937 OS.FileSys.mkDir dir;
adamc@274 938 (cname, oname,
adamc@274 939 fn () => (OS.FileSys.remove cname;
adamc@274 940 OS.FileSys.remove oname;
adamc@473 941 OS.FileSys.rmDir dir)
adamc@473 942 handle OS.SysErr _ => OS.FileSys.rmDir dir)
adamc@274 943 end
adamc@274 944 val ename = #exe job
adamc@202 945 in
adamc@274 946 let
adamc@274 947 val outf = TextIO.openOut cname
adamc@274 948 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@432 949
adamc@432 950 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
adamc@432 951 val libs =
adamc@432 952 if hasDb then
adamc@432 953 "-lpq"
adamc@432 954 else
adamc@432 955 ""
adamc@274 956 in
adamc@274 957 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
adamc@415 958 TextIO.output1 (outf, #"\n");
adamc@274 959 TextIO.closeOut outf;
adamc@102 960
adamc@274 961 case #sql job of
adamc@274 962 NONE => ()
adamc@274 963 | SOME sql =>
adamc@274 964 let
adamc@274 965 val outf = TextIO.openOut sql
adamc@274 966 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@274 967 in
adamc@274 968 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
adamc@274 969 TextIO.closeOut outf
adamc@274 970 end;
adamc@274 971
adamc@742 972 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
adamc@764 973 profile = #profile job, debug = #debug job, link = #link job};
adamc@274 974
adamc@274 975 cleanup ()
adamc@274 976 end
adamc@274 977 handle ex => (((cleanup ()) handle _ => ()); raise ex)
adamc@202 978 end
adamc@29 979
adamc@1 980 end