summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/jscomp.sml5
-rw-r--r--src/mono_opt.sml16
-rw-r--r--src/monoize.sml6
-rw-r--r--src/reduce.sml6
4 files changed, 28 insertions, 5 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
index b99a6858..ed913168 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -445,7 +445,7 @@ fun process file =
case p of
Prim.String s =>
str ("\"" ^ String.translate jsChar s ^ "\"")
- | Prim.Char ch => str ("'" ^ jsChar ch ^ "'")
+ | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
| _ => str (Prim.toString p)
end
@@ -1173,7 +1173,8 @@ fun process file =
| EJavaScript (m, e') =>
(foundJavaScript := true;
jsExp m outer (e', st)
- handle CantEmbed _ => (e, st))
+ handle CantEmbed t => ((*Print.preface ("Can't embed", MonoPrint.p_typ MonoEnv.empty t);*)
+ (e, st)))
| ESignalReturn e =>
let
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 5d81d24d..fb6ff264 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -348,6 +348,22 @@ fun exp e =
result = ran}), loc)
end
+ | ECase (discE, pes, {disc, result = (TFun (dom, ran), loc)}) =>
+ let
+ fun doBody (p, e) =
+ let
+ val pb = MonoEnv.patBindsN p
+ in
+ (EApp (MonoEnv.liftExpInExp pb e, (ERel pb, loc)), loc)
+ end
+ in
+ EAbs ("x", dom, ran,
+ (optExp (ECase (MonoEnv.liftExpInExp 0 discE,
+ map (fn (p, e) => (p, doBody (p, e))) pes,
+ {disc = disc,
+ result = ran}), loc), loc))
+ end
+
| EWrite (EQuery {exps, tables, state, query,
initial = (EPrim (Prim.String ""), _),
body = (EStrcat ((EPrim (Prim.String s), _),
diff --git a/src/monoize.sml b/src/monoize.sml
index a5dc3929..5f616c05 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -155,6 +155,12 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
readType (mt env dtmap t, loc)
+ | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc)
+ | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "xform") => (L'.TFfi ("Basis", "string"), loc)
+
| L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
diff --git a/src/reduce.sml b/src/reduce.sml
index cc8ba0fd..eadc8273 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -327,12 +327,12 @@ fun kindConAndExp (namedC, namedE) =
let
(*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
("env", Print.PD.string (e2s env))]*)
- val () = if dangling (edepth env) all then
+ (*val () = if dangling (edepth env) all then
(Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
("env", Print.PD.string (e2s env))];
raise Fail "!")
else
- ()
+ ()*)
val r = case e of
EPrim _ => all
@@ -516,7 +516,7 @@ fun kindConAndExp (namedC, namedE) =
val e1 = exp env e1
val e2 = exp env e2
- val e12 = reassoc (EApp (e1, e2), loc)
+ val e12 = (*reassoc*) (EApp (e1, e2), loc)
in
case #1 e12 of
EApp ((EAbs (_, _, _, b), _), e2) =>