Remove cc_ty from CIrredCan and cc_hole_ty from CHoleCan

A simple refactoring with no complicated fiddling.

9 files changed, 59 insertions, 57 deletions

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 34118c4ea6..11bfbe0cf2 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -517,12 +517,13 @@ hasEqualities givens = any (has_eq . evVarPred) givens
 
 ---------------- Getting free tyvars -------------------------
 tyVarsOfCt :: Ct -> TcTyVarSet
+-- NB: the 
 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
 tyVarsOfCt (CDictCan { cc_tyargs = tys }) 	        = tyVarsOfTypes tys
-tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
-tyVarsOfCt (CHoleCan { cc_hole_ty = ty })               = tyVarsOfType ty
-tyVarsOfCt (CNonCanonical { cc_ev = fl })               = tyVarsOfType (ctEvPred fl)
+tyVarsOfCt (CIrredEvCan { cc_ev = ev })                 = tyVarsOfType (ctEvPred ev)
+tyVarsOfCt (CHoleCan { cc_ev = ev })                    = tyVarsOfType (ctEvPred ev)
+tyVarsOfCt (CNonCanonical { cc_ev = ev })               = tyVarsOfType (ctEvPred ev)
 
 tyVarsOfCts :: Cts -> TcTyVarSet
 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
@@ -551,18 +552,19 @@ tidyCt :: TidyEnv -> Ct -> Ct
 -- Also converts it to non-canonical
 tidyCt env ct 
   = case ct of
-     CHoleCan {} -> ct { cc_ev = tidy_flavor env (cc_ev ct) }
-     _ -> CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
+     CHoleCan { cc_ev = ev }
+       -> ct { cc_ev = tidy_ev env ev }
+     _ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct)
                         , cc_loc  = cc_loc ct }
   where 
-    tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
+    tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
      -- NB: we do not tidy the ctev_evtm/var field because we don't 
      --     show it in error messages
-    tidy_flavor env ctev@(CtGiven { ctev_pred = pred })
+    tidy_ev env ctev@(CtGiven { ctev_pred = pred })
       = ctev { ctev_pred = tidyType env pred }
-    tidy_flavor env ctev@(CtWanted { ctev_pred = pred })
+    tidy_ev env ctev@(CtWanted { ctev_pred = pred })
       = ctev { ctev_pred = tidyType env pred }
-    tidy_flavor env ctev@(CtDerived { ctev_pred = pred })
+    tidy_ev env ctev@(CtDerived { ctev_pred = pred })
       = ctev { ctev_pred = tidyType env pred }
 
 tidyEvVar :: TidyEnv -> EvVar -> EvVar
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index d972e2ea85..e755d69c6b 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -192,12 +192,10 @@ canonicalize (CFunEqCan { cc_loc = d
     canEqLeafFunEq d ev (fn,xis1) xi2
 
 canonicalize (CIrredEvCan { cc_ev = ev
-                          , cc_loc = d
-                          , cc_ty = xi })
-  = canIrred d ev xi
-canonicalize ct@(CHoleCan {})
-  = do { emitInsoluble ct
-       ; return Stop }
+                          , cc_loc = d })
+  = canIrred d ev
+canonicalize (CHoleCan { cc_ev = ev, cc_loc = d })
+  = canHole d ev
 
 canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue
 -- Called only for non-canonical EvVars 
@@ -205,8 +203,8 @@ canEvNC d ev
   = case classifyPredType (ctEvPred ev) of
       ClassPred cls tys -> canClassNC d ev cls tys 
       EqPred ty1 ty2    -> canEqNC    d ev ty1 ty2 
-      IrredPred ev_ty   -> canIrred   d ev ev_ty
       TuplePred tys     -> canTuple   d ev tys
+      IrredPred {}      -> canIrred   d ev 
 \end{code}
 
 
@@ -388,24 +386,35 @@ is_improvement_pty ty = go (classifyPredType ty)
 
 
 \begin{code}
-canIrred :: CtLoc -> CtEvidence -> TcType -> TcS StopOrContinue
+canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue
 -- Precondition: ty not a tuple and no other evidence form
-canIrred d ev ty 
-  = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
+canIrred d ev
+  = do { let ty = ctEvPred ev
+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
        ; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
        ; let no_flattening = xi `eqType` ty 
-                             -- In this particular case it is not safe to 
-                             -- say 'isTcReflCo' because the new constraint may
-                             -- be reducible!
+             -- We can't use isTcReflCo, because even if the coercion is
+             -- Refl, the output type might have had a substitution 
+             -- applied to it.  For example  'a' might now be 'C b'
+
+       ; if no_flattening then
+           continueWith $
+           CIrredEvCan { cc_ev = ev, cc_loc = d }
+         else do
+       { mb <- rewriteCtFlavor ev xi co 
+       ; case mb of
+             Just new_ev -> canEvNC d new_ev  -- Re-classify and try again
+             Nothing     -> return Stop } }   -- Found a cached copy
+
+canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue
+canHole d ev 
+  = do { let ty = ctEvPred ev
+       ; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
        ; mb <- rewriteCtFlavor ev xi co 
        ; case mb of
-             Just new_ev 
-               | no_flattening
-                 -> continueWith $
-                    CIrredEvCan { cc_ev = new_ev, cc_ty = xi, cc_loc = d }
-               | otherwise
-                 -> canEvNC d new_ev
-             Nothing -> return Stop }
+             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d})
+             Nothing     -> return ()   -- Found a cached copy; won't happen
+       ; return Stop } 
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index cec65dea00..010c499829 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -493,7 +493,7 @@ mkHoleError ctxt ct@(CHoleCan {})
   = do { let tyvars = varSetElems (tyVarsOfCt ct)
              tyvars_msg = map loc_msg tyvars
              msg = (text "Found hole" <+> quotes (text "_") 
-                    <+> text "with type") <+> pprType (cc_hole_ty ct)
+                    <+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
                    $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
        ; (ctxt, binds_doc) <- relevantBindings ctxt ct
        ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 0b0eddc266..eb18764100 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -236,7 +236,7 @@ tcExpr HsHole res_ty
       ; traceTc "tcExpr.HsHole" (ppr ty)
       ; ev <- mkSysLocalM (mkFastString "_") ty
       ; loc <- getCtLoc HoleOrigin
-      ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_hole_ty = ty, cc_loc = loc }
+      ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc }
       ; traceTc "tcExpr.HsHole emitting" (ppr can)
       ; emitInsoluble can
       ; tcWrapResult (HsVar ev) ty res_ty }
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 662e47aeb7..3c6791818b 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -714,9 +714,9 @@ doInteractWithInert inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyarg
 -- we can rewrite them. We can never improve using this: 
 -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not 
 -- mean that (ty1 ~ ty2)
-doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 })
-           workItem@(CIrredEvCan { cc_ty = ty2 })
-  | ty1 `eqType` ty2
+doInteractWithInert (CIrredEvCan { cc_ev = ifl })
+           workItem@(CIrredEvCan { cc_ev = wfl })
+  | ctEvPred ifl `eqType` ctEvPred wfl
   = solveOneFromTheOther "Irred/Irred" ifl workItem
 
 doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 15cfdd4690..c9be731bf7 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -727,13 +727,13 @@ variables.
 
 \begin{code}
 zonkCt :: Ct -> TcM Ct
+zonkCt ct@(CHoleCan { cc_ev = ev })
+  = do { ev' <- zonkCtEvidence ev
+       ; return $ ct { cc_ev = ev' } }
 zonkCt ct
-  | isHoleCt ct = do { fl' <- zonkCtEvidence (cc_ev ct)
-                     ; return $ ct { cc_ev = fl' } }
-  | otherwise   = do { fl' <- zonkCtEvidence (cc_ev ct)
-                     ; return $
-                         CNonCanonical { cc_ev = fl'
-                                       , cc_loc = cc_loc ct } }
+  = do { fl' <- zonkCtEvidence (cc_ev ct)
+       ; return (CNonCanonical { cc_ev = fl'
+                               , cc_loc = cc_loc ct }) }
 
 zonkCtEvidence :: CtEvidence -> TcM CtEvidence
 zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index e72fda6062..1e93ec4eec 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -530,7 +530,9 @@ a bit complicated:
 	let x = 3 in
 	proc y -> (proc z -> e1) -< e2
 
-Here, x and z are in scope in e1, but y is not.  We implement this by
+Here, x and z are in scope in e1, but y is not.  
+
+We implement this by
 recording the environment when passing a proc (using newArrowScope),
 and returning to that (using escapeArrowScope) on the left of -< and the
 head of (|..|).
@@ -860,7 +862,8 @@ data Ct
 
   | CIrredEvCan {  -- These stand for yet-unknown predicates
       cc_ev :: CtEvidence,   -- See Note [Ct/evidence invariant]
-      cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin)
+                   -- In CIrredEvCan, the ctev_pred of the evidence is flat 
+                   -- and hence it may only be of the form (tv xi1 xi2 ... xin)
                    -- Since, if it were a type constructor application, that'd make the
                    -- whole constraint a CDictCan, or CTyEqCan. And it can't be
                    -- a type family application either because it's a Xi type.
@@ -898,9 +901,8 @@ data Ct
     }
 
   | CHoleCan {
-      cc_ev       :: CtEvidence,
-      cc_hole_ty  :: TcTauType, -- Not a Xi! See same not as above
-      cc_loc      :: CtLoc
+      cc_ev  :: CtEvidence,
+      cc_loc :: CtLoc
     }
 \end{code}
 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 89706cd512..7c968e0735 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -867,7 +867,7 @@ lookupInInertCans ics pty
 
       IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics)
     
-      _other -> Nothing -- NB: No caching for IPs
+      _other -> Nothing -- NB: No caching for IPs or holes
 \end{code}
 
 
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 00fce7267e..583eb56c89 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -195,17 +195,6 @@ calcClassCycles cls
     expandTheta _    _    []           = id
     expandTheta seen path (pred:theta) = expandType seen path pred . expandTheta seen path theta
 
-    {-
-    expandTree seen path (ClassPred cls tys)
-      | cls `elemUniqSet` seen = 
-      | otherwise              = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path) 
-                                             (substTysWith (classTyVars cls) tys (classSCTheta cls))
-    expandTree seen path (TuplePred ts)      = flip (foldr (expandTree seen path)) ts
-    expandTree _    _    (EqPred _ _)        = id
-    expandTree _    _    (IPPred _ _)        = id
-    expandTree seen path (IrredPred pred)    = expandType seen path pred
-    -}
-
     expandType seen path (TyConApp tc tys)
       -- Expand unsaturated classes to their superclass theta if they are yet unseen.
       -- If they have already been seen then we have detected an error!