Change monoization of monads to allow partial applications of operations

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)