summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml563
-rw-r--r--src/especialize.sml7
-rw-r--r--src/jscomp.sml33
-rw-r--r--src/unpoly.sml172
-rw-r--r--src/urweb.grm6
6 files changed, 443 insertions, 342 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 276cb4f2..2f062622 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -77,7 +77,6 @@ signature COMPILER = sig
val termination : (Elab.file, Elab.file) phase
val explify : (Elab.file, Expl.file) phase
val corify : (Expl.file, Core.file) phase
- val especialize : (Core.file, Core.file) phase
val core_untangle : (Core.file, Core.file) phase
val shake : (Core.file, Core.file) phase
val rpcify : (Core.file, Core.file) phase
@@ -107,7 +106,6 @@ signature COMPILER = sig
val toTermination : (string, Elab.file) transform
val toExplify : (string, Expl.file) transform
val toCorify : (string, Core.file) transform
- val toEspecialize : (string, Core.file) transform
val toCore_untangle : (string, Core.file) transform
val toShake1 : (string, Core.file) transform
val toRpcify : (string, Core.file) transform
@@ -118,6 +116,8 @@ signature COMPILER = sig
val toUnpoly : (string, Core.file) transform
val toSpecialize : (string, Core.file) transform
val toShake3 : (string, Core.file) transform
+ val toEspecialize : (string, Core.file) transform
+ val toShake4 : (string, Core.file) transform
val toMarshalcheck : (string, Core.file) transform
val toEffectize : (string, Core.file) transform
val toMonoize : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index f47812ed..b0dfe387 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -267,276 +267,313 @@ fun trim s =
s
end
-fun parseUrp' filename =
+structure M = BinaryMapFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
+
+fun parseUrp' fname =
let
- val dir = OS.Path.dir filename
- val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
+ val pathmap = ref (M.insert (M.empty, "", Config.libUr))
- fun relify fname =
- OS.Path.concat (dir, fname)
- handle OS.Path.Path => fname
+ fun pu filename =
+ let
+ val dir = OS.Path.dir filename
+ val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
- val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
+ 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
+ if Substring.isEmpty after then
+ fname
+ else
+ 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 relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
+ val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
- 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 rewrites = ref []
- val url = ref []
- val mime = 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),
- rewrites = rev (!rewrites),
- filterUrl = rev (!url),
- filterMime = rev (!mime),
- 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,
- rewrites = #rewrites old @ #rewrites new,
- filterUrl = #filterUrl old @ #filterUrl new,
- filterMime = #filterMime old @ #filterMime new,
- sources = #sources new @ #sources old
- }
- in
- foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
- end
+ fun relifyA fname =
+ OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
- 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
- | _ => (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 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
- | "rewrite" =>
+ fun readSources acc =
+ case TextIO.inputLine inf of
+ NONE => rev acc
+ | SOME line =>
let
- fun doit (pkind, from, to) =
+ 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 rewrites = ref []
+ val url = ref []
+ val mime = 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),
+ rewrites = rev (!rewrites),
+ filterUrl = rev (!url),
+ filterMime = rev (!mime),
+ 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,
+ rewrites = #rewrites old @ #rewrites new,
+ filterUrl = #filterUrl old @ #filterUrl new,
+ filterMime = #filterMime old @ #filterMime new,
+ sources = #sources new @ #sources old
+ }
+ in
+ foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
+ 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
+ | _ => (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 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
+ | "rewrite" =>
let
- val pkind = parsePkind pkind
- val (kind, from) = parseFrom from
+ fun doit (pkind, from, to) =
+ let
+ val pkind = parsePkind pkind
+ val (kind, from) = parseFrom from
+ in
+ rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
+ end
in
- rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
+ case String.tokens Char.isSpace arg of
+ [pkind, from, to] => doit (pkind, from, to)
+ | [pkind, from] => doit (pkind, from, "")
+ | _ => ErrorMsg.error "Bad 'rewrite' syntax"
end
- in
- case String.tokens Char.isSpace arg of
- [pkind, from, to] => doit (pkind, from, to)
- | [pkind, from] => doit (pkind, from, "")
- | _ => ErrorMsg.error "Bad 'rewrite' syntax"
+ | "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" => libs := relify arg :: !libs
+ | "path" =>
+ (case String.fields (fn ch => ch = #"=") arg of
+ [n, v] => pathmap := M.insert (!pathmap, n, v)
+ | _ => ErrorMsg.error "path argument not of the form name=value'")
+ | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
+ read ()
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" => libs := relify arg :: !libs
- | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
- read ()
- end
-
- val job = read ()
+
+ 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);
+ Settings.setRewriteRules (#rewrites job);
+ Settings.setUrlRules (#filterUrl job);
+ Settings.setMimeRules (#filterMime job);
+ job
+ end
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);
- Settings.setRewriteRules (#rewrites job);
- Settings.setUrlRules (#filterUrl job);
- Settings.setMimeRules (#filterMime job);
- job
+ pu fname
end
val parseUrp = {
@@ -669,14 +706,12 @@ val especialize = {
print = CorePrint.p_file CoreEnv.empty
}
-val toEspecialize = transform especialize "especialize" o toCorify
-
val core_untangle = {
func = CoreUntangle.untangle,
print = CorePrint.p_file CoreEnv.empty
}
-val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize
+val toCore_untangle = transform core_untangle "core_untangle" o toCorify
val shake = {
func = Shake.shake,
@@ -725,12 +760,16 @@ val toSpecialize = transform specialize "specialize" o toUnpoly
val toShake3 = transform shake "shake3" o toSpecialize
+val toEspecialize = transform especialize "especialize" o toShake3
+
+val toShake4 = transform shake "shake4" o toEspecialize
+
val marshalcheck = {
func = (fn file => (MarshalCheck.check file; file)),
print = CorePrint.p_file CoreEnv.empty
}
-val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake3
+val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake4
val effectize = {
func = Effective.effectize,
diff --git a/src/especialize.sml b/src/especialize.sml
index d1d018ee..03be01b1 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -148,6 +148,13 @@ fun specialize' file =
val functionInside = U.Con.exists {kind = fn _ => false,
con = fn TFun _ => true
| CFfi ("Basis", "transaction") => true
+ | CFfi ("Basis", "eq") => true
+ | CFfi ("Basis", "num") => true
+ | CFfi ("Basis", "ord") => true
+ | CFfi ("Basis", "show") => true
+ | CFfi ("Basis", "read") => true
+ | CFfi ("Basis", "sql_injectable_prim") => true
+ | CFfi ("Basis", "sql_injectable") => true
| _ => false}
val loc = ErrorMsg.dummySpan
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 26558745..d10bfd50 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -400,6 +400,8 @@ fun process file =
else
s
+ val foundJavaScript = ref false
+
fun jsExp mode skip outer =
let
val len = length outer
@@ -662,8 +664,10 @@ fun process file =
let
val args =
case (m, x, args) of
- ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
- | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
+ ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) =>
+ (foundJavaScript := true; [e])
+ | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) =>
+ (foundJavaScript := true; [e1, e2])
| _ => args
val name = case Settings.jsFunc (m, x) of
@@ -871,12 +875,15 @@ fun process file =
str ")"], st)
end
- | EJavaScript (Source _, _, SOME _) => (e, st)
+ | EJavaScript (Source _, _, SOME _) =>
+ (foundJavaScript := true;
+ (e, st))
| EJavaScript (_, _, SOME e) =>
- (strcat [str "cs(function(){return ",
- e,
- str "})"],
- st)
+ (foundJavaScript := true;
+ (strcat [str "cs(function(){return ",
+ e,
+ str "})"],
+ st))
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
@@ -888,6 +895,7 @@ fun process file =
let
val (e, st) = jsE inner (e, st)
in
+ foundJavaScript := true;
(strcat [str "cs(function(){return ",
e,
str "})"],
@@ -995,7 +1003,8 @@ fun process file =
in
case e of
EJavaScript (m, orig, NONE) =>
- doCode m 0 env orig orig
+ (foundJavaScript := true;
+ doCode m 0 env orig orig)
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),
@@ -1031,9 +1040,15 @@ fun process file =
NONE => String.concat (rev acc)
| SOME line => lines (line :: acc)
val lines = lines []
+
+ val script =
+ if !foundJavaScript then
+ lines ^ String.concat (rev (#script st))
+ else
+ ""
in
TextIO.closeIn inf;
- (DJavaScript (lines ^ String.concat (rev (#script st))), ErrorMsg.dummySpan) :: ds
+ (DJavaScript script, ErrorMsg.dummySpan) :: ds
end
end
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 17878508..56406636 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -72,8 +72,19 @@ fun unpolyNamed (xn, rep) =
end
| _ => e}
+structure M = BinaryMapFn(struct
+ type ord_key = con list
+ val compare = Order.joinL U.Con.compare
+ end)
+
+type func = {
+ kinds : kind list,
+ defs : (string * int * con * exp * string) list,
+ replacements : int M.map
+}
+
type state = {
- funcs : (kind list * (string * int * con * exp * string) list) IM.map,
+ funcs : func IM.map,
decls : decl list,
nextName : int
}
@@ -86,8 +97,6 @@ fun exp (e, st : state) =
case e of
ECApp _ =>
let
- (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*)
-
fun unravel (e, cargs) =
case e of
ECApp ((e, _), c) => unravel (e, c :: cargs)
@@ -102,72 +111,101 @@ fun exp (e, st : state) =
else
case IM.find (#funcs st, n) of
NONE => (e, st)
- | SOME (ks, vis) =>
- let
- val (vis, nextName) = ListUtil.foldlMap
- (fn ((x, n, t, e, s), nextName) =>
- ((x, nextName, n, t, e, s), nextName + 1))
- (#nextName st) vis
-
- fun specialize (x, n, n_old, t, e, s) =
- let
- fun trim (t, e, cargs) =
- case (t, e, cargs) of
- ((TCFun (_, _, t), _),
- (ECAbs (_, _, e), _),
- carg :: cargs) =>
- let
- val t = subConInCon (length cargs, carg) t
- val e = subConInExp (length cargs, carg) e
- in
- trim (t, e, cargs)
- end
- | (_, _, []) =>
- let
- val e = foldl (fn ((_, n, n_old, _, _, _), e) =>
- unpolyNamed (n_old, ENamed n) e)
- e vis
- in
- SOME (t, e)
- end
- | _ => NONE
- in
- (*Print.prefaces "specialize"
- [("t", CorePrint.p_con CoreEnv.empty t),
- ("e", CorePrint.p_exp CoreEnv.empty e),
- ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*)
- Option.map (fn (t, e) => (x, n, n_old, t, e, s))
- (trim (t, e, cargs))
- end
-
- val vis = List.map specialize vis
- in
- if List.exists (not o Option.isSome) vis orelse length cargs > length ks then
- (e, st)
- else
- let
- val vis = List.mapPartial (fn x => x) vis
- val vis = map (fn (x, n, n_old, t, e, s) =>
- (x ^ "_unpoly", n, n_old, t, e, s)) vis
- val vis' = map (fn (x, n, _, t, e, s) =>
- (x, n, t, e, s)) vis
-
- val ks' = List.drop (ks, length cargs)
- in
- case List.find (fn (_, _, n_old, _, _, _) => n_old = n) vis of
- NONE => raise Fail "Unpoly: Inconsistent 'val rec' record"
- | SOME (_, n, _, _, _, _) =>
- (ENamed n,
- {funcs = foldl (fn (vi, funcs) =>
- IM.insert (funcs, #2 vi, (ks', vis')))
- (#funcs st) vis',
+ | SOME {kinds = ks, defs = vis, replacements} =>
+ case M.find (replacements, cargs) of
+ SOME n => (ENamed n, st)
+ | NONE =>
+ let
+ val old_vis = vis
+ val (vis, (thisName, nextName)) =
+ ListUtil.foldlMap
+ (fn ((x, n', t, e, s), (thisName, nextName)) =>
+ ((x, nextName, n', t, e, s),
+ (if n' = n then nextName else thisName,
+ nextName + 1)))
+ (0, #nextName st) vis
+
+ fun specialize (x, n, n_old, t, e, s) =
+ let
+ fun trim (t, e, cargs) =
+ case (t, e, cargs) of
+ ((TCFun (_, _, t), _),
+ (ECAbs (_, _, e), _),
+ carg :: cargs) =>
+ let
+ val t = subConInCon (length cargs, carg) t
+ val e = subConInExp (length cargs, carg) e
+ in
+ trim (t, e, cargs)
+ end
+ | (_, _, []) =>
+ (*let
+ val e = foldl (fn ((_, n, n_old, _, _, _), e) =>
+ unpolyNamed (n_old, ENamed n) e)
+ e vis
+ in*)
+ SOME (t, e)
+ (*end*)
+ | _ => NONE
+ in
+ (*Print.prefaces "specialize"
+ [("t", CorePrint.p_con CoreEnv.empty t),
+ ("e", CorePrint.p_exp CoreEnv.empty e),
+ ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*)
+ Option.map (fn (t, e) => (x, n, n_old, t, e, s))
+ (trim (t, e, cargs))
+ end
+
+ val vis = List.map specialize vis
+ in
+ if List.exists (not o Option.isSome) vis orelse length cargs > length ks then
+ (e, st)
+ else
+ let
+ val vis = List.mapPartial (fn x => x) vis
+
+ val vis = map (fn (x, n, n_old, t, e, s) =>
+ (x ^ "_unpoly", n, n_old, t, e, s)) vis
+ val vis' = map (fn (x, n, _, t, e, s) =>
+ (x, n, t, e, s)) vis
+
+ val funcs = IM.insert (#funcs st, n,
+ {kinds = ks,
+ defs = old_vis,
+ replacements = M.insert (replacements,
+ cargs,
+ thisName)})
+
+ val ks' = List.drop (ks, length cargs)
+
+ val st = {funcs = foldl (fn (vi, funcs) =>
+ IM.insert (funcs, #2 vi,
+ {kinds = ks',
+ defs = vis',
+ replacements = M.empty}))
+ funcs vis',
+ decls = #decls st,
+ nextName = nextName}
+
+ val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
+ let
+ val (e, st) = polyExp (e, st)
+ in
+ ((x, n, t, e, s), st)
+ end)
+ st vis'
+ in
+ (ENamed thisName,
+ {funcs = #funcs st,
decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st,
- nextName = nextName})
- end
- end
+ nextName = #nextName st})
+ end
+ end
end
| _ => (e, st)
+and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x
+
fun decl (d, st : state) =
case d of
DValRec (vis as ((x, n, t, e, s) :: rest)) =>
@@ -232,7 +270,9 @@ fun decl (d, st : state) =
(d, st)
else
(d, {funcs = foldl (fn (vi, funcs) =>
- IM.insert (funcs, #2 vi, (cargs, vis)))
+ IM.insert (funcs, #2 vi, {kinds = cargs,
+ defs = vis,
+ replacements = M.empty}))
(#funcs st) vis,
decls = #decls st,
nextName = #nextName st})
diff --git a/src/urweb.grm b/src/urweb.grm
index 1e1fe2ed..4697fef7 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -933,12 +933,12 @@ eexp : eapps (eapps)
| eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
- | eterm DCOLON eexp (let
- val loc = s (etermleft, eexpright)
+ | eapps DCOLON eexp (let
+ val loc = s (eappsleft, eexpright)
in
(EApp ((EVar (["Basis"], "Cons", Infer), loc),
(ERecord [((CName "1", loc),
- eterm),
+ eapps),
((CName "2", loc),
eexp)], loc)), loc)
end)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-02 10:40:16 +0000