path: root/src/compiler.sml

(* Copyright (c) 2008-2012, 2014, Adam Chlipala
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

structure Compiler :> COMPILER = struct 

structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
                         structure Lex = Lex
                         structure LrParser = LrParser)

type job = {
     prefix : string,
     database : string option,
     sources : string list,
     exe : string,
     sql : string option,
     debug : bool,
     profile : bool,
     timeout : int,
     ffi : string list,
     link : string list,
     linker : string option,
     headers : string list,
     scripts : string list,
     clientToServer : Settings.ffi list,
     effectful : Settings.ffi list,
     benignEffectful : Settings.ffi list,
     clientOnly : Settings.ffi list,
     serverOnly : Settings.ffi list,
     jsFuncs : (Settings.ffi * string) list,
     rewrites : Settings.rewrite list,
     filterUrl : Settings.rule list,
     filterMime : Settings.rule list,
     filterRequest : Settings.rule list,
     filterResponse : Settings.rule list,
     filterEnv : Settings.rule list,
     protocol : string option,
     dbms : string option,
     sigFile : string option,
     safeGets : string list,
     onError : (string * string list * string) option,
     minHeap : int
}

type ('src, 'dst) phase = {
     func : 'src -> 'dst,
     print : 'dst -> Print.PD.pp_desc
}

type pmap = (string * Time.time) list

type ('src, 'dst) transform = {
     func : 'src -> 'dst option,
     print : 'dst -> Print.PD.pp_desc,
     time : 'src * pmap -> 'dst option * pmap
}

val debug = ref false
val dumpSource = ref false
val doIflow = ref false

val doDumpSource = ref (fn () => ())

val stop = ref (NONE : string option)
fun setStop s = stop := SOME s

fun transform (ph : ('src, 'dst) phase) name = {
    func = fn input => let
                  val () = if !debug then
                               print ("Starting " ^ name ^ "....\n")
                           else
                               ()
                  val v = #func ph input
              in
                  if !debug then
                      print ("Finished " ^ name ^ ".\n")
                  else
                      ();
                  if ErrorMsg.anyErrors () then
                      (!doDumpSource ();
                       doDumpSource := (fn () => ());
                       NONE)
                  else if !stop = SOME name then
                      (Print.eprint (#print ph v);
                       ErrorMsg.error ("Stopped compilation after phase " ^ name);
                       NONE)
                  else
                      (if !dumpSource then
                           doDumpSource := (fn () => Print.eprint (#print ph v))
                       else
                           ();
                       SOME v)
              end,
    print = #print ph,
    time = fn (input, pmap) => let
                  val () = if !debug then
                               print ("Starting " ^ name ^ "....\n")
                           else
                               ()
                  val befor = Time.now ()
                  val v = #func ph input
                  val elapsed = Time.- (Time.now (), befor)
              in
                  if !debug then
                      print ("Finished " ^ name ^ ".\n")
                  else
                      ();
                  (if ErrorMsg.anyErrors () then
                       NONE
                   else
                       SOME v,
                   (name, elapsed) :: pmap)
              end
}

fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
                                             ignore (#func tr x))

fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
                                           #func tr x)

fun runPrint (tr : ('src, 'dst) transform) input =
    (ErrorMsg.resetErrors ();
     case #func tr input of
         NONE => print "Failure\n"
       | SOME v =>
         (print "Success\n";
          Print.print (#print tr v);
          print "\n"))

fun runPrintToFile (tr : ('src, 'dst) transform) input fname =
    (ErrorMsg.resetErrors ();
     case #func tr input of
         NONE => print "Failure\n"
       | SOME v =>
         let
             val outf = TextIO.openOut fname
             val str = Print.openOut {dst = outf, wid = 80}
         in
             print "Success\n";
             Print.fprint str (#print tr v);
             Print.PD.PPS.closeStream str;
             TextIO.closeOut outf
         end)

fun time (tr : ('src, 'dst) transform) input =
    let
        val (_, pmap) = #time tr (input, [])
    in
        app (fn (name, time) =>
                print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
        print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
        print "\n"
    end

fun timePrint (tr : ('src, 'dst) transform) input =
    let
        val (ro, pmap) = #time tr (input, [])
    in
        app (fn (name, time) =>
                print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
        print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
        print "\n";
        case ro of
            NONE => print "Failure\n"
          | SOME v =>
            (print "Success\n";
             Print.print (#print tr v);
             print "\n")
    end

fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input =
    (ErrorMsg.resetErrors ();
     case #func tr input of
         NONE => print "Failure\n"
       | SOME file =>
         (print "Success\n";
          app (fn (d, _) =>
                  case d of
                      Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)
                    | Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts
                    | _ => ()) file))

val parseUrs =
    {func = fn filename => let
                   val fname = OS.FileSys.tmpName ()
                   val outf = TextIO.openOut fname
                   val () = TextIO.output (outf, "sig\n")
                   val inf = TextIO.openIn filename
                   fun loop () =
                       case TextIO.inputLine inf of
                           NONE => ()
                         | SOME line => (TextIO.output (outf, line);
                                         loop ())
                   val () = loop ()
                   val () = TextIO.closeIn inf
                   val () = TextIO.closeOut outf

                   val () = (ErrorMsg.resetErrors ();
                             ErrorMsg.resetPositioning filename;
                             Lex.UserDeclarations.initialize ())
	           val file = TextIO.openIn fname
	           fun get _ = TextIO.input file
	           fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
	           val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
	           val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
               in
                   TextIO.closeIn file;
                   case absyn of
                       [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
                     | _ => (ErrorMsg.errorAt {file = filename,
                                               first = {line = 0,
                                                        char = 0},
                                               last = {line = 0,
                                                       char = 0}} "Not a signature";
                             [])
               end
               handle LrParser.ParseError => [],
     print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}

(* The main parsing routine *)
val parseUr = {
    func = fn filename =>
              let
                  val () = (ErrorMsg.resetErrors ();
                            ErrorMsg.resetPositioning filename;
                            Lex.UserDeclarations.initialize ())
	          val file = TextIO.openIn filename
	          fun get _ = TextIO.input file
	          fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
	          val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
	          val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
              in
                  TextIO.closeIn file;
                  case absyn of
                      [(Source.DSgn ("?", _), _)] =>
                      (ErrorMsg.errorAt {file = filename,
                                         first = {line = 0,
                                                  char = 0},
                                         last = {line = 0,
                                                 char = 0}} "File starts with 'sig'";
                       [])
                    | _ => absyn
              end
              handle LrParser.ParseError => [],
     print = SourcePrint.p_file}    

fun p_job ({prefix, database, exe, sql, sources, debug, profile,
            timeout, ffi, link, headers, scripts,
            clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
    let
        open Print.PD
        open Print

        fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
                                                 box [string name, space, string m, string ".", string s, newline])
    in
        box [if debug then
                 box [string "DEBUG", newline]
             else
                 box [],
             if profile then
                 box [string "PROFILE", newline]
             else
                 box [],
             case database of
                 NONE => string "No database."
               | SOME db => string ("Database: " ^ db),
             newline,
             string "Exe: ",
             string exe,
             newline,
             case sql of
                 NONE => string "No SQL file."
               | SOME sql => string ("SQL fle: " ^ sql),
             newline,
             string "Timeout: ",
             string (Int.toString timeout),
             newline,
             p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
             p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
             p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
             p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
             p_ffi "ClientToServer" clientToServer,
             p_ffi "Effectful" effectful,
             p_ffi "BenignEffectful" benignEffectful,
             p_ffi "ClientOnly" clientOnly,
             p_ffi "ServerOnly" serverOnly,
             p_list_sep (box []) (fn ((m, s), s') =>
                                     box [string "JsFunc", space, string m, string ".", string s,
                                          space, string "=", space, string s', newline]) jsFuncs,
             string "Sources:",
             p_list string sources,
             newline]
    end

fun trim s =
    let
        val (_, s) = Substring.splitl Char.isSpace s
        val (s, _) = Substring.splitr Char.isSpace s
    in
        s
    end

val trimS = Substring.string o trim o Substring.full

structure M = BinaryMapFn(struct
                          type ord_key = string
                          val compare = String.compare
                          end)

(* XXX ezyang: pathmap gets initialized /really early/, before
 * we do any options parsing.  So libUr will always point to the
 * default. We override it explicitly in enableBoot *)
val pathmap = ref (M.insert (M.empty, "", Settings.libUr ()))

fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v)

(* XXX ezyang: this is not right; it probably doesn't work in
 * the case of separate build and src trees *)
fun enableBoot () =
 (Settings.configBin := OS.Path.joinDirFile {dir = Config.builddir, file = "bin"};
  Settings.configSrcLib := OS.Path.joinDirFile {dir = Config.builddir, file = "lib"};
  (* joinDirFile is annoying... (ArcError; it doesn't like
   * slashes in file) *)
  Settings.configLib := Config.builddir ^ "/src/c/.libs";
  Settings.configInclude := OS.Path.joinDirFile {dir = Config.builddir ^ "/include", file = "urweb"};
  Settings.configSitelisp := Config.builddir ^ "/src/elisp";
  addPath ("", Settings.libUr ()))

fun capitalize "" = ""
  | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)

fun institutionalizeJob (job : job) =
    (Settings.setDebug (#debug job);
     Settings.setUrlPrefix (#prefix job);
     Settings.setTimeout (#timeout job);
     Settings.setHeaders (#headers job);
     Settings.setScripts (#scripts job);
     Settings.setClientToServer (#clientToServer job);
     Settings.setEffectful (#effectful job);
     Settings.setBenignEffectful (#benignEffectful job);
     Settings.setClientOnly (#clientOnly job);
     Settings.setServerOnly (#serverOnly job);
     Settings.setJsFuncs (#jsFuncs job);
     Settings.setRewriteRules (#rewrites job);
     Settings.setUrlRules (#filterUrl job);
     Settings.setMimeRules (#filterMime job);
     Settings.setRequestHeaderRules (#filterRequest job);
     Settings.setResponseHeaderRules (#filterResponse job);
     Settings.setEnvVarRules (#filterEnv job);
     Option.app Settings.setProtocol (#protocol job);
     Option.app Settings.setDbms (#dbms job);
     Settings.setSafeGets (#safeGets job);
     Settings.setOnError (#onError job);
     Settings.setMinHeap (#minHeap job);
     Settings.setSigFile (#sigFile job))

datatype commentableLine =
         EndOfFile
       | OnlyComment
       | Content of string

fun inputCommentableLine inf =
    case TextIO.inputLine inf of
        NONE => EndOfFile
      | SOME s =>
        let
            val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s)
        in
            if not (Substring.isEmpty after)
               andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then
                OnlyComment
            else
                let
                    val s = #1 (Substring.splitr (not o Char.isSpace) befor)
                in
                    Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then
                                                   if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then
                                                       Substring.trimr 2 s
                                                   else
                                                       Substring.trimr 1 s
                                               else
                                                   s))
                end
        end

val lastUrp = ref ""

fun parseUrp' accLibs fname =
    (if !lastUrp = fname then
         ()
     else
         ModDb.reset ();
     lastUrp := fname;
     if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
        andalso Posix.FileSys.access (fname ^ ".ur", []) then
         let
             val job = {prefix = "/",
                        database = NONE,
                        sources = [fname],
                        exe = fname ^ ".exe",
                        sql = NONE,
                        debug = Settings.getDebug (),
                        profile = false,
                        timeout = 60,
                        ffi = [],
                        link = [],
                        linker = NONE,
                        headers = [],
                        scripts = [],
                        clientToServer = [],
                        effectful = [],
                        benignEffectful = [],
                        clientOnly = [],
                        serverOnly = [],
                        jsFuncs = [],
                        rewrites = [{pkind = Settings.Any,
                                     kind = Settings.Prefix,
                                     from = capitalize (OS.Path.file fname) ^ "/", to = "",
                                     hyphenate = false}],
                        filterUrl = [],
                        filterMime = [],
                        filterRequest = [],
                        filterResponse = [],
                        filterEnv = [],
                        protocol = NONE,
                        dbms = NONE,
                        sigFile = NONE,
                        safeGets = [],
                        onError = NONE,
                        minHeap = 0}
         in
             institutionalizeJob job;
             {Job = job, Libs = []}
         end
     else
         let
             val pathmap = ref (!pathmap)
             val bigLibs = ref []

             fun pu filename =
                 let
                     val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
                     val thisPath = OS.Path.dir filename

                     val dir = OS.Path.dir filename
                     fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})

                     val inf = opener ()

                     fun hasSpaceLine () =
                         case inputCommentableLine inf of
                             Content s => s = "debug" orelse s = "profile"
                                          orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
                           | EndOfFile => false
                           | OnlyComment => hasSpaceLine ()

                     val hasBlankLine = hasSpaceLine ()

                     val inf = (TextIO.closeIn inf; opener ())

                     fun pathify fname =
                         if size fname > 0 andalso String.sub (fname, 0) = #"$" then
                             let
                                 val fname' = Substring.extract (fname, 1, NONE)
                                 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
                             in
                                 case M.find (!pathmap, Substring.string befor) of
                                     NONE => fname
                                   | SOME rep => rep ^ Substring.string after
                             end
                         else
                             fname

                     fun relify fname =
                         let
                             val fname = pathify fname
                         in
                             OS.Path.concat (dir, fname)
                             handle OS.Path.Path => fname
                         end

                     fun libify path =
                         (if Posix.FileSys.access (path ^ ".urp", []) then
                              path
                          else
                              path ^ "/lib")
                         handle SysErr => path

                     fun libify' path =
                         (if Posix.FileSys.access (relify path ^ ".urp", []) then
                              path
                          else
                              path ^ "/lib")
                         handle SysErr => path

                     val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}

                     fun relifyA fname =
                         OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}

                     fun readSources acc =
                         case inputCommentableLine inf of
                             Content line =>
                             let
                                 val acc = if CharVector.all Char.isSpace line then
                                               acc
                                           else
                                               let
                                                   val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
                                                                                           (String.explode line))
                                                   val fname = relifyA fname
                                               in
                                                   fname :: acc
                                               end
                             in
                                 readSources acc
                             end
                           | OnlyComment => readSources acc
                           | EndOfFile => rev acc

                     val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s)
                     val database = ref (Settings.getDbstring ())
                     val exe = ref (Settings.getExe ())
                     val sql = ref (Settings.getSql ())
                     val debug = ref (Settings.getDebug ())
                     val profile = ref false
                     val timeout = ref NONE
                     val ffi = ref []
                     val link = ref []
                     val linker = ref NONE
                     val headers = ref []
                     val scripts = ref []
                     val clientToServer = ref []
                     val effectful = ref []
                     val benignEffectful = ref []
                     val clientOnly = ref []
                     val serverOnly = ref []
                     val jsFuncs = ref []
                     val rewrites = ref []
                     val url = ref []
                     val mime = ref []
                     val request = ref []
                     val response = ref []
                     val env = ref []
                     val libs = ref []
                     val protocol = ref NONE
                     val dbms = ref NONE
                     val sigFile = ref (Settings.getSigFile ())
                     val safeGets = ref []
                     val onError = ref NONE
                     val minHeap = ref 0

                     fun finish sources =
                         let
                             val job = {
                                 prefix = Option.getOpt (!prefix, "/"),
                                 database = !database,
                                 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
                                                                                 ext = SOME "exe"}),
                                 sql = !sql,
                                 debug = !debug,
                                 profile = !profile,
                                 timeout = Option.getOpt (!timeout, 60),
                                 ffi = rev (!ffi),
                                 link = rev (!link),
                                 linker = !linker,
                                 headers = rev (!headers),
                                 scripts = rev (!scripts),
                                 clientToServer = rev (!clientToServer),
                                 effectful = rev (!effectful),
                                 benignEffectful = rev (!benignEffectful),
                                 clientOnly = rev (!clientOnly),
                                 serverOnly = rev (!serverOnly),
                                 jsFuncs = rev (!jsFuncs),
                                 rewrites = rev (!rewrites),
                                 filterUrl = rev (!url),
                                 filterMime = rev (!mime),
                                 filterRequest = rev (!request),
                                 filterResponse = rev (!response),
                                 filterEnv = rev (!env),
                                 sources = sources,
                                 protocol = !protocol,
                                 dbms = !dbms,
                                 sigFile = !sigFile,
                                 safeGets = rev (!safeGets),
                                 onError = !onError,
                                 minHeap = !minHeap
                             }

                             fun mergeO f (old, new) =
                                 case (old, new) of
                                     (NONE, _) => new
                                   | (_, NONE) => old
                                   | (SOME v1, SOME v2) => SOME (f (v1, v2))

                             fun same desc = mergeO (fn (x : string, y) =>
                                                        (if x = y then
                                                             ()
                                                         else
                                                             ErrorMsg.error ("Multiple "
                                                                             ^ desc ^ " values that don't agree");
                                                         x))

                             fun merge (old : job, new : job) = {
                                 prefix = case #prefix old of
                                              "/" => #prefix new
                                            | pold => case #prefix new of
                                                          "/" => pold
                                                        | pnew => (if pold = pnew then
                                                                       ()
                                                                   else
                                                                       ErrorMsg.error ("Multiple prefix values that don't agree: "
                                                                                       ^ pold ^ ", " ^ pnew);
                                                                   pold),
                                 database = mergeO (fn (old, _) => old) (#database old, #database new),
                                 exe = #exe old,
                                 sql = #sql old,
                                 debug = #debug old orelse #debug new,
                                 profile = #profile old orelse #profile new,
                                 timeout = #timeout old,
                                 ffi = #ffi old @ #ffi new,
                                 link = #link old @ #link new,
                                 linker = mergeO (fn (_, new) => new) (#linker old, #linker new),
                                 headers = #headers old @ #headers new,
                                 scripts = #scripts old @ #scripts new,
                                 clientToServer = #clientToServer old @ #clientToServer new,
                                 effectful = #effectful old @ #effectful new,
                                 benignEffectful = #benignEffectful old @ #benignEffectful new,
                                 clientOnly = #clientOnly old @ #clientOnly new,
                                 serverOnly = #serverOnly old @ #serverOnly new,
                                 jsFuncs = #jsFuncs old @ #jsFuncs new,
                                 rewrites = #rewrites old @ #rewrites new,
                                 filterUrl = #filterUrl old @ #filterUrl new,
                                 filterMime = #filterMime old @ #filterMime new,
                                 filterRequest = #filterRequest old @ #filterRequest new,
                                 filterResponse = #filterResponse old @ #filterResponse new,
                                 filterEnv = #filterEnv old @ #filterEnv new,
                                 sources = #sources new
                                           @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
                                                         (#sources old),
                                 protocol = mergeO #2 (#protocol old, #protocol new),
                                 dbms = mergeO #2 (#dbms old, #dbms new),
                                 sigFile = mergeO #2 (#sigFile old, #sigFile new),
                                 safeGets = #safeGets old @ #safeGets new,
                                 onError = mergeO #2 (#onError old, #onError new),
                                 minHeap = Int.max (#minHeap old, #minHeap new)
                             }
                         in
                             if accLibs then
                                 foldr (fn (job', job) => merge (job, job')) job (!libs)
                             else
                                 job
                         end

                     fun parsePkind s =
                         case s of
                             "all" => Settings.Any
                           | "url" => Settings.Url
                           | "table" => Settings.Table
                           | "sequence" => Settings.Sequence
                           | "view" => Settings.View
                           | "relation" => Settings.Relation
                           | "cookie" => Settings.Cookie
                           | "style" => Settings.Style
                           | _ => (ErrorMsg.error "Bad path kind spec";
                                   Settings.Any)

                     fun parsePattern s =
                         if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
                             (Settings.Prefix, String.substring (s, 0, size s - 1))
                         else
                             (Settings.Exact, s)

                     fun parseFkind s =
                         case s of
                             "url" => url
                           | "mime" => mime
                           | "requestHeader" => request
                           | "responseHeader" => response
                           | "env" => env
                           | _ => (ErrorMsg.error "Bad filter kind";
                                   url)

                     fun read () =
                         case inputCommentableLine inf of
                             EndOfFile => finish []
                           | OnlyComment => read ()
                           | Content "" => finish (readSources [])
                           | Content line =>
                             let
                                 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
                                 val cmd = Substring.string (trim cmd)
                                 val arg = Substring.string (trim arg)

                                 fun ffiS () =
                                     case String.fields (fn ch => ch = #".") arg of
                                         [m, x] => (m, x)
                                       | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
                                               ("", ""))

                                 fun ffiM () =
                                     case String.fields (fn ch => ch = #"=") arg of
                                         [f, s] =>
                                         let
                                             val f = trimS f
                                             val s = trimS s
                                         in
                                             case String.fields (fn ch => ch = #".") f of
                                                 [m, x] => ((m, x), s)
                                               | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
                                                       (("", ""), ""))
                                         end
                                       | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
                                               (("", ""), ""))
                             in
                                 case cmd of
                                     "prefix" => prefix := SOME arg
                                   | "database" =>
                                     (case !database of
                                          NONE => database := SOME arg
                                        | SOME _ => ())
                                   | "dbms" =>
                                     (case !dbms of
                                          NONE => dbms := SOME arg
                                        | SOME _ => ())
                                   | "sigfile" =>
                                     (case !sigFile of
                                          NONE => sigFile := SOME arg
                                        | SOME _ => ())
                                   | "exe" =>
                                     (case !exe of
                                          NONE => exe := SOME (relify arg)
                                        | SOME _ => ())
                                   | "sql" =>
                                     (case !sql of
                                          NONE => sql := SOME (relify arg)
                                        | SOME _ => ())
                                   | "debug" => debug := true
                                   | "profile" => profile := true
                                   | "timeout" =>
                                     (case !timeout of
                                          NONE => ()
                                        | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
                                      timeout := SOME (valOf (Int.fromString arg)))
                                   | "ffi" => ffi := relify arg :: !ffi
                                   | "link" => let
                                         val arg = if size arg >= 1
                                                      andalso String.sub (arg, 0) = #"-" then
                                                       arg
                                                   else
                                                       relifyA arg
                                     in
                                         link := arg :: !link
                                     end
                                   | "linker" => linker := SOME arg
                                   | "include" => headers := relifyA arg :: !headers
                                   | "script" => scripts := arg :: !scripts
                                   | "clientToServer" => clientToServer := ffiS () :: !clientToServer
                                   | "safeGet" => safeGets := arg :: !safeGets
                                   | "effectful" => effectful := ffiS () :: !effectful
                                   | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
                                   | "clientOnly" => clientOnly := ffiS () :: !clientOnly
                                   | "serverOnly" => serverOnly := ffiS () :: !serverOnly
                                   | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
                                   | "rewrite" =>
                                     let
                                         fun doit (pkind, from, to, hyph) =
                                             let
                                                 val pkind = parsePkind pkind
                                                 val (kind, from) = parsePattern from
                                             in
                                                 rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
                                             end
                                     in
                                         case String.tokens Char.isSpace arg of
                                             [pkind, from, to, "[-]"] => doit (pkind, from, to, true)
                                           | [pkind, from, "[-]"] => doit (pkind, from, "", true)
                                           | [pkind, from, to] => doit (pkind, from, to, false)
                                           | [pkind, from] => doit (pkind, from, "", false)
                                           | _ => ErrorMsg.error "Bad 'rewrite' syntax"
                                     end
                                   | "allow" =>
                                     (case String.tokens Char.isSpace arg of
                                          [fkind, pattern] =>
                                          let
                                              val fkind = parseFkind fkind
                                              val (kind, pattern) = parsePattern pattern
                                          in
                                              fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
                                          end
                                        | _ => ErrorMsg.error "Bad 'allow' syntax")
                                   | "deny" =>
                                     (case String.tokens Char.isSpace arg of
                                          [fkind, pattern] =>
                                          let
                                              val fkind = parseFkind fkind
                                              val (kind, pattern) = parsePattern pattern
                                          in
                                              fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
                                          end
                                        | _ => ErrorMsg.error "Bad 'deny' syntax")
                                   | "library" => if accLibs then
                                                      libs := pu (libify (relify arg)) :: !libs
                                                  else
                                                      bigLibs := libify' arg :: !bigLibs
                                   | "path" =>
                                     (case String.fields (fn ch => ch = #"=") arg of
                                          [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
                                                     handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
                                        | _ => ErrorMsg.error "path argument not of the form name=value'")
                                   | "onError" =>
                                     (case String.fields (fn ch => ch = #".") arg of
                                          m1 :: (fs as _ :: _) =>
                                          onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
                                        | _ => ErrorMsg.error "invalid 'onError' argument")
                                   | "limit" =>
                                     (case String.fields Char.isSpace arg of
                                          [class, num] =>
                                          (case Int.fromString num of
                                               NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
                                             | SOME n =>
                                               if n < 0 then
                                                   ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
                                               else
                                                   Settings.addLimit (class, n))
                                        | _ => ErrorMsg.error "invalid 'limit' arguments")
                                   | "minHeap" =>
                                     (case Int.fromString arg of
                                          NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
                                        | SOME n => minHeap := n)
                                   | "coreInline" =>
                                     (case Int.fromString arg of
                                          NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'")
                                        | SOME n => Settings.setCoreInline n)
                                   | "monoInline" =>
                                     (case Int.fromString arg of
                                          NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'")
                                        | SOME n => Settings.setMonoInline n)
                                   | "alwaysInline" => Settings.addAlwaysInline arg
                                   | "neverInline" => Settings.addNeverInline arg
                                   | "noXsrfProtection" => Settings.addNoXsrfProtection arg
                                   | "timeFormat" => Settings.setTimeFormat arg
                                   | "noMangleSql" => Settings.setMangleSql false
                                   | "html5" => Settings.setIsHtml5 true
                                   | "lessSafeFfi" => Settings.setLessSafeFfi true

                                   | "file" =>
                                     (case String.fields Char.isSpace arg of
                                          [uri, fname] => (Settings.setFilePath thisPath;
                                                           Settings.addFile {Uri = uri,
                                                                             LoadFromFilename = fname})
                                        | _ => ErrorMsg.error "Bad 'file' arguments")

                                   | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                                 read ()
                             end

                     val job = if hasBlankLine then
                                   read ()
                               else
                                   finish (readSources [])
                 in
                     TextIO.closeIn inf;
                     institutionalizeJob job;
                     job
                 end
         in
             {Job = pu fname, Libs = !bigLibs}
         end)

fun p_job' {Job = j, Libs = _ : string list} = p_job j

val parseUrp = {
    func = #Job o parseUrp' true,
    print = p_job
}

val parseUrp' = {
    func = parseUrp' false,
    print = p_job'
}

val toParseJob = transform parseUrp "parseJob"
val toParseJob' = transform parseUrp' "parseJob'"

fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
    func = fn input => case #func tr1 input of
                           NONE => NONE
                         | SOME v => #func tr2 v,
    print = #print tr2,
    time = fn (input, pmap) => let
                  val (ro, pmap) = #time tr1 (input, pmap)
              in
                  case ro of
                      NONE => (NONE, pmap)
                    | SOME v => #time tr2 (v, pmap)
              end
}

structure SM = BinaryMapFn(struct
                           type ord_key = string
                           val compare = String.compare
                           end)

val moduleRoots = ref ([] : (string * string) list)
fun addModuleRoot (k, v) = moduleRoots :=
                           (OS.Path.mkAbsolute {path = k,
                                                relativeTo = OS.FileSys.getDir ()},
                            v) :: !moduleRoots

structure SK = struct
type ord_key = string
val compare = String.compare
end

structure SS = BinarySetFn(SK)
structure SM = BinaryMapFn(SK)

exception MissingFile of string

val parse = {
    func = fn {database, sources = fnames, ffi, onError, ...} : job =>
              let
                  val mrs = !moduleRoots

                  val anyErrors = ref false
                  fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
                  fun nameOf fname =
                      let
                          val fname = OS.Path.file fname
                          val fst = if size fname = 0 then #"!" else String.sub (fname, 0)
                      in
                          if not (Char.isAlpha fst) then
                              ErrorMsg.error ("Filename doesn't start with letter: " ^ fname)
                          else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then
                              ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname)
                          else
                              ();
                          capitalize fname
                      end

                  fun parseFfi fname =
                      let
                          val mname = nameOf fname
                          val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}

                          val loc = {file = urs,
                                     first = ErrorMsg.dummyPos,
                                     last = ErrorMsg.dummyPos}

                          val sgn = (Source.SgnConst (#func parseUrs urs), loc)
                      in
                          checkErrors ();
                          (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc)
                      end

                  val defed = ref SS.empty
                  val fulls = ref SS.empty

                  fun parseOne fname =
                      let
                          val mname = nameOf fname
                          val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
                          val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}

                          val () = if Posix.FileSys.access (ur, []) then
                                       ()
                                   else
                                       raise MissingFile ur

                          val sgnO =
                              if Posix.FileSys.access (urs, []) then
                                  SOME (Source.SgnConst (#func parseUrs urs),
                                        {file = urs,
                                         first = ErrorMsg.dummyPos,
                                         last = ErrorMsg.dummyPos})
                                  before checkErrors ()
                              else
                                  NONE

                          val loc = {file = ur,
                                     first = ErrorMsg.dummyPos,
                                     last = ErrorMsg.dummyPos}

                          val urt = OS.FileSys.modTime ur
                          val urst = (OS.FileSys.modTime urs) handle _ => urt

                          val ds = #func parseUr ur
                          val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
                                                (Source.StrConst ds, loc), false), loc)

                          val fname = OS.Path.mkCanonical fname
                          val d = case List.find (fn (root, name) =>
                                                     String.isPrefix (root ^ "/") fname) mrs of
                                      NONE => d
                                    | SOME (root, name) =>
                                      let
                                          val fname = String.extract (fname, size root + 1, NONE)
                                          val pieces = name :: String.tokens (fn ch => ch = #"/") fname
                                          val pieces = List.filter (fn s => size s > 0
                                                                            andalso Char.isAlpha (String.sub (s, 0)))
                                                                   pieces
                                          val pieces = map capitalize pieces
                                          val full = String.concatWith "." pieces

                                          fun makeD first prefix pieces =
                                              case pieces of
                                                  [] => (ErrorMsg.error "Empty module path";
                                                         (Source.DStyle "Boo", loc))
                                                | [_] => d
                                                | piece :: pieces =>
                                                  let
                                                      val this = case prefix of
                                                                     "" => piece
                                                                   | _ => prefix ^ "." ^ piece
                                                      val old = SS.member (!defed, this)

                                                      fun notThere (ch, s) =
                                                          Substring.isEmpty (#2 (Substring.splitl
                                                                                     (fn ch' => ch' <> ch) s))

                                                      fun simOpen () =
                                                          SS.foldl (fn (full, ds) =>
                                                                       if String.isPrefix (this ^ ".") full
                                                                          andalso notThere (#".",
                                                                                            Substring.extract (full,
                                                                                                               size
                                                                                                                   this + 1,
                                                                                                               NONE)) then
                                                                           let
                                                                               val parts = String.tokens
                                                                                           (fn ch => ch = #".") full

                                                                               val part = List.last parts

                                                                               val imp = if length parts >= 2 then
                                                                                             (Source.StrProj
                                                                                                  ((Source.StrVar
                                                                                                        (List.nth (parts,
                                                                                                                   length
                                                                                                                       parts
                                                                                                                       - 2)),
                                                                                                    loc),
                                                                                                   part), loc)
                                                                                         else
                                                                                             (Source.StrVar part, loc)
                                                                           in
                                                                               (Source.DStr (part, NONE, NONE, imp, false),
                                                                                loc) :: ds
                                                                           end
                                                                       else
                                                                           ds) [] (!fulls)
                                                  in
                                                      defed := SS.add (!defed, this);
                                                      (Source.DStr (piece, NONE, NONE,
                                                                    (Source.StrConst (if old then
                                                                                          simOpen ()
                                                                                          @ [makeD false this pieces]
                                                                                      else
                                                                                          [makeD false this pieces]),
                                                                     loc), first andalso old),
                                                       loc)
                                                  end
                                      in
                                          if SS.member (!fulls, full) then
                                              ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
                                          else
                                              ();
                                          
                                          makeD true "" pieces
                                          before ignore (foldl (fn (new, path) =>
                                                                   let
                                                                       val new' = case path of
                                                                                      "" => new
                                                                                    | _ => path ^ "." ^ new
                                                                   in
                                                                       fulls := SS.add (!fulls, new');
                                                                       new'
                                                                   end) "" pieces)
                                      end
                      in
                          checkErrors ();
                          d
                      end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
                                                       (Source.DSequence "", ErrorMsg.dummySpan))

                  val dsFfi = map parseFfi ffi
                  val ds = map parseOne fnames
                  val loc = ErrorMsg.dummySpan
              in
                  if !anyErrors then
                      ErrorMsg.error "Parse failure"
                  else
                      ();

                  let
                      val final = List.last fnames
                      val final = case List.find (fn (root, name) =>
                                                     String.isPrefix (root ^ "/") final) mrs of
                                      NONE => (Source.StrVar (nameOf final), loc)
                                    | SOME (root, name) =>
                                      let
                                          val m = (Source.StrVar name, loc)
                                          val final = String.extract (final, size root + 1, NONE)
                                          val fields = String.fields (fn ch => ch = #"/") final
                                          val fields = List.filter (fn s => size s = 0
                                                                            orelse not (Char.isDigit (String.sub (s, 0))))
                                                                   fields
                                      in
                                          foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc))
                                                m fields
                                      end

                      val ds = dsFfi @ ds
                               @ [(Source.DExport final, loc)]

                      val ds = case database of
                                   NONE => ds
                                 | SOME s => (Source.DDatabase s, loc) :: ds

                      val ds = case onError of
                                   NONE => ds
                                 | SOME v => ds @ [(Source.DOnError v, loc)]

                      fun dummy fname = {file = Settings.libFile fname,
                                         first = ErrorMsg.dummyPos,
                                         last = ErrorMsg.dummyPos}

                      val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
                      val used = SM.insert (used, "Top", dummy "top.urs")
                  in
                      ignore (List.foldl (fn (d, used) =>
                                             case #1 d of
                                                 Source.DStr (x, _, _, _, false) =>
                                                 (case SM.find (used, x) of
                                                      SOME loc =>
                                                      (ErrorMsg.error ("Duplicate top-level module name " ^ x);
                                                       Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)),
                                                                               ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))];
                                                       used)
                                                    | NONE =>
                                                      SM.insert (used, x, #2 d))
                                               | _ => used) used ds);
                      ds
                  end handle Empty => ds
              end,
    print = SourcePrint.p_file
}

val toParse = transform parse "parse" o toParseJob

val elaborate = {
    func = fn file => let
                  val basisF = Settings.libFile "basis.urs"
                  val topF = Settings.libFile "top.urs"
                  val topF' = Settings.libFile "top.ur"

                  val basis = #func parseUrs basisF
                  val topSgn = #func parseUrs topF
                  val topStr = #func parseUr topF'

                  val tm1 = OS.FileSys.modTime topF
                  val tm2 = OS.FileSys.modTime topF'
              in
                  Elaborate.elabFile basis (OS.FileSys.modTime basisF)
                                     topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1)
                                     ElabEnv.empty file
              end,
    print = ElabPrint.p_file ElabEnv.empty
}

val toElaborate = transform elaborate "elaborate" o toParse

val unnest = {
    func = Unnest.unnest,
    print = ElabPrint.p_file ElabEnv.empty
}

val toUnnest = transform unnest "unnest" o toElaborate

val termination = {
    func = (fn file => (Termination.check file; file)),
    print = ElabPrint.p_file ElabEnv.empty
}

val toTermination = transform termination "termination" o toUnnest

val explify = {
    func = Explify.explify,
    print = ExplPrint.p_file ExplEnv.empty
}

val toExplify = transform explify "explify" o toUnnest

val corify = {
    func = Corify.corify,
    print = CorePrint.p_file CoreEnv.empty
}

val toCorify = transform corify "corify" o toExplify

(*val reduce_local = {
    func = ReduceLocal.reduce,
    print = CorePrint.p_file CoreEnv.empty
}

val toReduce_local = transform reduce_local "reduce_local" o toCorify*)

val especialize = {
    func = ESpecialize.specialize,
    print = CorePrint.p_file CoreEnv.empty
}

val core_untangle = {
    func = CoreUntangle.untangle,
    print = CorePrint.p_file CoreEnv.empty
}

val toCore_untangle = transform core_untangle "core_untangle" o toCorify

val shake = {
    func = Shake.shake,
    print = CorePrint.p_file CoreEnv.empty
}

val toShake1 = transform shake "shake1" o toCore_untangle

val toEspecialize1' = transform especialize "especialize1'" o toShake1
val toShake1' = transform shake "shake1'" o toEspecialize1'

val rpcify = {
    func = Rpcify.frob,
    print = CorePrint.p_file CoreEnv.empty
}

val toRpcify = transform rpcify "rpcify" o toShake1'

val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
val toShake2 = transform shake "shake2" o toCore_untangle2

val toEspecialize1 = transform especialize "especialize1" o toShake2

val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
val toShake3 = transform shake "shake3" o toCore_untangle3

val tag = {
    func = Tag.tag,
    print = CorePrint.p_file CoreEnv.empty
}

val toTag = transform tag "tag" o toShake3

val reduce = {
    func = Reduce.reduce,
    print = CorePrint.p_file CoreEnv.empty
}

val toReduce = transform reduce "reduce" o toTag

val toShakey = transform shake "shakey" o toReduce

val unpoly = {
    func = Unpoly.unpoly,
    print = CorePrint.p_file CoreEnv.empty
}

val toUnpoly = transform unpoly "unpoly" o toShakey

val specialize = {
    func = Specialize.specialize,
    print = CorePrint.p_file CoreEnv.empty
}

val toSpecialize = transform specialize "specialize" o toUnpoly

val toShake4 = transform shake "shake4" o toSpecialize

val toEspecialize2 = transform especialize "especialize2" o toShake4
val toShake4' = transform shake "shake4'" o toEspecialize2
val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
val toShake4'' = transform shake "shake4'" o toSpecialize2
val toEspecialize3 = transform especialize "especialize3" o toShake4''

val toReduce2 = transform reduce "reduce2" o toEspecialize3

val toShake5 = transform shake "shake5" o toReduce2

val marshalcheck = {
    func = (fn file => (MarshalCheck.check file; file)),
    print = CorePrint.p_file CoreEnv.empty
}

val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5

val effectize = {
    func = Effective.effectize,
    print = CorePrint.p_file CoreEnv.empty
}

val toEffectize = transform effectize "effectize" o toMarshalcheck

val css = {
    func = Css.summarize,
    print = fn _ => Print.box []
}

val toCss = transform css "css" o toShake5

val monoize = {
    func = Monoize.monoize CoreEnv.empty,
    print = MonoPrint.p_file MonoEnv.empty
}

val toMonoize = transform monoize "monoize" o toEffectize

val mono_opt = {
    func = MonoOpt.optimize,
    print = MonoPrint.p_file MonoEnv.empty
}

val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize

val untangle = {
    func = Untangle.untangle,
    print = MonoPrint.p_file MonoEnv.empty
}

val toUntangle = transform untangle "untangle" o toMono_opt1

val mono_reduce = {
    func = MonoReduce.reduce,
    print = MonoPrint.p_file MonoEnv.empty
}

val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle

val mono_shake = {
    func = MonoShake.shake,
    print = MonoPrint.p_file MonoEnv.empty
}

val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce

val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake

val iflow = {
    func = (fn file => (if !doIflow then Iflow.check file else (); file)),
    print = MonoPrint.p_file MonoEnv.empty
}

val toIflow = transform iflow "iflow" o toMono_opt2

val namejs = {
    func = NameJS.rewrite,
    print = MonoPrint.p_file MonoEnv.empty
}

val toNamejs = transform namejs "namejs" o toIflow

val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs

val scriptcheck = {
    func = ScriptCheck.classify,
    print = MonoPrint.p_file MonoEnv.empty
}

val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle

val dbmodecheck = {
    func = DbModeCheck.classify,
    print = MonoPrint.p_file MonoEnv.empty
}

val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck

val jscomp = {
    func = JsComp.process,
    print = MonoPrint.p_file MonoEnv.empty
}

val toJscomp = transform jscomp "jscomp" o toDbmodecheck

val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp

val fuse = {
    func = Fuse.fuse,
    print = MonoPrint.p_file MonoEnv.empty
}

val toFuse = transform fuse "fuse" o toMono_opt3

val toUntangle2 = transform untangle "untangle2" o toFuse

val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
val toFuse2 = transform fuse "fuse2" o toMono_reduce3
val toUntangle3 = transform untangle "untangle3" o toFuse2
val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3

val pathcheck = {
    func = (fn file => (PathCheck.check file; file)),
    print = MonoPrint.p_file MonoEnv.empty
}

val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3

val sidecheck = {
    func = SideCheck.check,
    print = MonoPrint.p_file MonoEnv.empty
}

val toSidecheck = transform sidecheck "sidecheck" o toPathcheck

val sigcheck = {
    func = SigCheck.check,
    print = MonoPrint.p_file MonoEnv.empty
}

val toSigcheck = transform sigcheck "sigcheck" o toSidecheck

val cjrize = {
    func = Cjrize.cjrize,
    print = CjrPrint.p_file CjrEnv.empty
}

val toCjrize = transform cjrize "cjrize" o toSigcheck

val prepare = {
    func = Prepare.prepare,
    print = CjrPrint.p_file CjrEnv.empty
}

val toPrepare = transform prepare "prepare" o toCjrize

val checknest = {
    func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
    print = CjrPrint.p_file CjrEnv.empty
}

val toChecknest = transform checknest "checknest" o toPrepare

val sqlify = {
    func = Cjrize.cjrize,
    print = CjrPrint.p_sql CjrEnv.empty
}

val toSqlify = transform sqlify "sqlify" o toMono_opt2

fun escapeFilename s =
    "\""
    ^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s
    ^ "\""

val beforeC = ref (fn () => ())

structure StringSet = BinarySetFn(struct
                                  type ord_key = string
                                  val compare = String.compare
                                  end)

fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} =
    let
        val proto = Settings.currentProtocol ()

        val lib = if Settings.getStaticLinking () then
                      " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a"
                  else
                      "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb"

        val opt = if debug then
                      ""
                  else
                      " -O3"

        val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value"
                      ^ opt ^ " -I " ^ !Settings.configInclude
                      ^ " " ^ #compile proto
                      ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname

        val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs)

        val ssl = if Settings.getStaticLinking () then
                      Config.openssl ^ " -ldl -lz"
                  else
                      Config.openssl

        val link = linker
                   ^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename

        val (compile, link) =
            if profile then
                (compile ^ " -pg", link ^ " -pg")
            else
                (compile, link)

        val (compile, link) =
            if debug then
                (compile ^ " -g", link ^ " -g")
            else
                (compile, link)

        val link = #1 (foldl
            (fn (s, (link, set)) =>
              if StringSet.member (set, s) then
                (link, set)
              else
                ((link ^ " " ^ s), StringSet.add (set, s)))
            (link, StringSet.empty)
            link')

        fun system s =
            (if debug then
                 print (s ^ "\n")
             else
                 ();
             OS.Process.isSuccess (OS.Process.system s))
    in
        !beforeC ();
        system compile andalso system link
    end

fun compile job =
    case run toChecknest job of
        NONE => false
      | SOME file =>
        let
            val job = valOf (run (transform parseUrp "parseUrp") job)

            val (cname, oname, cleanup) =
                if #debug job then
                    ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
                else
                    let
                        val dir = OS.FileSys.tmpName ()
                        val () = if OS.FileSys.access (dir, []) then
                                     OS.FileSys.remove dir
                                 else
                                     ()
                        val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
                        val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
                    in
                        OS.FileSys.mkDir dir;
                        (cname, oname,
                      fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then
                                    ()
                                else
                                    raise Fail ("Unable to delete temporary directory " ^ dir)))
                    end
            val ename = #exe job
        in
            let
                val outf = TextIO.openOut cname
                val s = TextIOPP.openOut {dst = outf, wid = 80}

                val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
                val libs =
                    if hasDb then
                        #link (Settings.currentDbms ())
                    else
                        ""
            in
                Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
		TextIO.output1 (outf, #"\n");
                TextIO.closeOut outf;

                if ErrorMsg.anyErrors () then
                    false
                else
                    (case #sql job of
                         NONE => ()
                       | SOME sql =>
                         let
                             val outf = TextIO.openOut sql
                             val s = TextIOPP.openOut {dst = outf, wid = 80}
                         in
                             Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
                             TextIO.closeOut outf
                         end;

                     compileC {cname = cname, oname = oname, ename = ename, libs = libs,
                               profile = #profile job, debug = #debug job, linker = #linker job, link = #link job}
                     
                     before cleanup ())
            end
            handle ex => (((cleanup ()) handle _ => ()); raise ex)
        end

fun compiler job =
    if compile job then
        ()
    else
        OS.Process.exit OS.Process.failure

fun moduleOf fname =
    let
        val mrs = !moduleRoots
        val fname = OS.Path.mkCanonical fname
    in
        case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
            NONE => capitalize (OS.Path.base (OS.Path.file fname))
          | SOME (root, name) =>
            let
                val fname = OS.Path.base fname
                val fname = String.extract (fname, size root + 1, NONE)
                val fs = String.fields (fn ch => ch = #"/") fname
                val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
                val fs = map capitalize fs
            in
                String.concatWith "." (name :: fs)
            end
    end

end