summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-23 10:14:51 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-23 10:14:51 -0400
commit5232b7e45cf55208a0a3ea41395bb9f87d06dd21 (patch)
tree8afc65ee353c134c317e06064d25e94328af4c3b
parentcabd451f495af6f122b77c61903cc17ee7832d71 (diff)
Change monoization of monads to allow partial applications of operations
-rw-r--r--src/monoize.sml62
-rw-r--r--src/settings.sml3
2 files changed, 38 insertions, 27 deletions
diff --git a/src/monoize.sml b/src/monoize.sml
index bfb95644..19bb1a11 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -95,6 +95,9 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
(L'.TList (mt env dtmap t), loc)
+ | L.CApp ((L.CFfi ("Basis", "monad"), _), _) =>
+ (L'.TRecord [], loc)
+
| L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
let
val t = mt env dtmap t
@@ -1096,18 +1099,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
- (L.EFfi ("Basis", "transaction_monad"), _)) =>
+ | L.EFfi ("Basis", "transaction_monad") => ((L'.ERecord [], loc), fm)
+ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "transaction"), _)), _), t) =>
let
val t = monoType env t
in
- ((L'.EAbs ("x", t,
- (L'.TFun ((L'.TRecord [], loc), t), loc),
- (L'.EAbs ("_", (L'.TRecord [], loc), t,
- (L'.ERel 1, loc)), loc)), loc), fm)
+ ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), t), loc)), loc),
+ (L'.EAbs ("x", t,
+ (L'.TFun ((L'.TRecord [], loc), t), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), t,
+ (L'.ERel 1, loc)), loc)), loc)), loc),
+ fm)
end
- | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
- (L.EFfi ("Basis", "transaction_monad"), _)) =>
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "transaction"), _)), _),
+ t1), _), t2) =>
let
val t1 = monoType env t1
val t2 = monoType env t2
@@ -1115,15 +1120,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val mt1 = (L'.TFun (un, t1), loc)
val mt2 = (L'.TFun (un, t2), loc)
in
- ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
- (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
- (L'.EAbs ("_", un, un,
- (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
- (L'.ERecord [], loc)), loc),
- (L'.EApp (
- (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
- (L'.ERecord [], loc)),
- loc)), loc)), loc)), loc)), loc),
+ ((L'.EAbs ("_", un,
+ (L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc)), loc),
+ (L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
+ (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
+ (L'.EAbs ("_", un, un,
+ (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
+ (L'.ERecord [], loc)), loc),
+ (L'.EApp (
+ (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
+ (L'.ERecord [], loc)),
+ loc)), loc)), loc)), loc)), loc)), loc),
fm)
end
@@ -1213,17 +1220,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EApp (e, (L'.ERecord [], loc)), loc), fm)
end
- | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
- (L.EFfi ("Basis", "signal_monad"), _)) =>
+ | L.EFfi ("Basis", "signal_monad") => ((L'.ERecord [], loc), fm)
+ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), (L.CFfi ("Basis", "signal"), _)), _), t) =>
let
val t = monoType env t
in
- ((L'.EAbs ("x", t, (L'.TSignal t, loc),
- (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
+ ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (t, (L'.TSignal t, loc)), loc),
+ (L'.EAbs ("x", t, (L'.TSignal t, loc),
+ (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc)), loc),
fm)
end
- | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
- (L.EFfi ("Basis", "signal_monad"), _)) =>
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), (L.CFfi ("Basis", "signal"), _)), _),
+ t1), _), t2) =>
let
val t1 = monoType env t1
val t2 = monoType env t2
@@ -1231,9 +1239,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val mt1 = (L'.TSignal t1, loc)
val mt2 = (L'.TSignal t2, loc)
in
- ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
- (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
- (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
+ ((L'.EAbs ("_", un, (L'.TFun (mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc)), loc),
+ (L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
+ (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
+ (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)),
+ loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
diff --git a/src/settings.sml b/src/settings.sml
index bdadb318..9dc6e414 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -148,7 +148,8 @@ val jsFuncsBase = basisM [("alert", "alert"),
("attrifyString", "escape"),
("attrifyInt", "ts"),
("attrifyFloat", "ts"),
- ("attrifyBool", "bs")]
+ ("attrifyBool", "bs"),
+ ("boolToString", "ts")]
val jsFuncs = ref jsFuncsBase
fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
fun jsFunc x = M.find (!jsFuncs, x)