Mercurial > urweb
diff src/compiler.sml @ 1780:85a87f155e7b
Flush elaboration cache when switching between .urp files
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sat, 23 Jun 2012 10:11:33 -0400 |
| parents | b5f5e8d439c7 |
| children | 3d922a28370b |
line wrap: on
line diff
--- a/src/compiler.sml Sat Jun 23 09:46:40 2012 -0400 +++ b/src/compiler.sml Sat Jun 23 10:11:33 2012 -0400 @@ -401,464 +401,471 @@ end end +val lastUrp = ref "" + fun parseUrp' accLibs 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 = [], - 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 [] + (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 = [], + 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 ()} + fun pu filename = + let + val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()} - val dir = OS.Path.dir filename - fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) + val dir = OS.Path.dir filename + fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) - val inf = opener () + 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 () + 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 hasBlankLine = hasSpaceLine () - val inf = (TextIO.closeIn inf; opener ()) + 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 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 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 + 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 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), + 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, + 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 parseFrom s = + if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then + (Settings.Prefix, String.substring (s, 0, size s - 1)) else - path ^ "/lib") - handle SysErr => path + (Settings.Exact, s) - fun libify' path = - (if Posix.FileSys.access (relify path ^ ".urp", []) then - path + fun parseFkind s = + case s of + "url" => url + | "mime" => mime + | "requestHeader" => request + | "responseHeader" => response + | _ => (ErrorMsg.error "Bad filter kind"; + url) + + 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 - path ^ "/lib") - handle SysErr => path + (Settings.Exact, s) - val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} + 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 relifyA fname = - OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} + 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 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 + 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) = parseFrom 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) + | "alwaysInline" => Settings.addAlwaysInline arg + | "noXsrfProtection" => Settings.addNoXsrfProtection arg + | "timeFormat" => Settings.setTimeFormat arg - 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 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 + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); + read () + end - 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), - 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, - 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 parseFrom s = - if size s > 1 andalso String.sub (s, size s - 2) = #"/" 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 - | _ => (ErrorMsg.error "Bad filter kind"; - url) - - 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 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) = parseFrom 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) - | "alwaysInline" => Settings.addAlwaysInline arg - | "noXsrfProtection" => Settings.addNoXsrfProtection arg - | "timeFormat" => Settings.setTimeFormat arg - - | _ => 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 + 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