Mercurial > urweb
changeset 820:91f465ded07e
Change monoization of monads to allow partial applications of operations
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 23 May 2009 10:14:51 -0400 |
| parents | cb30dd2ba353 |
| children | 395a5d450cc0 |
| files | src/monoize.sml src/settings.sml |
| diffstat | 2 files changed, 38 insertions(+), 27 deletions(-) [+] |
line wrap: on
line diff
--- a/src/monoize.sml Sat May 23 09:45:02 2009 -0400 +++ b/src/monoize.sml Sat May 23 10:14:51 2009 -0400 @@ -95,6 +95,9 @@ | 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 @@ 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 @@ 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 @@ ((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 @@ 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) =>
--- a/src/settings.sml Sat May 23 09:45:02 2009 -0400 +++ b/src/settings.sml Sat May 23 10:14:51 2009 -0400 @@ -148,7 +148,8 @@ ("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)