Mercurial > urweb

annotate src/compiler.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 d27ed5ddeb52
children efceae06df17
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@768 54 rewrites : Settings.rewrite list
adamc@270 55 }
adamc@201 56
adamc@201 57 type ('src, 'dst) phase = {
adamc@201 58 func : 'src -> 'dst,
adamc@201 59 print : 'dst -> Print.PD.pp_desc
adamc@201 60 }
adamc@201 61
adamc@201 62 type pmap = (string * Time.time) list
adamc@201 63
adamc@201 64 type ('src, 'dst) transform = {
adamc@201 65 func : 'src -> 'dst option,
adamc@201 66 print : 'dst -> Print.PD.pp_desc,
adamc@201 67 time : 'src * pmap -> 'dst option * pmap
adamc@201 68 }
adamc@201 69
adamc@201 70 fun transform (ph : ('src, 'dst) phase) name = {
adamc@201 71 func = fn input => let
adamc@201 72 val v = #func ph input
adamc@201 73 in
adamc@201 74 if ErrorMsg.anyErrors () then
adamc@201 75 NONE
adamc@201 76 else
adamc@201 77 SOME v
adamc@201 78 end,
adamc@201 79 print = #print ph,
adamc@201 80 time = fn (input, pmap) => let
adamc@201 81 val befor = Time.now ()
adamc@201 82 val v = #func ph input
adamc@201 83 val elapsed = Time.- (Time.now (), befor)
adamc@201 84 in
adamc@201 85 (if ErrorMsg.anyErrors () then
adamc@201 86 NONE
adamc@201 87 else
adamc@201 88 SOME v,
adamc@201 89 (name, elapsed) :: pmap)
adamc@201 90 end
adamc@201 91 }
adamc@201 92
adamc@270 93 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
adamc@201 94 func = fn input => case #func tr1 input of
adamc@201 95 NONE => NONE
adamc@201 96 | SOME v => #func tr2 v,
adamc@201 97 print = #print tr2,
adamc@201 98 time = fn (input, pmap) => let
adamc@201 99 val (ro, pmap) = #time tr1 (input, pmap)
adamc@201 100 in
adamc@201 101 case ro of
adamc@201 102 NONE => (NONE, pmap)
adamc@201 103 | SOME v => #time tr2 (v, pmap)
adamc@201 104 end
adamc@201 105 }
adamc@201 106
adamc@346 107 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@346 108 ignore (#func tr x))
adamc@346 109
adamc@280 110 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@280 111 #func tr x)
adamc@201 112
adamc@201 113 fun runPrint (tr : ('src, 'dst) transform) input =
adamc@280 114 (ErrorMsg.resetErrors ();
adamc@280 115 case #func tr input of
adamc@280 116 NONE => print "Failure\n"
adamc@280 117 | SOME v =>
adamc@280 118 (print "Success\n";
adamc@280 119 Print.print (#print tr v);
adamc@280 120 print "\n"))
adamc@201 121
adamc@201 122 fun time (tr : ('src, 'dst) transform) input =
adamc@55 123 let
adamc@201 124 val (_, pmap) = #time tr (input, [])
adamc@201 125 in
adamc@201 126 app (fn (name, time) =>
adamc@201 127 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 128 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 129 print "\n"
adamc@201 130 end
adamc@55 131
adamc@201 132 fun timePrint (tr : ('src, 'dst) transform) input =
adamc@201 133 let
adamc@201 134 val (ro, pmap) = #time tr (input, [])
adamc@55 135 in
adamc@201 136 app (fn (name, time) =>
adamc@201 137 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 138 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 139 print "\n";
adamc@201 140 case ro of
adamc@201 141 NONE => print "Failure\n"
adamc@201 142 | SOME v =>
adamc@201 143 (print "Success\n";
adamc@201 144 Print.print (#print tr v);
adamc@201 145 print "\n")
adamc@55 146 end
adamc@55 147
adamc@244 148 val parseUrs =
adamc@201 149 {func = fn filename => let
adamc@201 150 val fname = OS.FileSys.tmpName ()
adamc@201 151 val outf = TextIO.openOut fname
adamc@201 152 val () = TextIO.output (outf, "sig\n")
adamc@201 153 val inf = TextIO.openIn filename
adamc@201 154 fun loop () =
adamc@201 155 case TextIO.inputLine inf of
adamc@201 156 NONE => ()
adamc@201 157 | SOME line => (TextIO.output (outf, line);
adamc@201 158 loop ())
adamc@201 159 val () = loop ()
adamc@201 160 val () = TextIO.closeIn inf
adamc@201 161 val () = TextIO.closeOut outf
adamc@201 162
adamc@201 163 val () = (ErrorMsg.resetErrors ();
adamc@201 164 ErrorMsg.resetPositioning filename;
adamc@201 165 Lex.UserDeclarations.initialize ())
adamc@201 166 val file = TextIO.openIn fname
adamc@201 167 fun get _ = TextIO.input file
adamc@201 168 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 169 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 170 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 171 in
adamc@201 172 TextIO.closeIn file;
adamc@201 173 case absyn of
adamc@201 174 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
adamc@201 175 | _ => (ErrorMsg.errorAt {file = filename,
adamc@201 176 first = {line = 0,
adamc@201 177 char = 0},
adamc@201 178 last = {line = 0,
adamc@201 179 char = 0}} "Not a signature";
adamc@201 180 [])
adamc@201 181 end
adamc@201 182 handle LrParser.ParseError => [],
adamc@201 183 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
adamc@55 184
adamc@1 185 (* The main parsing routine *)
adamc@244 186 val parseUr = {
adamc@201 187 func = fn filename =>
adamc@201 188 let
adamc@201 189 val () = (ErrorMsg.resetErrors ();
adamc@201 190 ErrorMsg.resetPositioning filename;
adamc@201 191 Lex.UserDeclarations.initialize ())
adamc@201 192 val file = TextIO.openIn filename
adamc@201 193 fun get _ = TextIO.input file
adamc@201 194 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 195 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 196 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 197 in
adamc@201 198 TextIO.closeIn file;
adamc@201 199 case absyn of
adamc@201 200 [(Source.DSgn ("?", _), _)] =>
adamc@201 201 (ErrorMsg.errorAt {file = filename,
adamc@201 202 first = {line = 0,
adamc@201 203 char = 0},
adamc@201 204 last = {line = 0,
adamc@201 205 char = 0}} "File starts with 'sig'";
adamc@201 206 [])
adamc@201 207 | _ => absyn
adamc@201 208 end
adamc@201 209 handle LrParser.ParseError => [],
adamc@201 210 print = SourcePrint.p_file}
adamc@56 211
adamc@768 212 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
adamc@768 213 timeout, ffi, link, headers, scripts,
adamc@768 214 clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
adamc@270 215 let
adamc@270 216 open Print.PD
adamc@270 217 open Print
adamc@765 218
adamc@765 219 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
adamc@765 220 box [string name, space, string m, string ".", string s, newline])
adamc@270 221 in
adamc@274 222 box [if debug then
adamc@274 223 box [string "DEBUG", newline]
adamc@274 224 else
adamc@274 225 box [],
adamc@502 226 if profile then
adamc@502 227 box [string "PROFILE", newline]
adamc@502 228 else
adamc@502 229 box [],
adamc@274 230 case database of
adamc@270 231 NONE => string "No database."
adamc@270 232 | SOME db => string ("Database: " ^ db),
adamc@270 233 newline,
adamc@274 234 string "Exe: ",
adamc@274 235 string exe,
adamc@274 236 newline,
adamc@274 237 case sql of
adamc@274 238 NONE => string "No SQL file."
adamc@274 239 | SOME sql => string ("SQL fle: " ^ sql),
adamc@673 240 newline,
adamc@673 241 string "Timeout: ",
adamc@673 242 string (Int.toString timeout),
adamc@673 243 newline,
adamc@764 244 p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
adamc@764 245 p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
adamc@766 246 p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
adamc@764 247 p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
adamc@765 248 p_ffi "ClientToServer" clientToServer,
adamc@765 249 p_ffi "Effectful" effectful,
adamc@765 250 p_ffi "ClientOnly" clientOnly,
adamc@765 251 p_ffi "ServerOnly" serverOnly,
adamc@765 252 p_list_sep (box []) (fn ((m, s), s') =>
adamc@765 253 box [string "JsFunc", space, string m, string ".", string s,
adamc@765 254 space, string "=", space, string s', newline]) jsFuncs,
adamc@270 255 string "Sources:",
adamc@270 256 p_list string sources,
adamc@270 257 newline]
adamc@270 258 end
adamc@270 259
adamc@270 260 fun trim s =
adamc@270 261 let
adamc@270 262 val (_, s) = Substring.splitl Char.isSpace s
adamc@270 263 val (s, _) = Substring.splitr Char.isSpace s
adamc@270 264 in
adamc@270 265 s
adamc@270 266 end
adamc@270 267
adamc@767 268 fun parseUrp' filename =
adamc@767 269 let
adamc@767 270 val dir = OS.Path.dir filename
adamc@767 271 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
adamc@767 272
adamc@767 273 fun relify fname =
adamc@767 274 OS.Path.concat (dir, fname)
adamc@767 275 handle OS.Path.Path => fname
adamc@767 276
adamc@767 277 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
adamc@767 278
adamc@767 279 fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
adamc@767 280
adamc@767 281 fun readSources acc =
adamc@767 282 case TextIO.inputLine inf of
adamc@767 283 NONE => rev acc
adamc@767 284 | SOME line =>
adamc@767 285 let
adamc@767 286 val acc = if CharVector.all Char.isSpace line then
adamc@767 287 acc
adamc@767 288 else
adamc@767 289 let
adamc@767 290 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
adamc@767 291 (String.explode line))
adamc@767 292 val fname = relify fname
adamc@767 293 in
adamc@767 294 fname :: acc
adamc@767 295 end
adamc@767 296 in
adamc@767 297 readSources acc
adamc@767 298 end
adamc@767 299
adamc@767 300 val prefix = ref NONE
adamc@767 301 val database = ref NONE
adamc@767 302 val exe = ref NONE
adamc@767 303 val sql = ref NONE
adamc@767 304 val debug = ref false
adamc@767 305 val profile = ref false
adamc@767 306 val timeout = ref NONE
adamc@767 307 val ffi = ref []
adamc@767 308 val link = ref []
adamc@767 309 val headers = ref []
adamc@767 310 val scripts = ref []
adamc@767 311 val clientToServer = ref []
adamc@767 312 val effectful = ref []
adamc@767 313 val clientOnly = ref []
adamc@767 314 val serverOnly = ref []
adamc@767 315 val jsFuncs = ref []
adamc@768 316 val rewrites = ref []
adamc@767 317 val libs = ref []
adamc@767 318
adamc@767 319 fun finish sources =
adamc@767 320 let
adamc@767 321 val job = {
adamc@767 322 prefix = Option.getOpt (!prefix, "/"),
adamc@767 323 database = !database,
adamc@767 324 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
adamc@767 325 ext = SOME "exe"}),
adamc@767 326 sql = !sql,
adamc@767 327 debug = !debug,
adamc@767 328 profile = !profile,
adamc@767 329 timeout = Option.getOpt (!timeout, 60),
adamc@767 330 ffi = rev (!ffi),
adamc@767 331 link = rev (!link),
adamc@767 332 headers = rev (!headers),
adamc@767 333 scripts = rev (!scripts),
adamc@767 334 clientToServer = rev (!clientToServer),
adamc@767 335 effectful = rev (!effectful),
adamc@767 336 clientOnly = rev (!clientOnly),
adamc@767 337 serverOnly = rev (!serverOnly),
adamc@767 338 jsFuncs = rev (!jsFuncs),
adamc@768 339 rewrites = rev (!rewrites),
adamc@767 340 sources = sources
adamc@767 341 }
adamc@767 342
adamc@767 343 fun mergeO f (old, new) =
adamc@767 344 case (old, new) of
adamc@767 345 (NONE, _) => new
adamc@767 346 | (_, NONE) => old
adamc@767 347 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adamc@767 348
adamc@767 349 fun same desc = mergeO (fn (x : string, y) =>
adamc@767 350 (if x = y then
adamc@767 351 ()
adamc@767 352 else
adamc@767 353 ErrorMsg.error ("Multiple "
adamc@767 354 ^ desc ^ " values that don't agree");
adamc@767 355 x))
adamc@767 356
adamc@767 357 fun merge (old : job, new : job) = {
adamc@767 358 prefix = #prefix old,
adamc@767 359 database = #database old,
adamc@767 360 exe = #exe old,
adamc@767 361 sql = #sql old,
adamc@767 362 debug = #debug old orelse #debug new,
adamc@767 363 profile = #profile old orelse #profile new,
adamc@767 364 timeout = #timeout old,
adamc@767 365 ffi = #ffi old @ #ffi new,
adamc@767 366 link = #link old @ #link new,
adamc@767 367 headers = #headers old @ #headers new,
adamc@767 368 scripts = #scripts old @ #scripts new,
adamc@767 369 clientToServer = #clientToServer old @ #clientToServer new,
adamc@767 370 effectful = #effectful old @ #effectful new,
adamc@767 371 clientOnly = #clientOnly old @ #clientOnly new,
adamc@767 372 serverOnly = #serverOnly old @ #serverOnly new,
adamc@767 373 jsFuncs = #jsFuncs old @ #jsFuncs new,
adamc@768 374 rewrites = #rewrites old @ #rewrites new,
adamc@767 375 sources = #sources old @ #sources new
adamc@767 376 }
adamc@767 377 in
adamc@767 378 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
adamc@767 379 end
adamc@767 380
adamc@768 381 fun parsePkind s =
adamc@768 382 case s of
adamc@768 383 "all" => Settings.Any
adamc@768 384 | "url" => Settings.Url
adamc@768 385 | "table" => Settings.Table
adamc@768 386 | "sequence" => Settings.Sequence
adamc@768 387 | "view" => Settings.View
adamc@768 388 | "relation" => Settings.Relation
adamc@768 389 | "cookie" => Settings.Cookie
adamc@768 390 | "style" => Settings.Style
adamc@768 391 | _ => (ErrorMsg.error "Bad path kind spec";
adamc@768 392 Settings.Any)
adamc@768 393
adamc@768 394 fun parseFrom s =
adamc@768 395 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
adamc@768 396 (Settings.Prefix, String.substring (s, 0, size s - 1))
adamc@768 397 else
adamc@768 398 (Settings.Exact, s)
adamc@768 399
adamc@767 400 fun read () =
adamc@767 401 case TextIO.inputLine inf of
adamc@767 402 NONE => finish []
adamc@767 403 | SOME "\n" => finish (readSources [])
adamc@767 404 | SOME line =>
adamc@767 405 let
adamc@767 406 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
adamc@767 407 val cmd = Substring.string (trim cmd)
adamc@767 408 val arg = Substring.string (trim arg)
adamc@767 409
adamc@767 410 fun ffiS () =
adamc@767 411 case String.fields (fn ch => ch = #".") arg of
adamc@767 412 [m, x] => (m, x)
adamc@767 413 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
adamc@767 414 ("", ""))
adamc@767 415
adamc@767 416 fun ffiM () =
adamc@767 417 case String.fields (fn ch => ch = #"=") arg of
adamc@767 418 [f, s] =>
adamc@767 419 (case String.fields (fn ch => ch = #".") f of
adamc@767 420 [m, x] => ((m, x), s)
adamc@767 421 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adamc@767 422 (("", ""), "")))
adamc@767 423 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adamc@767 424 (("", ""), ""))
adamc@767 425 in
adamc@767 426 case cmd of
adamc@767 427 "prefix" =>
adamc@767 428 (case !prefix of
adamc@767 429 NONE => ()
adamc@767 430 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
adamc@767 431 prefix := SOME arg)
adamc@767 432 | "database" =>
adamc@767 433 (case !database of
adamc@767 434 NONE => ()
adamc@767 435 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
adamc@767 436 database := SOME arg)
adamc@767 437 | "exe" =>
adamc@767 438 (case !exe of
adamc@767 439 NONE => ()
adamc@767 440 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
adamc@767 441 exe := SOME (relify arg))
adamc@767 442 | "sql" =>
adamc@767 443 (case !sql of
adamc@767 444 NONE => ()
adamc@767 445 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
adamc@767 446 sql := SOME (relify arg))
adamc@767 447 | "debug" => debug := true
adamc@767 448 | "profile" => profile := true
adamc@767 449 | "timeout" =>
adamc@767 450 (case !timeout of
adamc@767 451 NONE => ()
adamc@767 452 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
adamc@767 453 timeout := SOME (valOf (Int.fromString arg)))
adamc@767 454 | "ffi" => ffi := relify arg :: !ffi
adamc@767 455 | "link" => link := relifyA arg :: !link
adamc@767 456 | "include" => headers := relifyA arg :: !headers
adamc@767 457 | "script" => scripts := arg :: !scripts
adamc@767 458 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
adamc@767 459 | "effectful" => effectful := ffiS () :: !effectful
adamc@767 460 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
adamc@767 461 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
adamc@767 462 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
adamc@768 463 | "rewrite" =>
adamc@768 464 let
adamc@768 465 fun doit (pkind, from, to) =
adamc@768 466 let
adamc@768 467 val pkind = parsePkind pkind
adamc@768 468 val (kind, from) = parseFrom from
adamc@768 469 in
adamc@768 470 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
adamc@768 471 end
adamc@768 472 in
adamc@768 473 case String.tokens Char.isSpace arg of
adamc@768 474 [pkind, from, to] => doit (pkind, from, to)
adamc@768 475 | [pkind, from] => doit (pkind, from, "")
adamc@768 476 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
adamc@768 477 end
adamc@767 478 | "library" => libs := relify arg :: !libs
adamc@767 479 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
adamc@767 480 read ()
adamc@767 481 end
adamc@767 482
adamc@767 483 val job = read ()
adamc@767 484 in
adamc@767 485 TextIO.closeIn inf;
adamc@767 486 Settings.setUrlPrefix (#prefix job);
adamc@767 487 Settings.setTimeout (#timeout job);
adamc@767 488 Settings.setHeaders (#headers job);
adamc@767 489 Settings.setScripts (#scripts job);
adamc@767 490 Settings.setClientToServer (#clientToServer job);
adamc@767 491 Settings.setEffectful (#effectful job);
adamc@767 492 Settings.setClientOnly (#clientOnly job);
adamc@767 493 Settings.setServerOnly (#serverOnly job);
adamc@767 494 Settings.setJsFuncs (#jsFuncs job);
adamc@768 495 Settings.setRewriteRules (#rewrites job);
adamc@767 496 job
adamc@767 497 end
adamc@767 498
adamc@270 499 val parseUrp = {
adamc@767 500 func = parseUrp',
adamc@270 501 print = p_job
adamc@270 502 }
adamc@270 503
adamc@270 504 val toParseJob = transform parseUrp "parseJob"
adamc@270 505
adamc@56 506 fun capitalize "" = ""
adamc@56 507 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@56 508
adamc@201 509 val parse = {
adamc@764 510 func = fn {database, sources = fnames, ffi, ...} : job =>
adamc@201 511 let
adamc@201 512 fun nameOf fname = capitalize (OS.Path.file fname)
adamc@109 513
adamc@764 514 fun parseFfi fname =
adamc@764 515 let
adamc@764 516 val mname = nameOf fname
adamc@764 517 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@764 518
adamc@764 519 val loc = {file = urs,
adamc@764 520 first = ErrorMsg.dummyPos,
adamc@764 521 last = ErrorMsg.dummyPos}
adamc@764 522
adamc@764 523 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
adamc@764 524 in
adamc@764 525 (Source.DFfiStr (mname, sgn), loc)
adamc@764 526 end
adamc@764 527
adamc@201 528 fun parseOne fname =
adamc@201 529 let
adamc@201 530 val mname = nameOf fname
adamc@244 531 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
adamc@244 532 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@56 533
adamc@201 534 val sgnO =
adamc@244 535 if Posix.FileSys.access (urs, []) then
adamc@244 536 SOME (Source.SgnConst (#func parseUrs urs),
adamc@244 537 {file = urs,
adamc@201 538 first = ErrorMsg.dummyPos,
adamc@201 539 last = ErrorMsg.dummyPos})
adamc@201 540 else
adamc@201 541 NONE
adamc@56 542
adamc@244 543 val loc = {file = ur,
adamc@201 544 first = ErrorMsg.dummyPos,
adamc@201 545 last = ErrorMsg.dummyPos}
adamc@56 546
adamc@244 547 val ds = #func parseUr ur
adamc@201 548 in
adamc@201 549 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
adamc@201 550 end
adamc@56 551
adamc@764 552 val dsFfi = map parseFfi ffi
adamc@201 553 val ds = map parseOne fnames
adamc@201 554 in
adamc@201 555 let
adamc@201 556 val final = nameOf (List.last fnames)
adamc@271 557
adamc@764 558 val ds = dsFfi @ ds
adamc@764 559 @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
adamc@201 560 in
adamc@271 561 case database of
adamc@271 562 NONE => ds
adamc@271 563 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
adamc@201 564 end handle Empty => ds
adamc@201 565 end,
adamc@201 566 print = SourcePrint.p_file
adamc@201 567 }
adamc@56 568
adamc@270 569 val toParse = transform parse "parse" o toParseJob
adamc@38 570
adamc@378 571 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
adamc@378 572 file = s}
adamc@378 573 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@378 574 file = s}
adamc@378 575
adamc@201 576 val elaborate = {
adamc@201 577 func = fn file => let
adamc@378 578 val basis = #func parseUrs (libFile "basis.urs")
adamc@378 579 val topSgn = #func parseUrs (libFile "top.urs")
adamc@378 580 val topStr = #func parseUr (libFile "top.ur")
adamc@201 581 in
adamc@325 582 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
adamc@201 583 end,
adamc@201 584 print = ElabPrint.p_file ElabEnv.empty
adamc@201 585 }
adamc@5 586
adamc@270 587 val toElaborate = transform elaborate "elaborate" o toParse
adamc@201 588
adamc@448 589 val unnest = {
adamc@448 590 func = Unnest.unnest,
adamc@448 591 print = ElabPrint.p_file ElabEnv.empty
adamc@448 592 }
adamc@448 593
adamc@448 594 val toUnnest = transform unnest "unnest" o toElaborate
adamc@448 595
adamc@313 596 val termination = {
adamc@313 597 func = (fn file => (Termination.check file; file)),
adamc@313 598 print = ElabPrint.p_file ElabEnv.empty
adamc@313 599 }
adamc@313 600
adamc@448 601 val toTermination = transform termination "termination" o toUnnest
adamc@313 602
adamc@201 603 val explify = {
adamc@201 604 func = Explify.explify,
adamc@201 605 print = ExplPrint.p_file ExplEnv.empty
adamc@201 606 }
adamc@201 607
adamc@625 608 val toExplify = transform explify "explify" o toUnnest
adamc@201 609
adamc@201 610 val corify = {
adamc@201 611 func = Corify.corify,
adamc@201 612 print = CorePrint.p_file CoreEnv.empty
adamc@201 613 }
adamc@201 614
adamc@270 615 val toCorify = transform corify "corify" o toExplify
adamc@201 616
adamc@482 617 (*val reduce_local = {
adamc@482 618 func = ReduceLocal.reduce,
adamc@482 619 print = CorePrint.p_file CoreEnv.empty
adamc@482 620 }
adamc@482 621
adamc@482 622 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
adamc@482 623
adamc@443 624 val especialize = {
adamc@443 625 func = ESpecialize.specialize,
adamc@443 626 print = CorePrint.p_file CoreEnv.empty
adamc@443 627 }
adamc@443 628
adamc@443 629 val toEspecialize = transform especialize "especialize" o toCorify
adamc@443 630
adamc@454 631 val core_untangle = {
adamc@454 632 func = CoreUntangle.untangle,
adamc@454 633 print = CorePrint.p_file CoreEnv.empty
adamc@454 634 }
adamc@454 635
adamc@454 636 val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize
adamc@454 637
adamc@202 638 val shake = {
adamc@202 639 func = Shake.shake,
adamc@202 640 print = CorePrint.p_file CoreEnv.empty
adamc@202 641 }
adamc@39 642
adamc@454 643 val toShake1 = transform shake "shake1" o toCore_untangle
adamc@110 644
adamc@607 645 val rpcify = {
adamc@607 646 func = Rpcify.frob,
adamc@607 647 print = CorePrint.p_file CoreEnv.empty
adamc@607 648 }
adamc@607 649
adamc@607 650 val toRpcify = transform rpcify "rpcify" o toShake1
adamc@607 651
adamc@642 652 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
adamc@642 653 val toShake2 = transform shake "shake2" o toCore_untangle2
adamc@642 654
adamc@202 655 val tag = {
adamc@202 656 func = Tag.tag,
adamc@202 657 print = CorePrint.p_file CoreEnv.empty
adamc@202 658 }
adamc@193 659
adamc@642 660 val toTag = transform tag "tag" o toCore_untangle2
adamc@20 661
adamc@202 662 val reduce = {
adamc@202 663 func = Reduce.reduce,
adamc@202 664 print = CorePrint.p_file CoreEnv.empty
adamc@202 665 }
adamc@25 666
adamc@692 667 val toReduce = transform reduce "reduce" o toTag
adamc@23 668
adamc@315 669 val unpoly = {
adamc@315 670 func = Unpoly.unpoly,
adamc@315 671 print = CorePrint.p_file CoreEnv.empty
adamc@315 672 }
adamc@315 673
adamc@315 674 val toUnpoly = transform unpoly "unpoly" o toReduce
adamc@315 675
adamc@202 676 val specialize = {
adamc@202 677 func = Specialize.specialize,
adamc@202 678 print = CorePrint.p_file CoreEnv.empty
adamc@202 679 }
adamc@132 680
adamc@315 681 val toSpecialize = transform specialize "specialize" o toUnpoly
adamc@131 682
adamc@642 683 val toShake3 = transform shake "shake3" o toSpecialize
adamc@133 684
adamc@692 685 val marshalcheck = {
adamc@692 686 func = (fn file => (MarshalCheck.check file; file)),
adamc@692 687 print = CorePrint.p_file CoreEnv.empty
adamc@692 688 }
adamc@692 689
adamc@692 690 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake3
adamc@692 691
adamc@732 692 val effectize = {
adamc@732 693 func = Effective.effectize,
adamc@732 694 print = CorePrint.p_file CoreEnv.empty
adamc@732 695 }
adamc@732 696
adamc@732 697 val toEffectize = transform effectize "effectize" o toMarshalcheck
adamc@732 698
adamc@202 699 val monoize = {
adamc@202 700 func = Monoize.monoize CoreEnv.empty,
adamc@202 701 print = MonoPrint.p_file MonoEnv.empty
adamc@202 702 }
adamc@134 703
adamc@732 704 val toMonoize = transform monoize "monoize" o toEffectize
adamc@96 705
adamc@202 706 val mono_opt = {
adamc@202 707 func = MonoOpt.optimize,
adamc@202 708 print = MonoPrint.p_file MonoEnv.empty
adamc@202 709 }
adamc@29 710
adamc@270 711 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
adamc@5 712
adamc@202 713 val untangle = {
adamc@202 714 func = Untangle.untangle,
adamc@202 715 print = MonoPrint.p_file MonoEnv.empty
adamc@202 716 }
adamc@1 717
adamc@270 718 val toUntangle = transform untangle "untangle" o toMono_opt1
adamc@38 719
adamc@202 720 val mono_reduce = {
adamc@202 721 func = MonoReduce.reduce,
adamc@202 722 print = MonoPrint.p_file MonoEnv.empty
adamc@202 723 }
adamc@16 724
adamc@270 725 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
adamc@39 726
adamc@202 727 val mono_shake = {
adamc@202 728 func = MonoShake.shake,
adamc@202 729 print = MonoPrint.p_file MonoEnv.empty
adamc@202 730 }
adamc@110 731
adamc@270 732 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
adamc@193 733
adamc@572 734 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
adamc@572 735
adamc@567 736 val jscomp = {
adamc@567 737 func = JsComp.process,
adamc@567 738 print = MonoPrint.p_file MonoEnv.empty
adamc@567 739 }
adamc@567 740
adamc@572 741 val toJscomp = transform jscomp "jscomp" o toMono_opt2
adamc@567 742
adamc@572 743 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
adamc@20 744
adamc@506 745 val fuse = {
adamc@506 746 func = Fuse.fuse,
adamc@506 747 print = MonoPrint.p_file MonoEnv.empty
adamc@506 748 }
adamc@506 749
adamc@572 750 val toFuse = transform fuse "fuse" o toMono_opt3
adamc@506 751
adamc@506 752 val toUntangle2 = transform untangle "untangle2" o toFuse
adamc@506 753
adamc@601 754 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
adamc@601 755 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
adamc@506 756
adamc@377 757 val pathcheck = {
adamc@377 758 func = (fn file => (PathCheck.check file; file)),
adamc@377 759 print = MonoPrint.p_file MonoEnv.empty
adamc@377 760 }
adamc@377 761
adamc@506 762 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2
adamc@377 763
adamc@202 764 val cjrize = {
adamc@202 765 func = Cjrize.cjrize,
adamc@202 766 print = CjrPrint.p_file CjrEnv.empty
adamc@202 767 }
adamc@23 768
adamc@377 769 val toCjrize = transform cjrize "cjrize" o toPathcheck
adamc@29 770
adamc@643 771 val scriptcheck = {
adamc@643 772 func = ScriptCheck.classify,
adamc@643 773 print = CjrPrint.p_file CjrEnv.empty
adamc@643 774 }
adamc@643 775
adamc@643 776 val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
adamc@643 777
adamc@282 778 val prepare = {
adamc@282 779 func = Prepare.prepare,
adamc@282 780 print = CjrPrint.p_file CjrEnv.empty
adamc@282 781 }
adamc@282 782
adamc@643 783 val toPrepare = transform prepare "prepare" o toScriptcheck
adamc@282 784
adamc@274 785 val sqlify = {
adamc@274 786 func = Cjrize.cjrize,
adamc@274 787 print = CjrPrint.p_sql CjrEnv.empty
adamc@274 788 }
adamc@274 789
adamc@274 790 val toSqlify = transform sqlify "sqlify" o toMono_opt2
adamc@274 791
adamc@764 792 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
adamc@183 793 let
adamc@378 794 val urweb_o = clibFile "urweb.o"
adamc@378 795 val driver_o = clibFile "driver.o"
adamc@378 796
adamc@435 797 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname
adamc@734 798 val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename
adamc@502 799
adamc@502 800 val (compile, link) =
adamc@502 801 if profile then
adamc@502 802 (compile ^ " -pg", link ^ " -pg")
adamc@502 803 else
adamc@502 804 (compile, link)
adamc@742 805
adamc@742 806 val (compile, link) =
adamc@742 807 if debug then
adamc@742 808 (compile ^ " -g", link ^ " -g")
adamc@742 809 else
adamc@742 810 (compile, link)
adamc@764 811
adamc@764 812 val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
adamc@183 813 in
adamc@183 814 if not (OS.Process.isSuccess (OS.Process.system compile)) then
adamc@183 815 print "C compilation failed\n"
adamc@183 816 else if not (OS.Process.isSuccess (OS.Process.system link)) then
adamc@186 817 print "C linking failed\n"
adamc@183 818 else
adamc@673 819 ()
adamc@183 820 end
adamc@183 821
adamc@202 822 fun compile job =
adamc@282 823 case run toPrepare job of
adamc@244 824 NONE => print "Ur compilation failed\n"
adamc@29 825 | SOME file =>
adamc@202 826 let
adamc@274 827 val job = valOf (run (transform parseUrp "parseUrp") job)
adamc@102 828
adamc@274 829 val (cname, oname, cleanup) =
adamc@274 830 if #debug job then
adamc@457 831 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
adamc@274 832 else
adamc@274 833 let
adamc@274 834 val dir = OS.FileSys.tmpName ()
adamc@403 835 val () = if OS.FileSys.access (dir, []) then
adamc@403 836 OS.FileSys.remove dir
adamc@403 837 else
adamc@403 838 ()
adamc@457 839 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
adamc@457 840 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
adamc@274 841 in
adamc@274 842 OS.FileSys.mkDir dir;
adamc@274 843 (cname, oname,
adamc@274 844 fn () => (OS.FileSys.remove cname;
adamc@274 845 OS.FileSys.remove oname;
adamc@473 846 OS.FileSys.rmDir dir)
adamc@473 847 handle OS.SysErr _ => OS.FileSys.rmDir dir)
adamc@274 848 end
adamc@274 849 val ename = #exe job
adamc@202 850 in
adamc@274 851 let
adamc@274 852 val outf = TextIO.openOut cname
adamc@274 853 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@432 854
adamc@432 855 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
adamc@432 856 val libs =
adamc@432 857 if hasDb then
adamc@432 858 "-lpq"
adamc@432 859 else
adamc@432 860 ""
adamc@274 861 in
adamc@274 862 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
adamc@415 863 TextIO.output1 (outf, #"\n");
adamc@274 864 TextIO.closeOut outf;
adamc@102 865
adamc@274 866 case #sql job of
adamc@274 867 NONE => ()
adamc@274 868 | SOME sql =>
adamc@274 869 let
adamc@274 870 val outf = TextIO.openOut sql
adamc@274 871 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@274 872 in
adamc@274 873 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
adamc@274 874 TextIO.closeOut outf
adamc@274 875 end;
adamc@274 876
adamc@742 877 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
adamc@764 878 profile = #profile job, debug = #debug job, link = #link job};
adamc@274 879
adamc@274 880 cleanup ()
adamc@274 881 end
adamc@274 882 handle ex => (((cleanup ()) handle _ => ()); raise ex)
adamc@202 883 end
adamc@29 884
adamc@1 885 end