diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2008-12-19 10:27:58 -0500 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2008-12-19 10:27:58 -0500 |
| commit | a2854d6b8db55b9c6e69d16262ea182ab9bd307d (patch) | |
| tree | 2ae9890ec2aaa8c2404ce09448a078fec7857bbb /src | |
| parent | ba83ee9a9b3d2539b820c9fcb1cb7cd42226da6c (diff) | |
Monad type class seems to be working
Diffstat (limited to 'src')
| -rw-r--r-- | src/corify.sml | 2 | ||||
| -rw-r--r-- | src/elaborate.sml | 10 | ||||
| -rw-r--r-- | src/monoize.sml | 6 |
3 files changed, 15 insertions, 3 deletions
diff --git a/src/corify.sml b/src/corify.sml index 8bb1a925..2383ee03 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -926,8 +926,10 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = val e = (L.EModProj (m, ms, s), loc) val ef = (L.EModProj (basis, [], "bind"), loc) + val ef = (L.ECApp (ef, (L.CModProj (basis, [], "transaction"), loc)), loc) val ef = (L.ECApp (ef, ran'), loc) val ef = (L.ECApp (ef, ran), loc) + val ef = (L.EApp (ef, (L.EModProj (basis, [], "transaction_monad"), loc)), loc) val ef = (L.EApp (ef, (L.EApp (e, (L.ERel 0, loc)), loc)), loc) val eat = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), diff --git a/src/elaborate.sml b/src/elaborate.sml index 05e08c81..c18cfb49 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3548,7 +3548,15 @@ fun elabFile basis topStr topSgn env file = ("c1", p_con env c1), ("c2", p_con env c2)]; raise Fail "Unresolved constraint in top.ur")) - | TypeClass _ => raise Fail "Unresolved type class constraint in top.ur") gs + | TypeClass (env, c, r, loc) => + let + val c = normClassKey env c + in + case E.resolveClass env c of + SOME e => r := SOME e + | NONE => expError env (Unresolvable (loc, c)) + end) gs + val () = subSgn (env', D.empty) topSgn' topSgn val (env', top_n) = E.pushStrNamed env' "Top" topSgn diff --git a/src/monoize.sml b/src/monoize.sml index 1880c57d..1c4aa81b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -934,7 +934,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), + (L.EFfi ("Basis", "transaction_monad"), _)) => let val t = monoType env t in @@ -943,7 +944,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), t, (L'.ERel 1, loc)), loc)), loc), fm) end - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) => + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "transaction_monad"), _)) => let val t1 = monoType env t1 val t2 = monoType env t2 |