Fix migrated AT support

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index e142418..1998cd2 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -86,6 +86,24 @@ import DynFlags              ( DynFlags(ctxtStkDepth),
        Notes on functional dependencies (a bug)
        --------------------------------------
 
+Consider this:
+
+       class C a b | a -> b
+       class D a b | a -> b
+
+       instance D a b => C a b -- Undecidable 
+                               -- (Not sure if it's crucial to this eg)
+       f :: C a b => a -> Bool
+       f _ = True
+       
+       g :: C a b => a -> Bool
+       g = f
+
+Here f typechecks, but g does not!!  Reason: before doing improvement,
+we reduce the (C a b1) constraint from the call of f to (D a b1).
+
+Here is a more complicated example:
+
 | > class Foo a b | a->b
 | >
 | > class Bar a b | a->b
@@ -257,9 +275,9 @@ any other type variables.
 
 
 
-       --------------------------------------
-               Notes on ambiguity
-       --------------------------------------
+-------------------------------------
+       Note [Ambiguity]
+-------------------------------------
 
 It's very hard to be certain when a type is ambiguous.  Consider
 
@@ -1048,8 +1066,6 @@ tcSimplifyRestricted      -- Used for restricted binding groups
 tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- Zonk everything in sight
   = mappM zonkInst wanteds                     `thenM` \ wanteds' ->
-    zonkTcTyVarsAndFV (varSetElems tau_tvs)    `thenM` \ tau_tvs' ->
-    tcGetGlobalTyVars                          `thenM` \ gbl_tvs' ->
 
        -- 'reduceMe': Reduce as far as we can.  Don't stop at
        -- dicts; the idea is to get rid of as many type
@@ -1058,25 +1074,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- immediately, with no constraint on s.
        --
        -- BUT do no improvement!  See Plan D above
+       -- HOWEVER, some unification may take place, if we instantiate
+       --          a method Inst with an equality constraint
     reduceContextWithoutImprovement 
        doc reduceMe wanteds'           `thenM` \ (_frees, _binds, constrained_dicts) ->
 
        -- Next, figure out the tyvars we will quantify over
+    zonkTcTyVarsAndFV (varSetElems tau_tvs)    `thenM` \ tau_tvs' ->
+    tcGetGlobalTyVars                          `thenM` \ gbl_tvs' ->
+    mappM zonkInst constrained_dicts           `thenM` \ constrained_dicts' ->
     let
-       constrained_tvs = tyVarsOfInsts constrained_dicts
-       qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
-                        `minusVarSet` constrained_tvs
+       constrained_tvs' = tyVarsOfInsts constrained_dicts'
+       qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
+                        `minusVarSet` constrained_tvs'
     in
     traceTc (text "tcSimplifyRestricted" <+> vcat [
-               pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+               pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
                ppr _binds,
-               ppr constrained_tvs, ppr tau_tvs', ppr qtvs ])  `thenM_`
+               ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ])        `thenM_`
 
        -- The first step may have squashed more methods than
        -- necessary, so try again, this time more gently, knowing the exact
        -- set of type variables to quantify over.
        --
-       -- We quantify only over constraints that are captured by qtvs;
+       -- We quantify only over constraints that are captured by qtvs';
        -- these will just be a subset of non-dicts.  This in contrast
        -- to normal inference (using isFreeWhenInferring) in which we quantify over
        -- all *non-inheritable* constraints too.  This implements choice
@@ -1090,7 +1111,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- expose implicit parameters to the test that follows
     let
        is_nested_group = isNotTopLevel top_lvl
-        try_me inst | isFreeWrtTyVars qtvs inst,
+        try_me inst | isFreeWrtTyVars qtvs' inst,
                      (is_nested_group || isDict inst) = Free
                    | otherwise                        = ReduceMe AddSCs
     in
@@ -1101,14 +1122,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- See "Notes on implicit parameters, Question 4: top level"
     if is_nested_group then
        extendLIEs frees        `thenM_`
-        returnM (varSetElems qtvs, binds)
+        returnM (varSetElems qtvs', binds)
     else
        let
            (non_ips, bad_ips) = partition isClassDict frees
        in    
        addTopIPErrs bndrs bad_ips      `thenM_`
        extendLIEs non_ips              `thenM_`
-        returnM (varSetElems qtvs, binds)
+        returnM (varSetElems qtvs', binds)
 \end{code}
 
 
@@ -2451,8 +2472,8 @@ addNoInstanceErrs mb_what givens dicts
                                ptext SLIT("to the") <+> what] ]
 
        fix2 | null instance_dicts = []
-            | otherwise           = [ ptext SLIT("add an instance declaration for")
-                                      <+> pprDictsTheta instance_dicts ]
+            | otherwise           = [ sep [ptext SLIT("add an instance declaration for"),
+                                           pprDictsTheta instance_dicts] ]
        instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)]
                -- Insts for which it is worth suggesting an adding an instance declaration
                -- Exclude implicit parameters, and tyvar dicts