summaryrefslogtreecommitdiff
path: root/src/compiler.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 12:50:52 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 12:50:52 -0400
commit471d5a79a82a673ca46d3a4e711f54ae1409c0f3 (patch)
tree16510fccf9c64c746597334f24e86fbdc6f98e96 /src/compiler.sml
parentf996ddede8ad8df6a6b475185b5384366f0dd6c9 (diff)
Add 'library' directive
Diffstat (limited to 'src/compiler.sml')
-rw-r--r--src/compiler.sml344
1 files changed, 194 insertions, 150 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index 1a7868e3..8d33023d 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -264,157 +264,201 @@ fun trim s =
s
end
+fun parseUrp' filename =
+ let
+ val dir = OS.Path.dir filename
+ val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
+
+ fun relify fname =
+ OS.Path.concat (dir, fname)
+ handle OS.Path.Path => fname
+
+ val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
+
+ fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
+
+ fun readSources acc =
+ case TextIO.inputLine inf of
+ NONE => rev acc
+ | SOME 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 = relify fname
+ in
+ fname :: acc
+ end
+ in
+ readSources acc
+ end
+
+ val prefix = ref NONE
+ val database = ref NONE
+ val exe = ref NONE
+ val sql = ref NONE
+ val debug = ref false
+ val profile = ref false
+ val timeout = ref NONE
+ val ffi = ref []
+ val link = ref []
+ val headers = ref []
+ val scripts = ref []
+ val clientToServer = ref []
+ val effectful = ref []
+ val clientOnly = ref []
+ val serverOnly = ref []
+ val jsFuncs = ref []
+ val libs = ref []
+
+ 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),
+ headers = rev (!headers),
+ scripts = rev (!scripts),
+ clientToServer = rev (!clientToServer),
+ effectful = rev (!effectful),
+ clientOnly = rev (!clientOnly),
+ serverOnly = rev (!serverOnly),
+ jsFuncs = rev (!jsFuncs),
+ sources = sources
+ }
+
+ 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 = #prefix old,
+ database = #database old,
+ 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,
+ headers = #headers old @ #headers new,
+ scripts = #scripts old @ #scripts new,
+ clientToServer = #clientToServer old @ #clientToServer new,
+ effectful = #effectful old @ #effectful new,
+ clientOnly = #clientOnly old @ #clientOnly new,
+ serverOnly = #serverOnly old @ #serverOnly new,
+ jsFuncs = #jsFuncs old @ #jsFuncs new,
+ sources = #sources old @ #sources new
+ }
+ in
+ foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
+ end
+
+ fun read () =
+ case TextIO.inputLine inf of
+ NONE => finish []
+ | SOME "\n" => finish (readSources [])
+ | SOME 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] =>
+ (case String.fields (fn ch => ch = #".") f of
+ [m, x] => ((m, x), s)
+ | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
+ (("", ""), "")))
+ | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
+ (("", ""), ""))
+ in
+ case cmd of
+ "prefix" =>
+ (case !prefix of
+ NONE => ()
+ | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
+ prefix := SOME arg)
+ | "database" =>
+ (case !database of
+ NONE => ()
+ | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
+ database := SOME arg)
+ | "exe" =>
+ (case !exe of
+ NONE => ()
+ | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
+ exe := SOME (relify arg))
+ | "sql" =>
+ (case !sql of
+ NONE => ()
+ | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
+ sql := SOME (relify arg))
+ | "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" => link := relifyA arg :: !link
+ | "include" => headers := relifyA arg :: !headers
+ | "script" => scripts := arg :: !scripts
+ | "clientToServer" => clientToServer := ffiS () :: !clientToServer
+ | "effectful" => effectful := ffiS () :: !effectful
+ | "clientOnly" => clientOnly := ffiS () :: !clientOnly
+ | "serverOnly" => serverOnly := ffiS () :: !serverOnly
+ | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
+ | "library" => libs := relify arg :: !libs
+ | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
+ read ()
+ end
+
+ val job = read ()
+ in
+ TextIO.closeIn inf;
+ 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.setClientOnly (#clientOnly job);
+ Settings.setServerOnly (#serverOnly job);
+ Settings.setJsFuncs (#jsFuncs job);
+ job
+ end
+
val parseUrp = {
- func = fn filename =>
- let
- val dir = OS.Path.dir filename
- val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
-
- fun relify fname =
- OS.Path.concat (dir, fname)
- handle OS.Path.Path => fname
-
- val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
-
- fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
-
- fun readSources acc =
- case TextIO.inputLine inf of
- NONE => rev acc
- | SOME 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 = relify fname
- in
- fname :: acc
- end
- in
- readSources acc
- end
-
- val prefix = ref NONE
- val database = ref NONE
- val exe = ref NONE
- val sql = ref NONE
- val debug = ref false
- val profile = ref false
- val timeout = ref NONE
- val ffi = ref []
- val link = ref []
- val headers = ref []
- val scripts = ref []
- val clientToServer = ref []
- val effectful = ref []
- val clientOnly = ref []
- val serverOnly = ref []
- val jsFuncs = ref []
-
- fun finish sources =
- {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),
- headers = rev (!headers),
- scripts = rev (!scripts),
- clientToServer = rev (!clientToServer),
- effectful = rev (!effectful),
- clientOnly = rev (!clientOnly),
- serverOnly = rev (!serverOnly),
- jsFuncs = rev (!jsFuncs),
- sources = sources}
-
- fun read () =
- case TextIO.inputLine inf of
- NONE => finish []
- | SOME "\n" => finish (readSources [])
- | SOME 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] =>
- (case String.fields (fn ch => ch = #".") f of
- [m, x] => ((m, x), s)
- | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
- (("", ""), "")))
- | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
- (("", ""), ""))
- in
- case cmd of
- "prefix" =>
- (case !prefix of
- NONE => ()
- | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
- prefix := SOME arg)
- | "database" =>
- (case !database of
- NONE => ()
- | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
- database := SOME arg)
- | "exe" =>
- (case !exe of
- NONE => ()
- | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
- exe := SOME (relify arg))
- | "sql" =>
- (case !sql of
- NONE => ()
- | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
- sql := SOME (relify arg))
- | "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" => link := relifyA arg :: !link
- | "include" => headers := relifyA arg :: !headers
- | "script" => scripts := arg :: !scripts
- | "clientToServer" => clientToServer := ffiS () :: !clientToServer
- | "effectful" => effectful := ffiS () :: !effectful
- | "clientOnly" => clientOnly := ffiS () :: !clientOnly
- | "serverOnly" => serverOnly := ffiS () :: !serverOnly
- | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
- | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
- read ()
- end
-
- val job = read ()
- in
- TextIO.closeIn inf;
- 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.setClientOnly (#clientOnly job);
- Settings.setServerOnly (#serverOnly job);
- Settings.setJsFuncs (#jsFuncs job);
- job
- end,
+ func = parseUrp',
print = p_job
}