Large refactor: Move CtLoc field from Ct to CtEvidence

9 files changed, 303 insertions, 317 deletions

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index db49902b81..e26d921953 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -83,7 +83,8 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
 emitWanted origin pred 
   = do { loc <- getCtLoc origin
        ; ev  <- newWantedEvVar pred
-       ; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev }))
+       ; emitFlat $ mkNonCanonical $
+             CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
        ; return ev }
 
 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
@@ -568,8 +569,7 @@ tidyCt env ct
   = case ct of
      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 }
+     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
   where 
     tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
      -- NB: we do not tidy the ctev_evtm/var field because we don't 
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 90780a7252..3c81c34c53 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -157,46 +157,42 @@ EvBinds, so we are again good.
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 canonicalize :: Ct -> TcS StopOrContinue
-canonicalize ct@(CNonCanonical { cc_ev = ev, cc_loc  = d })
+canonicalize ct@(CNonCanonical { cc_ev = ev })
   = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
        ; {-# SCC "canEvVar" #-}
-         canEvNC d ev }
+         canEvNC ev }
 
-canonicalize (CDictCan { cc_loc  = d
-                       , cc_ev = ev
+canonicalize (CDictCan { cc_ev = ev
                        , cc_class  = cls
                        , cc_tyargs = xis })
   = {-# SCC "canClass" #-}
-    canClass d ev cls xis -- Do not add any superclasses
-canonicalize (CTyEqCan { cc_loc  = d
-                       , cc_ev = ev
+    canClass ev cls xis -- Do not add any superclasses
+canonicalize (CTyEqCan { cc_ev = ev
                        , cc_tyvar  = tv
                        , cc_rhs    = xi })
   = {-# SCC "canEqLeafTyVarEq" #-}
-    canEqLeafTyVar d ev tv xi
+    canEqLeafTyVar ev tv xi
 
-canonicalize (CFunEqCan { cc_loc = d
-                        , cc_ev = ev
+canonicalize (CFunEqCan { cc_ev = ev
                         , cc_fun    = fn
                         , cc_tyargs = xis1
                         , cc_rhs    = xi2 })
   = {-# SCC "canEqLeafFunEq" #-}
-    canEqLeafFun d ev fn xis1 xi2
+    canEqLeafFun ev fn xis1 xi2
 
-canonicalize (CIrredEvCan { cc_ev = ev
-                          , cc_loc = d })
-  = canIrred d ev
-canonicalize (CHoleCan { cc_ev = ev, cc_loc = d, cc_occ = occ })
-  = canHole d ev occ
+canonicalize (CIrredEvCan { cc_ev = ev })
+  = canIrred ev
+canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ })
+  = canHole ev occ
 
-canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue
+canEvNC :: CtEvidence -> TcS StopOrContinue
 -- Called only for non-canonical EvVars
-canEvNC d ev
+canEvNC ev
   = case classifyPredType (ctEvPred ev) of
-      ClassPred cls tys -> traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) >> canClassNC d ev cls tys
-      EqPred ty1 ty2    -> traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)   >> canEqNC    d ev ty1 ty2
-      TuplePred tys     -> traceTcS "canEvNC:tup" (ppr tys)             >> canTuple   d ev tys
-      IrredPred {}      -> traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) >> canIrred   d ev
+      ClassPred cls tys -> traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) >> canClassNC ev cls tys
+      EqPred ty1 ty2    -> traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)   >> canEqNC    ev ty1 ty2
+      TuplePred tys     -> traceTcS "canEvNC:tup" (ppr tys)             >> canTuple   ev tys
+      IrredPred {}      -> traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) >> canIrred   ev
 \end{code}
 
 
@@ -207,13 +203,13 @@ canEvNC d ev
 %************************************************************************
 
 \begin{code}
-canTuple :: CtLoc -> CtEvidence -> [PredType] -> TcS StopOrContinue
-canTuple d ev tys
+canTuple :: CtEvidence -> [PredType] -> TcS StopOrContinue
+canTuple ev tys
   = do { traceTcS "can_pred" (text "TuplePred!")
        ; let xcomp = EvTupleMk
              xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..]
        ; ctevs <- xCtFlavor ev tys (XEvTerm xcomp xdecomp)
-       ; canEvVarsCreated d ctevs }
+       ; canEvVarsCreated ctevs }
 \end{code}
 
 %************************************************************************
@@ -224,8 +220,7 @@ canTuple d ev tys
 
 \begin{code}
 canClass, canClassNC
-   :: CtLoc
-   -> CtEvidence
+   :: CtEvidence
    -> Class -> [Type] -> TcS StopOrContinue
 -- Precondition: EvVar is class evidence
 
@@ -234,12 +229,12 @@ canClass, canClassNC
 -- for already-canonical class constraints (but which might have
 -- been subsituted or somthing), and hence do not need superclasses
 
-canClassNC d ev cls tys
-  = canClass d ev cls tys
+canClassNC ev cls tys
+  = canClass ev cls tys
     `andWhenContinue` emitSuperclasses
 
-canClass d ev cls tys
-  = do { (xis, cos) <- flattenMany d FMFullFlatten ev tys
+canClass ev cls tys
+  = do { (xis, cos) <- flattenMany FMFullFlatten ev tys
        ; let co = mkTcTyConAppCo (classTyCon cls) cos
              xi = mkClassPred cls xis
        ; mb <- rewriteCtFlavor ev xi co
@@ -248,15 +243,14 @@ canClass d ev cls tys
        ; case mb of
            Nothing -> return Stop
            Just new_ev -> continueWith $
-                          CDictCan { cc_ev = new_ev, cc_loc = d
+                          CDictCan { cc_ev = new_ev
                                    , cc_tyargs = xis, cc_class = cls } }
 
 emitSuperclasses :: Ct -> TcS StopOrContinue
-emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev
-                              , cc_tyargs = xis_new, cc_class = cls })
+emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls })
             -- Add superclasses of this one here, See Note [Adding superclasses].
             -- But only if we are not simplifying the LHS of a rule.
- = do { newSCWorkFromFlavored d ev cls xis_new
+ = do { newSCWorkFromFlavored ev cls xis_new
       -- Arguably we should "seq" the coercions if they are derived,
       -- as we do below for emit_kind_constraint, to allow errors in
       -- superclasses to be executed if deferred to runtime!
@@ -328,10 +322,9 @@ By adding superclasses definitely only once, during canonicalisation, this situa
 happen.
 
 \begin{code}
-newSCWorkFromFlavored :: CtLoc -- Depth
-                      -> CtEvidence -> Class -> [Xi] -> TcS ()
+newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS ()
 -- Returns superclasses, see Note [Adding superclasses]
-newSCWorkFromFlavored d flavor cls xis
+newSCWorkFromFlavored flavor cls xis
   | isDerived flavor
   = return ()  -- Deriveds don't yield more superclasses because we will
                -- add them transitively in the case of wanteds.
@@ -342,7 +335,7 @@ newSCWorkFromFlavored d flavor cls xis
              xev = XEvTerm { ev_comp   = panic "Can't compose for given!"
                            , ev_decomp = xev_decomp }
        ; ctevs <- xCtFlavor flavor sc_theta xev
-       ; emitWorkNC d ctevs }
+       ; emitWorkNC ctevs }
 
   | isEmptyVarSet (tyVarsOfTypes xis)
   = return () -- Wanteds with no variables yield no deriveds.
@@ -351,9 +344,10 @@ newSCWorkFromFlavored d flavor cls xis
   | otherwise -- Wanted case, just add those SC that can lead to improvement.
   = do { let sc_rec_theta = transSuperClasses cls xis
              impr_theta   = filter is_improvement_pty sc_rec_theta
+             loc          = ctev_loc flavor
        ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
-       ; mb_der_evs <- mapM newDerived impr_theta
-       ; emitWorkNC d (catMaybes mb_der_evs) }
+       ; mb_der_evs <- mapM (newDerived loc) impr_theta
+       ; emitWorkNC (catMaybes mb_der_evs) }
 
 is_improvement_pty :: PredType -> Bool
 -- Either it's an equality, or has some functional dependency
@@ -375,12 +369,12 @@ is_improvement_pty ty = go (classifyPredType ty)
 
 
 \begin{code}
-canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue
+canIrred :: CtEvidence -> TcS StopOrContinue
 -- Precondition: ty not a tuple and no other evidence form
-canIrred d old_ev
+canIrred old_ev
   = do { let old_ty = ctEvPred old_ev
        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)
-       ; (xi,co) <- flatten d FMFullFlatten old_ev old_ty -- co :: xi ~ old_ty
+       ; (xi,co) <- flatten FMFullFlatten old_ev old_ty -- co :: xi ~ old_ty
        ; mb <- rewriteCtFlavor old_ev xi co
        ; case mb of {
              Nothing     -> return Stop ;
@@ -388,12 +382,12 @@ canIrred d old_ev
 
     do { -- Re-classify, in case flattening has improved its shape
        ; case classifyPredType (ctEvPred new_ev) of
-           ClassPred cls tys -> canClassNC d new_ev cls tys
-           TuplePred tys     -> canTuple   d new_ev tys
+           ClassPred cls tys -> canClassNC new_ev cls tys
+           TuplePred tys     -> canTuple   new_ev tys
            EqPred ty1 ty2
-              | something_changed old_ty ty1 ty2 -> canEqNC d new_ev ty1 ty2
+              | something_changed old_ty ty1 ty2 -> canEqNC new_ev ty1 ty2
            _  -> continueWith $
-                 CIrredEvCan { cc_ev = new_ev, cc_loc = d } } } }
+                 CIrredEvCan { cc_ev = new_ev } } } }
   where
     -- If the constraint was a kind-mis-matched equality, we must
     -- retry canEqNC only if something has changed, otherwise we
@@ -407,13 +401,13 @@ canIrred d old_ev
        | otherwise
        = True
 
-canHole :: CtLoc -> CtEvidence -> OccName -> TcS StopOrContinue
-canHole d ev occ
+canHole :: CtEvidence -> OccName -> TcS StopOrContinue
+canHole ev occ
   = do { let ty = ctEvPred ev
-       ; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
+       ; (xi,co) <- flatten FMFullFlatten ev ty -- co :: xi ~ ty
        ; mb <- rewriteCtFlavor ev xi co
        ; case mb of
-             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d, cc_occ = occ })
+             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ })
              Nothing     -> return ()   -- Found a cached copy; won't happen
        ; return Stop }
 \end{code}
@@ -469,7 +463,7 @@ unexpanded synonym.
 data FlattenMode = FMSubstOnly | FMFullFlatten
 
 -- Flatten a bunch of types all at once.
-flattenMany :: CtLoc -> FlattenMode
+flattenMany ::  FlattenMode
             -> CtEvidence
             -> [Type] -> TcS ([Xi], [TcCoercion])
 -- Coercions :: Xi ~ Type
@@ -477,46 +471,46 @@ flattenMany :: CtLoc -> FlattenMode
 -- NB: The EvVar inside the 'ctxt :: CtEvidence' is unused,
 --     we merely want (a) Given/Solved/Derived/Wanted info
 --                    (b) the GivenLoc/WantedLoc for when we create new evidence
-flattenMany d f ctxt tys
+flattenMany f ctxt tys
   = -- pprTrace "flattenMany" empty $
     go tys
   where go []       = return ([],[])
-        go (ty:tys) = do { (xi,co)    <- flatten d f ctxt ty
+        go (ty:tys) = do { (xi,co)    <- flatten f ctxt ty
                          ; (xis,cos)  <- go tys
                          ; return (xi:xis,co:cos) }
 
 -- Flatten a type to get rid of type function applications, returning
 -- the new type-function-free type, and a collection of new equality
 -- constraints.  See Note [Flattening] for more detail.
-flatten :: CtLoc -> FlattenMode
+flatten :: FlattenMode
         -> CtEvidence -> TcType -> TcS (Xi, TcCoercion)
 -- Postcondition: Coercion :: Xi ~ TcType
-flatten loc f ctxt ty
+flatten f ctxt ty
   | Just ty' <- tcView ty
-  = do { (xi, co) <- flatten loc f ctxt ty'
-       ; if tcEqType xi ty then return (ty,co) else return (xi,co) }
+  = do { (xi, co) <- flatten f ctxt ty'
+       ; if eqType xi ty then return (ty,co) else return (xi,co) }
        -- Small tweak for better error messages
 
-flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
+flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
 
-flatten loc f ctxt (TyVarTy tv)
-  = flattenTyVar loc f ctxt tv
+flatten f ctxt (TyVarTy tv)
+  = flattenTyVar f ctxt tv
 
-flatten loc f ctxt (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten loc f ctxt ty1
-       ; (xi2,co2) <- flatten loc f ctxt ty2
+flatten f ctxt (AppTy ty1 ty2)
+  = do { (xi1,co1) <- flatten f ctxt ty1
+       ; (xi2,co2) <- flatten f ctxt ty2
        ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
 
-flatten loc f ctxt (FunTy ty1 ty2)
-  = do { (xi1,co1) <- flatten loc f ctxt ty1
-       ; (xi2,co2) <- flatten loc f ctxt ty2
+flatten f ctxt (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten f ctxt ty1
+       ; (xi2,co2) <- flatten f ctxt ty2
        ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) }
 
-flatten loc f ctxt (TyConApp tc tys)
+flatten f ctxt (TyConApp tc tys)
   -- For a normal type constructor or data family application, we just
   -- recursively flatten the arguments.
   | not (isSynFamilyTyCon tc)
-    = do { (xis,cos) <- flattenMany loc f ctxt tys
+    = do { (xis,cos) <- flattenMany f ctxt tys
          ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) }
 
   -- Otherwise, it's a type function application, and we have to
@@ -524,7 +518,7 @@ flatten loc f ctxt (TyConApp tc tys)
   -- between the application and a newly generated flattening skolem variable.
   | otherwise
   = ASSERT( tyConArity tc <= length tys )       -- Type functions are saturated
-      do { (xis, cos) <- flattenMany loc f ctxt tys
+      do { (xis, cos) <- flattenMany f ctxt tys
          ; let (xi_args,  xi_rest)  = splitAt (tyConArity tc) xis
                (cos_args, cos_rest) = splitAt (tyConArity tc) cos
                  -- The type function might be *over* saturated
@@ -549,7 +543,7 @@ flatten loc f ctxt (TyConApp tc tys)
                              -- cache as well when we interact an equality with the inert.
                              -- The design choice is: do we keep the flat cache rewritten or not?
                              -- For now I say we don't keep it fully rewritten.
-                            do { (rhs_xi,co) <- flatten loc f ctev rhs_ty
+                            do { (rhs_xi,co) <- flatten f ctev rhs_ty
                                ; let final_co = evTermCoercion (ctEvTerm ctev)
                                                 `mkTcTransCo` mkTcSymCo co
                                ; traceTcS "flatten/flat-cache hit" $ (ppr ctev $$ ppr rhs_xi $$ ppr final_co)
@@ -559,8 +553,7 @@ flatten loc f ctxt (TyConApp tc tys)
                                 ; let ct = CFunEqCan { cc_ev     = ctev
                                                      , cc_fun    = tc
                                                      , cc_tyargs = xi_args
-                                                     , cc_rhs    = rhs_xi
-                                                     , cc_loc    = loc }
+                                                     , cc_rhs    = rhs_xi }
                                 ; updWorkListTcS $ extendWorkListFunEq ct
                                 ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr rhs_xi $$ ppr ctev)
                                 ; return (evTermCoercion (ctEvTerm ctev), rhs_xi) }
@@ -573,11 +566,11 @@ flatten loc f ctxt (TyConApp tc tys)
                   )
          }
 
-flatten loc _f ctxt ty@(ForAllTy {})
+flatten _f ctxt ty@(ForAllTy {})
 -- We allow for-alls when, but only when, no type function
 -- applications inside the forall involve the bound type variables.
   = do { let (tvs, rho) = splitForAllTys ty
-       ; (rho', co) <- flatten loc FMSubstOnly ctxt rho
+       ; (rho', co) <- flatten FMSubstOnly ctxt rho
                          -- Substitute only under a forall
                          -- See Note [Flattening under a forall]
        ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
@@ -602,27 +595,26 @@ and we have not begun to think about how to make that work!
 
 \begin{code}
 flattenTyVar, flattenFinalTyVar
-        :: CtLoc -> FlattenMode
-        -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion)
+        :: FlattenMode -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion)
 -- "Flattening" a type variable means to apply the substitution to it
 -- The substitution is actually the union of the substitution in the TyBinds
 -- for the unification variables that have been unified already with the inert
 -- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract.
-flattenTyVar loc f ctxt tv
+flattenTyVar f ctxt tv
   | not (isTcTyVar tv)                -- Happens when flatten under a (forall a. ty)
-  = flattenFinalTyVar loc f ctxt tv   -- So ty contains referneces to the non-TcTyVar a
+  = flattenFinalTyVar f ctxt tv   -- So ty contains referneces to the non-TcTyVar a
   | otherwise
   = do { mb_ty <- isFilledMetaTyVar_maybe tv
        ; case mb_ty of {
            Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty)
-                         ; flatten loc f ctxt ty } ;
+                         ; flatten f ctxt ty } ;
            Nothing ->
 
     -- Try in ty_binds
     do { ty_binds <- getTcSTyBindsMap
        ; case lookupVarEnv ty_binds tv of {
            Just (_tv,ty) -> do { traceTcS "Following bound tyvar" (ppr tv <+> equals <+> ppr ty)
-                               ; flatten loc f ctxt ty } ;
+                               ; flatten f ctxt ty } ;
                  -- NB: ty_binds coercions are all ReflCo,
                  -- so no need to transitively compose co' with another coercion,
                  -- unlike in 'flatten_from_inerts'
@@ -634,19 +626,19 @@ flattenTyVar loc f ctxt tv
        ; case mco of {
            Just (co,ty) ->
              do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr ty)
-                ; (ty_final,co') <- flatten loc f ctxt ty
+                ; (ty_final,co') <- flatten f ctxt ty
                 ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } ;
        -- NB recursive call.
        -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants]
        -- In fact, because of flavors, it couldn't possibly be idempotent,
        -- this is explained in Note [Non-idempotent inert substitution]
 
-           Nothing -> flattenFinalTyVar loc f ctxt tv
+           Nothing -> flattenFinalTyVar f ctxt tv
     } } } } } }
   where
     tv_eq_subst subst tv
        | Just (ct:_) <- lookupVarEnv subst tv   -- If the first doesn't work, the
-       , let ctev = cc_ev ct                    -- subsequent ones won't either
+       , let ctev = ctEvidence ct               -- subsequent ones won't either
              rhs  = cc_rhs ct
        , ctev `canRewrite` ctxt
        = Just (evTermCoercion (ctEvTerm ctev), rhs)
@@ -654,10 +646,10 @@ flattenTyVar loc f ctxt tv
               -- touch the actual coercion so we are fine.
        | otherwise = Nothing
 
-flattenFinalTyVar loc f ctxt tv
+flattenFinalTyVar f ctxt tv
   = -- Done, but make sure the kind is zonked
     do { let knd = tyVarKind tv
-       ; (new_knd, _kind_co) <- flatten loc f ctxt knd
+       ; (new_knd, _kind_co) <- flatten f ctxt knd
        ; let ty = mkTyVarTy (setVarType tv new_knd)
        ; return (ty, mkTcReflCo ty) }
 \end{code}
@@ -698,25 +690,25 @@ Insufficient (non-recursive) rewriting was the reason for #5668.
 %************************************************************************
 
 \begin{code}
-canEvVarsCreated :: CtLoc -> [CtEvidence] -> TcS StopOrContinue
-canEvVarsCreated _loc [] = return Stop
+canEvVarsCreated :: [CtEvidence] -> TcS StopOrContinue
+canEvVarsCreated [] = return Stop
     -- Add all but one to the work list
     -- and return the first (if any) for futher processing
-canEvVarsCreated loc (ev : evs)
-  = do { emitWorkNC loc evs; canEvNC loc ev }
+canEvVarsCreated (ev : evs)
+  = do { emitWorkNC evs; canEvNC ev }
           -- Note the "NC": these are fresh goals, not necessarily canonical
 
-emitWorkNC :: CtLoc -> [CtEvidence] -> TcS ()
-emitWorkNC loc evs
+emitWorkNC :: [CtEvidence] -> TcS ()
+emitWorkNC evs
   | null evs  = return ()
   | otherwise = updWorkListTcS (extendWorkListCts (map mk_nc evs))
   where
-    mk_nc ev = CNonCanonical { cc_ev = ev, cc_loc = loc }
+    mk_nc ev = mkNonCanonical ev
 
 -------------------------
-canEqNC :: CtLoc -> CtEvidence -> Type -> Type -> TcS StopOrContinue
+canEqNC :: CtEvidence -> Type -> Type -> TcS StopOrContinue
 
-canEqNC _loc ev ty1 ty2
+canEqNC ev ty1 ty2
   | tcEqType ty1 ty2      -- Dealing with equality here avoids
                           -- later spurious occurs checks for a~a
   = if isWanted ev then
@@ -727,36 +719,36 @@ canEqNC _loc ev ty1 ty2
 -- If one side is a variable, orient and flatten,
 -- WITHOUT expanding type synonyms, so that we tend to
 -- substitute a ~ Age rather than a ~ Int when @type Age = Int@
-canEqNC loc ev ty1@(TyVarTy {}) ty2
-  = canEqLeaf loc ev ty1 ty2
-canEqNC loc ev ty1 ty2@(TyVarTy {})
-  = canEqLeaf loc ev ty1 ty2
+canEqNC ev ty1@(TyVarTy {}) ty2
+  = canEqLeaf ev ty1 ty2
+canEqNC ev ty1 ty2@(TyVarTy {})
+  = canEqLeaf ev ty1 ty2
 
 -- See Note [Naked given applications]
-canEqNC loc ev ty1 ty2
-  | Just ty1' <- tcView ty1 = canEqNC loc ev ty1' ty2
-  | Just ty2' <- tcView ty2 = canEqNC loc ev ty1  ty2'
+canEqNC ev ty1 ty2
+  | Just ty1' <- tcView ty1 = canEqNC ev ty1' ty2
+  | Just ty2' <- tcView ty2 = canEqNC ev ty1  ty2'
 
-canEqNC loc ev ty1@(TyConApp fn tys) ty2
+canEqNC ev ty1@(TyConApp fn tys) ty2
   | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = canEqLeaf loc ev ty1 ty2
-canEqNC loc ev ty1 ty2@(TyConApp fn tys)
+  = canEqLeaf ev ty1 ty2
+canEqNC ev ty1 ty2@(TyConApp fn tys)
   | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = canEqLeaf loc ev ty1 ty2
+  = canEqLeaf ev ty1 ty2
 
-canEqNC loc ev ty1 ty2
+canEqNC ev ty1 ty2
   | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1
   , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2
   , isDecomposableTyCon tc1 && isDecomposableTyCon tc2
-  = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2
+  = canDecomposableTyConApp ev tc1 tys1 tc2 tys2
 
-canEqNC loc ev s1@(ForAllTy {}) s2@(ForAllTy {})
+canEqNC ev s1@(ForAllTy {}) s2@(ForAllTy {})
  | tcIsForAllTy s1, tcIsForAllTy s2
- , CtWanted { ctev_evar = orig_ev } <- ev
+ , CtWanted { ctev_loc = loc, ctev_evar = orig_ev } <- ev
  = do { let (tvs1,body1) = tcSplitForAllTys s1
             (tvs2,body2) = tcSplitForAllTys s2
       ; if not (equalLength tvs1 tvs2) then
-          canEqFailure loc ev s1 s2
+          canEqFailure ev s1 s2
         else
           do { traceTcS "Creating implication for polytype equality" $ ppr ev
              ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
@@ -770,9 +762,9 @@ canEqNC loc ev s1@(ForAllTy {}) s2@(ForAllTy {})
 -- e.g.  F a b ~ Maybe c   where F has arity 1
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
-canEqNC loc ev ty1 ty2
- =  do { (s1, co1) <- flatten loc FMSubstOnly ev ty1
-       ; (s2, co2) <- flatten loc FMSubstOnly ev ty2
+canEqNC ev ty1 ty2
+ =  do { (s1, co1) <- flatten FMSubstOnly ev ty1
+       ; (s2, co2) <- flatten FMSubstOnly ev ty2
        ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2) (mkHdEqPred s2 co1 co2)
        ; case mb_ct of
            Nothing     -> return Stop
@@ -782,7 +774,7 @@ canEqNC loc ev ty1 ty2
       | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1
       , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2
       , isDecomposableTyCon tc1 && isDecomposableTyCon tc2
-      = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2
+      = canDecomposableTyConApp ev tc1 tys1 tc2 tys2
 
       | Just (s1,t1) <- tcSplitAppTy_maybe ty1
       , Just (s2,t2) <- tcSplitAppTy_maybe ty2
@@ -791,37 +783,37 @@ canEqNC loc ev ty1 ty2
                  xevdecomp x = let xco = evTermCoercion x
                                in [EvCoercion (mkTcLRCo CLeft xco), EvCoercion (mkTcLRCo CRight xco)]
            ; ctevs <- xCtFlavor ev [mkTcEqPred s1 s2, mkTcEqPred t1 t2] (XEvTerm xevcomp xevdecomp)
-           ; canEvVarsCreated loc ctevs }
+           ; canEvVarsCreated ctevs }
 
       | otherwise
-      = do { emitInsoluble (CNonCanonical { cc_ev = ev, cc_loc = loc })
+      = do { emitInsoluble (mkNonCanonical ev)
            ; return Stop }
 
 ------------------------
-canDecomposableTyConApp :: CtLoc -> CtEvidence
+canDecomposableTyConApp :: CtEvidence
                         -> TyCon -> [TcType]
                         -> TyCon -> [TcType]
                         -> TcS StopOrContinue
-canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2
+canDecomposableTyConApp ev tc1 tys1 tc2 tys2
   | tc1 /= tc2 || length tys1 /= length tys2
     -- Fail straight away for better error messages
-  = canEqFailure loc ev (mkTyConApp tc1 tys1) (mkTyConApp tc2 tys2)
+  = canEqFailure ev (mkTyConApp tc1 tys1) (mkTyConApp tc2 tys2)
   | otherwise
   = do { let xcomp xs  = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs))
              xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..]
              xev = XEvTerm xcomp xdecomp
        ; ctevs <- xCtFlavor ev (zipWith mkTcEqPred tys1 tys2) xev
-       ; canEvVarsCreated loc ctevs }
+       ; canEvVarsCreated ctevs }
 
-canEqFailure :: CtLoc -> CtEvidence -> TcType -> TcType -> TcS StopOrContinue
+canEqFailure :: CtEvidence -> TcType -> TcType -> TcS StopOrContinue
 -- See Note [Make sure that insolubles are fully rewritten]
-canEqFailure loc ev ty1 ty2
-  = do { (s1, co1) <- flatten loc FMSubstOnly ev ty1
-       ; (s2, co2) <- flatten loc FMSubstOnly ev ty2
+canEqFailure ev ty1 ty2
+  = do { (s1, co1) <- flatten FMSubstOnly ev ty1
+       ; (s2, co2) <- flatten FMSubstOnly ev ty2
        ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2)
                                      (mkHdEqPred s2 co1 co2)
        ; case mb_ct of
-           Just new_ev -> emitInsoluble (CNonCanonical { cc_ev = new_ev, cc_loc = loc })
+           Just new_ev -> emitInsoluble (mkNonCanonical new_ev)
            Nothing -> pprPanic "canEqFailure" (ppr ev $$ ppr ty1 $$ ppr ty2)
        ; return Stop }
 \end{code}
@@ -1036,7 +1028,7 @@ reOrient (VarCls tv1)  (VarCls tv2)
 
 ------------------
 
-canEqLeaf :: CtLoc -> CtEvidence
+canEqLeaf :: CtEvidence
           -> Type -> Type
           -> TcS StopOrContinue
 -- Canonicalizing "leaf" equality constraints which cannot be
@@ -1051,7 +1043,7 @@ canEqLeaf :: CtLoc -> CtEvidence
 -- NB: at this point we do NOT know that the kinds of s1 and s2 are
 --     compatible.  See Note [Equalities with incompatible kinds]
 
-canEqLeaf loc ev s1 s2
+canEqLeaf ev s1 s2
   | cls1 `reOrient` cls2
   = do { traceTcS "canEqLeaf (reorienting)" doc
        ; let xcomp [x] = EvCoercion (mkTcSymCo (evTermCoercion x))
@@ -1061,12 +1053,12 @@ canEqLeaf loc ev s1 s2
        ; ctevs <- xCtFlavor ev [mkTcEqPred s2 s1] xev
        ; case ctevs of
            []     -> return Stop
-           [ctev] -> canEqLeafOriented loc ctev cls2 s1
+           [ctev] -> canEqLeafOriented ctev cls2 s1
            _      -> panic "canEqLeaf" }
 
   | otherwise
   = do { traceTcS "canEqLeaf" doc
-       ; canEqLeafOriented loc ev cls1 s2 }
+       ; canEqLeafOriented ev cls1 s2 }
   where
     cls1 = classify s1
     cls2 = classify s2
@@ -1074,23 +1066,21 @@ canEqLeaf loc ev s1 s2
                 , hang (ppr s1) 2 (dcolon  <+> ppr (typeKind s1))
                 , hang (ppr s2) 2 (dcolon  <+> ppr (typeKind s2)) ]
 
-canEqLeafOriented :: CtLoc -> CtEvidence
-                  -> TypeClassifier -> TcType -> TcS StopOrContinue
+canEqLeafOriented :: CtEvidence -> TypeClassifier -> TcType -> TcS StopOrContinue
 -- By now s1 will either be a variable or a type family application
-canEqLeafOriented loc ev (FunCls fn tys1) s2 = canEqLeafFun loc ev fn tys1 s2
-canEqLeafOriented loc ev (VarCls tv)      s2 = canEqLeafTyVar loc ev tv s2
-canEqLeafOriented _   ev (OtherCls {})    _  = pprPanic "canEqLeafOriented" (ppr (ctEvPred ev))
+canEqLeafOriented ev (FunCls fn tys1) s2 = canEqLeafFun ev fn tys1 s2
+canEqLeafOriented ev (VarCls tv)      s2 = canEqLeafTyVar ev tv s2
+canEqLeafOriented ev (OtherCls {})    _  = pprPanic "canEqLeafOriented" (ppr (ctEvPred ev))
 
-canEqLeafFun :: CtLoc -> CtEvidence
-             -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue
-canEqLeafFun loc ev fn tys1 ty2  -- ev :: F tys1 ~ ty2
+canEqLeafFun :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue
+canEqLeafFun ev fn tys1 ty2  -- ev :: F tys1 ~ ty2
   = do { traceTcS "canEqLeafFun" $ pprEq (mkTyConApp fn tys1) ty2
 
             -- Flatten type function arguments
             -- cos1 :: xis1 ~ tys1
             -- co2  :: xi2 ~ ty2
-      ; (xis1,cos1) <- flattenMany loc FMFullFlatten ev tys1
-      ; (xi2, co2)  <- flatten     loc FMFullFlatten ev ty2
+      ; (xis1,cos1) <- flattenMany FMFullFlatten ev tys1
+      ; (xi2, co2)  <- flatten     FMFullFlatten ev ty2
 
           -- Fancy higher-dimensional coercion between equalities!
           -- SPJ asks why?  Why not just co : F xis1 ~ F tys1?
@@ -1103,17 +1093,16 @@ canEqLeafFun loc ev fn tys1 ty2  -- ev :: F tys1 ~ ty2
             Nothing     -> return Stop
             Just new_ev | typeKind fam_head `isSubKind` typeKind xi2
                         -- Establish CFunEqCan kind invariant
-                        -> continueWith (CFunEqCan { cc_ev = new_ev, cc_loc = loc
-                                                   , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 })
+                        -> continueWith (CFunEqCan { cc_ev = new_ev, cc_fun = fn
+                                                   , cc_tyargs = xis1, cc_rhs = xi2 })
                         | otherwise
-                        -> checkKind loc new_ev fam_head xi2 }
+                        -> checkKind new_ev fam_head xi2 }
 
-canEqLeafTyVar :: CtLoc -> CtEvidence
-               -> TcTyVar -> TcType -> TcS StopOrContinue
-canEqLeafTyVar loc ev tv s2              -- ev :: tv ~ s2
+canEqLeafTyVar :: CtEvidence -> TcTyVar -> TcType -> TcS StopOrContinue
+canEqLeafTyVar ev tv s2              -- ev :: tv ~ s2
   = do { traceTcS "canEqLeafTyVar 1" $ pprEq (mkTyVarTy tv) s2
-       ; (xi1,co1) <- flattenTyVar loc FMFullFlatten ev tv -- co1 :: xi1 ~ tv
-       ; (xi2,co2) <- flatten      loc FMFullFlatten ev s2 -- co2 :: xi2 ~ s2
+       ; (xi1,co1) <- flattenTyVar FMFullFlatten ev tv -- co1 :: xi1 ~ tv
+       ; (xi2,co2) <- flatten      FMFullFlatten ev s2 -- co2 :: xi2 ~ s2
        ; let co = mkHdEqPred s2 co1 co2
              -- co :: (xi1 ~ xi2) ~ (tv ~ s2)
 
@@ -1124,7 +1113,7 @@ canEqLeafTyVar loc ev tv s2              -- ev :: tv ~ s2
                             do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co
                                ; case mb of
                                    Nothing     -> return Stop
-                                   Just new_ev -> canEqNC loc new_ev xi1 xi2 }
+                                   Just new_ev -> canEqNC new_ev xi1 xi2 }
 
            (Just tv1, Just tv2) | tv1 == tv2
               -> do { when (isWanted ev) $
@@ -1132,14 +1121,14 @@ canEqLeafTyVar loc ev tv s2              -- ev :: tv ~ s2
                     ; return Stop }
 
            (Just tv1, _) -> do { dflags <- getDynFlags
-                               ; canEqLeafTyVar2 dflags loc ev tv1 xi2 co } }
+                               ; canEqLeafTyVar2 dflags ev tv1 xi2 co } }
 
-canEqLeafTyVar2 :: DynFlags -> CtLoc -> CtEvidence
+canEqLeafTyVar2 :: DynFlags -> CtEvidence
                 -> TyVar -> Type -> TcCoercion
                 -> TcS StopOrContinue
 -- LHS rewrote to a type variable,
 -- RHS to something else (possibly a tyvar, but not the *same* tyvar)
-canEqLeafTyVar2 dflags loc ev tv1 xi2 co
+canEqLeafTyVar2 dflags ev tv1 xi2 co
   | OC_OK xi2' <- occurCheckExpand dflags tv1 xi2  -- No occurs check
   = do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2') co
                 -- Ensure that the new goal has enough type synonyms
@@ -1151,21 +1140,20 @@ canEqLeafTyVar2 dflags loc ev tv1 xi2 co
                         -- Establish CTyEqCan kind invariant
                         -- Reorientation has done its best, but the kinds might
                         -- simply be incompatible
-                        -> continueWith (CTyEqCan { cc_ev = new_ev, cc_loc = loc
+                        -> continueWith (CTyEqCan { cc_ev = new_ev
                                                   , cc_tyvar  = tv1, cc_rhs = xi2' })
                         | otherwise
-                        -> checkKind loc new_ev xi1 xi2' }
+                        -> checkKind new_ev xi1 xi2' }
 
   | otherwise  -- Occurs check error
   = do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co
        ; case mb of
            Nothing     -> return Stop
-           Just new_ev -> canEqFailure loc new_ev xi1 xi2 }
+           Just new_ev -> canEqFailure new_ev xi1 xi2 }
   where
     xi1 = mkTyVarTy tv1
 
-checkKind :: CtLoc
-          -> CtEvidence          -- t1~t2
+checkKind :: CtEvidence          -- t1~t2
           -> TcType -> TcType    -- s1~s2, flattened and zonked
           -> TcS StopOrContinue
 -- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint
@@ -1175,16 +1163,16 @@ checkKind :: CtLoc
 -- a second attempt at solving
 -- See Note [Equalities with incompatible kinds]
 
-checkKind loc new_ev s1 s2
+checkKind new_ev s1 s2
   = ASSERT( isKind k1 && isKind k2 )
     do {  -- See Note [Equalities with incompatible kinds]
          traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2])
        ; updWorkListTcS $ extendWorkListNonEq $
-         CIrredEvCan { cc_ev = new_ev, cc_loc = loc }
-       ; mw <- newDerived (mkEqPred k1 k2)
+         CIrredEvCan { cc_ev = new_ev }
+       ; mw <- newDerived kind_co_loc (mkEqPred k1 k2)
        ; case mw of
            Nothing  -> return Stop
-           Just kev -> canEqNC kind_co_loc kev k1 k2 }
+           Just kev -> canEqNC kev k1 k2 }
 
          -- Always create a Wanted kind equality even if
          -- you are decomposing a given constraint.
@@ -1192,6 +1180,7 @@ checkKind loc new_ev s1 s2
   where
     k1 = typeKind s1
     k2 = typeKind s2
+    loc = ctev_loc new_ev
     kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc))
 
 
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 63e22f63fd..a89cf7cd31 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -337,7 +337,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
 mkGroupReporter mk_err ctxt cts
   = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
   where
-    cmp_loc ct1 ct2 = ctLocSpan (cc_loc ct1) `compare` ctLocSpan (cc_loc ct2)
+    cmp_loc ct1 ct2 = ctLocSpan (ctev_loc (ctEvidence ct1)) `compare` ctLocSpan (ctev_loc (ctEvidence ct2))
 
 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
             -> [Ct] -> TcM ()
@@ -361,7 +361,7 @@ maybeReportError ctxt err
 maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
 -- See Note [Deferring coercion errors to runtime]
 maybeAddDeferredBinding ctxt err ct
-  | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
+  | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
     -- Only add deferred bindings for Wanted constraints
   , isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
   , Just ev_binds_var <- cec_binds ctxt  -- We have somewhere to put the bindings
@@ -418,13 +418,13 @@ pprWithArising (ct:cts)
   | otherwise
   = (loc, vcat (map ppr_one (ct:cts)))
   where
-    loc = cc_loc ct
+    loc = ctev_loc (ctEvidence ct)
     ppr_one ct = hang (parens (pprType (ctPred ct))) 
-                    2 (pprArisingAt (cc_loc ct))
+                    2 (pprArisingAt (ctev_loc (ctEvidence ct)))
 
 mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
 mkErrorMsg ctxt ct msg 
-  = do { let tcl_env = ctLocEnv (cc_loc ct)
+  = do { let tcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
        ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
        ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
 
@@ -518,7 +518,7 @@ mkIrredErr ctxt cts
        ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
   where
     (ct1:_) = cts
-    orig    = ctLocOrigin (cc_loc ct1)
+    orig    = ctLocOrigin (ctev_loc (ctEvidence ct1))
     givens  = getUserGivens ctxt
     msg = couldNotDeduce givens (map ctPred cts, orig)
 
@@ -528,7 +528,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
   = do { let tyvars = varSetElems (tyVarsOfCt ct)
              tyvars_msg = map loc_msg tyvars
              msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
-                             2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
+                             2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
                         , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
        ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
                -- The 'False' means "don't filter the bindings; see Trac #8191
@@ -551,7 +551,7 @@ mkIPErr ctxt cts
        ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
   where
     (ct1:_) = cts
-    orig    = ctLocOrigin (cc_loc ct1)
+    orig    = ctLocOrigin (ctev_loc (ctEvidence ct1))
     preds   = map ctPred cts
     givens  = getUserGivens ctxt
     msg | null givens
@@ -602,25 +602,26 @@ mkEqErr1 ctxt ct
        ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
        ; dflags <- getDynFlags
        ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) 
-                      (ct { cc_loc = given_loc}) -- Note [Inaccessible code]
+                      (ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
                       Nothing ty1 ty2 }
 
   | otherwise   -- Wanted or derived
   = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
-       ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
+       ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin loc)
        ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
        ; dflags <- getDynFlags
        ; mkEqErr_help dflags ctxt (wanted_msg $$ binds_msg) 
                       ct is_oriented ty1 ty2 }
   where
-    ev         = cc_ev ct
+    ev         = ctEvidence ct
+    loc        = ctev_loc ev
     (ty1, ty2) = getEqPredTys (ctEvPred ev)
 
     mk_given :: [Implication] -> (CtLoc, SDoc)
     -- For given constraints we overwrite the env (and hence src-loc)
     -- with one from the implication.  See Note [Inaccessible code]
-    mk_given []           = (cc_loc ct, empty)
-    mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
+    mk_given []           = (loc, empty)
+    mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
                             , hang (ptext (sLit "Inaccessible code in"))
                                  2 (ppr (ic_info implic)))
 
@@ -993,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
   | otherwise
   = return (ctxt, safe_haskell_msg)
   where
-    orig        = ctLocOrigin (cc_loc ct)
+    orig        = ctLocOrigin (ctev_loc (ctEvidence ct))
     pred        = ctPred ct
     (clas, tys) = getClassPredTys pred
     ispecs      = [ispec | (ispec, _) <- matches]
@@ -1324,7 +1325,7 @@ relevantBindings want_filtering ctxt ct
          else do { traceTc "rb" doc
                  ; return (ctxt { cec_tidy = tidy_env' }, doc) } } 
   where
-    lcl_env = ctLocEnv (cc_loc ct)
+    lcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
     ct_tvs = tyVarsOfCt ct
 
     run_out :: Maybe Int -> Bool
@@ -1396,16 +1397,16 @@ are created by in RtClosureInspect.zonkRTTIType.
 %************************************************************************
 
 \begin{code}
-solverDepthErrorTcS :: SubGoalCounter -> Ct -> TcM a
-solverDepthErrorTcS cnt ct
+solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
+solverDepthErrorTcS cnt ev
   = setCtLoc loc $
-    do { pred <- zonkTcType (ctPred ct)
+    do { pred <- zonkTcType (ctEvPred ev)
        ; env0 <- tcInitTidyEnv
        ; let tidy_env  = tidyFreeTyVars env0 (tyVarsOfType pred)
              tidy_pred = tidyType tidy_env pred
        ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
   where
-    loc   = cc_loc ct
+    loc   = ctev_loc ev
     depth = ctLocDepth loc
     value = subGoalCounterValue cnt depth
     msg CountConstraints =
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 2b4f6aa702..6f3eb41ffd 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -137,7 +137,7 @@ tcHole occ res_ty
       ; name <- newSysName occ
       ; let ev = mkLocalId name ty
       ; loc <- getCtLoc HoleOrigin
-      ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc, cc_occ = occ }
+      ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ }
       ; emitInsoluble can
       ; tcWrapResult (HsVar ev) ty res_ty }
 \end{code}
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 8b9e758d29..36d0c09c38 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -95,12 +95,14 @@ solveInteractGiven loc fsks givens
                       -- See Note [Do not decompose given polytype equalities]
                       -- in TcCanonical
   where
-    given_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvId ev_id
-                                                         , ctev_pred = evVarPred ev_id }
+    given_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvId ev_id
+                                                     , ctev_pred = evVarPred ev_id
+                                                     , ctev_loc = loc }
                           | ev_id <- givens ]
 
-    fsk_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty)
-                                                       , ctev_pred = pred  }
+    fsk_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty)
+                                                   , ctev_pred = pred
+                                                   , ctev_loc = loc }
                         | tv <- fsks
                         , let FlatSkol fam_ty = tcTyVarDetails tv
                               tv_ty = mkTyVarTy tv
@@ -125,7 +127,7 @@ solveInteract cts
               NoWorkRemaining     -- Done, successfuly (modulo frozen)
                 -> return ()
               MaxDepthExceeded cnt ct -- Failure, depth exceeded
-                -> wrapErrTcS $ solverDepthErrorTcS cnt ct
+                -> wrapErrTcS $ solverDepthErrorTcS cnt (ctEvidence ct)
               NextWorkItem ct     -- More work, loop around!
                 -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
 
@@ -151,7 +153,7 @@ selectNextWorkItem max_depth
           (Nothing,_)
               -> (NoWorkRemaining,wl)           -- No more work
           (Just ct, new_wl)
-              | Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
+              | Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (ctev_loc (ctEvidence ct))) -- Depth exceeded
               -> (MaxDepthExceeded cnt ct,new_wl)
           (Just ct, new_wl)
               -> (NextWorkItem ct, new_wl)      -- New workitem and worklist
@@ -408,8 +410,9 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
 
 addFunDepWork :: Ct -> Ct -> TcS ()
 addFunDepWork work_ct inert_ct
-  = do { let work_loc           = cc_loc work_ct
-             inert_pred_loc     = (ctPred inert_ct, pprArisingAt (cc_loc inert_ct))
+  = do { let work_loc           = ctev_loc (ctEvidence work_ct)
+             inert_loc          = ctev_loc (ctEvidence inert_ct)
+             inert_pred_loc     = (ctPred inert_ct, pprArisingAt inert_loc)
              work_item_pred_loc = (ctPred work_ct,  pprArisingAt work_loc)
 
        ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
@@ -489,13 +492,13 @@ I can think of two ways to fix this:
 \begin{code}
 interactFunEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
 interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
-                                         , cc_tyargs = args, cc_rhs = rhs, cc_loc = loc })
+                                         , cc_tyargs = args, cc_rhs = rhs })
   | (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } : _) <- matching_inerts
   , ev_i `canRewrite` ev
   = do { traceTcS "interact with inerts: FunEq/FunEq" $
          vcat [ text "workItem =" <+> ppr workItem
               , text "inertItem=" <+> ppr ev_i ]
-       ; solveFunEq loc ev_i rhs_i ev rhs
+       ; solveFunEq ev_i rhs_i ev rhs
        ; return (Nothing, True) }
 
   | (ev_i : _) <- [ ev_i | CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } <- matching_inerts
@@ -507,15 +510,15 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
   | eq_is@(eq_i : _) <- matching_inerts
   , ev `canRewrite` ctEvidence eq_i   -- This is unusual
   = do { let solve (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i })
-                      = solveFunEq loc ev rhs ev_i rhs_i
+                      = solveFunEq ev rhs ev_i rhs_i
              solve ct = pprPanic "interactFunEq" (ppr ct)
        ; mapM_ solve eq_is
        ; return (Just (inerts { inert_funeqs = replaceFunEqs funeqs tc args workItem }), True) }
 
   | (CFunEqCan { cc_rhs = rhs_i } : _) <- matching_inerts
-  = do { mb <- newDerived (mkTcEqPred rhs_i rhs)
+  = do { mb <- newDerived loc (mkTcEqPred rhs_i rhs)
        ; case mb of
-           Just x  -> updWorkListTcS (extendWorkListEq (mkNonCanonical loc x))
+           Just x  -> updWorkListTcS (extendWorkListEq (mkNonCanonical x))
            Nothing -> return ()
        ; return (Nothing, False) }
 
@@ -524,13 +527,13 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
         ; traceTcS "builtInCandidates: " $ ppr is
         ; let interact = sfInteractInert ops args rhs
         ; impMbs <- sequence
-                 [ do mb <- newDerived (mkTcEqPred lhs_ty rhs_ty)
+                 [ do mb <- newDerived (ctev_loc iev) (mkTcEqPred lhs_ty rhs_ty)
                       case mb of
-                        Just x -> return $ Just $ mkNonCanonical d x
+                        Just x -> return $ Just $ mkNonCanonical x
                         Nothing -> return Nothing
                  | CFunEqCan { cc_tyargs = iargs
                              , cc_rhs = ixi
-                             , cc_loc = d } <- is
+                             , cc_ev = iev } <- is
                  , Pair lhs_ty rhs_ty <- interact iargs ixi
                  ]
         ; let imps = catMaybes impMbs
@@ -542,22 +545,22 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
   where
     funeqs = inert_funeqs inerts
     matching_inerts = findFunEqs funeqs tc args
+    loc = ctev_loc ev
 
 interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi)
 
 
-solveFunEq :: CtLoc
-           -> CtEvidence    -- From this  :: F tys ~ xi1
+solveFunEq :: CtEvidence    -- From this  :: F tys ~ xi1
            -> Type
            -> CtEvidence    -- Solve this :: F tys ~ xi2
            -> Type
            -> TcS ()
-solveFunEq loc from_this xi1 solve_this xi2
+solveFunEq from_this xi1 solve_this xi2
   = do { ctevs <- xCtFlavor solve_this [mkTcEqPred xi2 xi1] xev
              -- No caching!  See Note [Cache-caused loops]
              -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
 
-       ; emitWorkNC loc ctevs }
+       ; emitWorkNC ctevs }
   where
     from_this_co = evTermCoercion $ ctEvTerm from_this
 
@@ -664,8 +667,7 @@ test when solving pairwise CFunEqCan.
 \begin{code}
 interactTyVarEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
 -- CTyEqCans are always consumed, returning Stop
-interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs
-                                          , cc_ev = ev, cc_loc = loc })
+interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev = ev })
   | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
                              <- findTyEqs (inert_eqs inerts) tv
                          , ev_i `canRewriteOrSame` ev
@@ -689,7 +691,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs
        ; return (Nothing, True) }
 
   | otherwise
-  = do { mb_solved <- trySpontaneousSolve ev tv rhs loc
+  = do { mb_solved <- trySpontaneousSolve ev tv rhs
        ; case mb_solved of
            SPCantSolve   -- Includes givens
               -> do { untch <- getUntouchables
@@ -716,7 +718,8 @@ interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
 givenFlavour :: CtEvidence
 -- Used just to pass to kickOutRewritable
 givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev"
-                       , ctev_evtm = panic "givenFlavour:tm" }
+                       , ctev_evtm = panic "givenFlavour:tm"
+                       , ctev_loc  = panic "givenFlavour:loc" }
 
 ppr_kicked :: Int -> SDoc
 ppr_kicked 0 = empty
@@ -893,8 +896,8 @@ data SPSolveResult = SPCantSolve
 
 -- @trySpontaneousSolve wi@ solves equalities where one side is a
 -- touchable unification variable.
-trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> CtLoc -> TcS SPSolveResult
-trySpontaneousSolve gw tv1 xi d
+trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
+trySpontaneousSolve gw tv1 xi
   | isGiven gw   -- See Note [Touchables and givens]
   = return SPCantSolve
 
@@ -902,36 +905,34 @@ trySpontaneousSolve gw tv1 xi d
   = do { tch1 <- isTouchableMetaTyVarTcS tv1
        ; tch2 <- isTouchableMetaTyVarTcS tv2
        ; case (tch1, tch2) of
-           (True,  True)  -> trySpontaneousEqTwoWay d gw tv1 tv2
-           (True,  False) -> trySpontaneousEqOneWay d gw tv1 xi
-           (False, True)  -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1)
+           (True,  True)  -> trySpontaneousEqTwoWay gw tv1 tv2
+           (True,  False) -> trySpontaneousEqOneWay gw tv1 xi
+           (False, True)  -> trySpontaneousEqOneWay gw tv2 (mkTyVarTy tv1)
            _              -> return SPCantSolve }
   | otherwise
   = do { tch1 <- isTouchableMetaTyVarTcS tv1
-       ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi
+       ; if tch1 then trySpontaneousEqOneWay gw tv1 xi
                  else return SPCantSolve }
 
 ----------------
-trySpontaneousEqOneWay :: CtLoc -> CtEvidence
-                       -> TcTyVar -> Xi -> TcS SPSolveResult
+trySpontaneousEqOneWay :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
 -- tv is a MetaTyVar, not untouchable
-trySpontaneousEqOneWay d gw tv xi
+trySpontaneousEqOneWay gw tv xi
   | not (isSigTyVar tv) || isTyVarTy xi
   , typeKind xi `tcIsSubKind` tyVarKind tv
-  = solveWithIdentity d gw tv xi
+  = solveWithIdentity gw tv xi
   | otherwise -- Still can't solve, sig tyvar and non-variable rhs
   = return SPCantSolve
 
 ----------------
-trySpontaneousEqTwoWay :: CtLoc -> CtEvidence
-                       -> TcTyVar -> TcTyVar -> TcS SPSolveResult
+trySpontaneousEqTwoWay :: CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult
 -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
 
-trySpontaneousEqTwoWay d gw tv1 tv2
+trySpontaneousEqTwoWay gw tv1 tv2
   | k1 `tcIsSubKind` k2 && nicer_to_update_tv2
-  = solveWithIdentity d gw tv2 (mkTyVarTy tv1)
+  = solveWithIdentity gw tv2 (mkTyVarTy tv1)
   | k2 `tcIsSubKind` k1
-  = solveWithIdentity d gw tv1 (mkTyVarTy tv2)
+  = solveWithIdentity gw tv1 (mkTyVarTy tv2)
   | otherwise
   = return SPCantSolve
   where
@@ -959,7 +960,7 @@ double unifications is the main reason we disallow touchable
 unification variables as RHS of type family equations: F xis ~ alpha.
 
 \begin{code}
-solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
+solveWithIdentity :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
 -- Solve with the identity coercion
 -- Precondition: kind(xi) is a sub-kind of kind(tv)
 -- Precondition: CtEvidence is Wanted or Derived
@@ -972,7 +973,7 @@ solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
 --     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
 --     say that in (a ~ xi), the type variable a does not appear in xi.
 --     See TcRnTypes.Ct invariants.
-solveWithIdentity _d wd tv xi
+solveWithIdentity wd tv xi
   = do { let tv_ty = mkTyVarTy tv
        ; traceTcS "Sneaky unification:" $
                        vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi,
@@ -1361,9 +1362,9 @@ instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
        | tcEqType sty1 sty2
        = return ievs -- Return no trivial equalities
        | otherwise
-       = do { mb_eqv <- newDerived (mkTcEqPred sty1 sty2)
+       = do { mb_eqv <- newDerived der_loc (mkTcEqPred sty1 sty2)
             ; case mb_eqv of
-                 Just ev -> return (mkNonCanonical der_loc ev : ievs)
+                 Just ev -> return (mkNonCanonical (ev {ctev_loc = der_loc}) : ievs)
                  Nothing -> return ievs }
                    -- We are eventually going to emit FD work back in the work list so
                    -- it is important that we only return the /freshly created/ and not
@@ -1425,22 +1426,19 @@ doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
 doTopReact inerts workItem
   = do { traceTcS "doTopReact" (ppr workItem)
        ; case workItem of
-           CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis
-                    , cc_loc = d }
-              -> doTopReactDict inerts fl cls xis d
+           CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis }
+              -> doTopReactDict inerts fl cls xis
 
-           CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args
-                     , cc_rhs = xi, cc_loc = d }
-              -> doTopReactFunEq workItem fl tc args xi d
+           CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args , cc_rhs = xi }
+              -> doTopReactFunEq workItem fl tc args xi
 
            _  -> -- Any other work item does not react with any top-level equations
                  return NoTopInt  }
 
 --------------------
-doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi]
-               -> CtLoc -> TcS TopInteractResult
+doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi] -> TcS TopInteractResult
 -- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts fl cls xis loc
+doTopReactDict inerts fl cls xis
   | not (isWanted fl)   -- Never use instances for Given or Derived constraints
   = try_fundeps_and_return
 
@@ -1459,6 +1457,7 @@ doTopReactDict inerts fl cls xis loc
      arising_sdoc = pprArisingAt loc
      dict_id = ctEvId fl
      pred = mkClassPred cls xis
+     loc = ctev_loc fl
 
      solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
       -- Precondition: evidence term matches the predicate workItem
@@ -1475,8 +1474,7 @@ doTopReactDict inerts fl cls xis loc
                ppr dict_id
              ; setEvBind dict_id ev_term
              ; let mk_new_wanted ev
-                       = CNonCanonical { cc_ev  = ev
-                                       , cc_loc = bumpCtLocDepth CountConstraints loc }
+                       = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc })
              ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs))
              ; return $
                SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
@@ -1495,9 +1493,8 @@ doTopReactDict inerts fl cls xis loc
             ; return NoTopInt }
 
 --------------------
-doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi
-                -> CtLoc -> TcS TopInteractResult
-doTopReactFunEq _ct fl fun_tc args xi loc
+doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi -> TcS TopInteractResult
+doTopReactFunEq _ct fl fun_tc args xi
   = ASSERT(isSynFamilyTyCon fun_tc) -- No associated data families have
                                      -- reached this far
     -- Look in the cache of solved funeqs
@@ -1522,13 +1519,13 @@ doTopReactFunEq _ct fl fun_tc args xi loc
        ; succeed_with "Fun/Top" co ty } } } } }
   where
     fam_ty = mkTyConApp fun_tc args
+    loc = ctev_loc fl
 
     try_improvement
       | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc
       = do { let eqns = sfInteractTop ops args xi
-           ; impsMb <- mapM (\(Pair x y) -> newDerived (mkTcEqPred x y))
-                            eqns
-           ; let work = map (mkNonCanonical loc) (catMaybes impsMb)
+           ; impsMb <- mapM (\(Pair x y) -> newDerived loc (mkTcEqPred x y)) eqns
+           ; let work = map mkNonCanonical (catMaybes impsMb)
            ; unless (null work) (updWorkListTcS (extendWorkListEqs work)) }
       | otherwise
       = return ()
@@ -1539,8 +1536,7 @@ doTopReactFunEq _ct fl fun_tc args xi loc
            ; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs)
            ; case ctevs of
                [ctev] -> updWorkListTcS $ extendWorkListEq $
-                         CNonCanonical { cc_ev = ctev
-                                       , cc_loc  = bumpCtLocDepth CountTyFunApps loc }
+                         mkNonCanonical (ctev { ctev_loc = bumpCtLocDepth CountTyFunApps loc })
                ctevs -> -- No subgoal (because it's cached)
                         ASSERT( null ctevs) return ()
            ; return $ SomeTopInt { tir_rule = str
@@ -1844,12 +1840,12 @@ matchClassInst _ clas [ ty ] _
       _ -> panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
                      $$ vcat (map (ppr . idType) (classMethods clas)))
 
-matchClassInst _ clas [ _k, ty1, ty2 ] _
+matchClassInst _ clas [ _k, ty1, ty2 ] loc
   | clas == coercibleClass =  do
       traceTcS "matchClassInst for" $ ppr clas <+> ppr ty1 <+> ppr ty2
       rdr_env <- getGlobalRdrEnvTcS
       safeMode <- safeLanguageOn `fmap` getDynFlags
-      ev <- getCoercibleInst safeMode rdr_env ty1 ty2
+      ev <- getCoercibleInst safeMode rdr_env loc ty1 ty2
       traceTcS "matchClassInst returned" $ ppr ev
       return ev
 
@@ -1903,7 +1899,7 @@ matchClassInst inerts clas tys loc
             ; if null theta then
                   return (GenInst [] (EvDFunApp dfun_id tys []))
               else do
-            { evc_vars <- instDFunConstraints theta
+            { evc_vars <- instDFunConstraints loc theta
             ; let new_ev_vars = freshGoals evc_vars
                       -- new_ev_vars are only the real new variables that can be emitted
                   dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
@@ -1935,8 +1931,8 @@ matchClassInst inerts clas tys loc
 
 -- See Note [Coercible Instances]
 -- Changes to this logic should likely be reflected in coercible_msg in TcErrors.
-getCoercibleInst :: Bool -> GlobalRdrEnv -> TcType -> TcType -> TcS LookupInstResult
-getCoercibleInst safeMode rdr_env ty1 ty2
+getCoercibleInst :: Bool -> GlobalRdrEnv -> CtLoc -> TcType -> TcType -> TcS LookupInstResult
+getCoercibleInst safeMode rdr_env loc ty1 ty2
   | ty1 `tcEqType` ty2
   = do return $ GenInst []
               $ EvCoercible (EvCoercibleRefl ty1)
@@ -1952,7 +1948,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
        arg_evs <- flip mapM (zip3 (tyConRoles tc1) tyArgs1 tyArgs2) $ \(r,ta1,ta2) ->
          case r of Nominal -> return (Nothing, EvCoercibleArgN ta1 {- == ta2, due to nominalArgsAgree -})
                    Representational -> do
-                        ct_ev <- requestCoercible ta1 ta2
+                        ct_ev <- requestCoercible loc ta1 ta2
                         return (freshGoal ct_ev, EvCoercibleArgR (getEvTerm ct_ev))
                    Phantom -> do
                         return (Nothing, EvCoercibleArgP ta1 ta2)
@@ -1966,7 +1962,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
     dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
   = do markDataConsAsUsed rdr_env tc
        let concTy = newTyConInstRhs tc tyArgs
-       ct_ev <- requestCoercible concTy ty2
+       ct_ev <- requestCoercible loc concTy ty2
        return $ GenInst (freshGoals [ct_ev])
               $ EvCoercible (EvCoercibleNewType CLeft tc tyArgs (getEvTerm ct_ev))
 
@@ -1977,7 +1973,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
     dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
   = do markDataConsAsUsed rdr_env tc
        let concTy = newTyConInstRhs tc tyArgs
-       ct_ev <- requestCoercible ty1 concTy
+       ct_ev <- requestCoercible loc ty1 concTy
        return $ GenInst (freshGoals [ct_ev])
               $ EvCoercible (EvCoercibleNewType CRight tc tyArgs (getEvTerm ct_ev))
 
@@ -2006,10 +2002,11 @@ markDataConsAsUsed rdr_env tc = addUsedRdrNamesTcS
   , not (null gres)
   , Imported (imp_spec:_) <- [gre_prov (head gres)] ]
 
-requestCoercible :: TcType -> TcType -> TcS MaybeNew
-requestCoercible ty1 ty2 =
+requestCoercible :: CtLoc -> TcType -> TcType -> TcS MaybeNew
+requestCoercible loc ty1 ty2 =
     ASSERT2( typeKind ty1 `tcEqKind` typeKind ty2, ppr ty1 <+> ppr ty2)
-    newWantedEvVar (coercibleClass `mkClassPred` [typeKind ty1, ty1, ty2])
+    newWantedEvVar loc (coercibleClass `mkClassPred` [typeKind ty1, ty1, ty2])
+
 \end{code}
 
 Note [Coercible Instances]
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 93e3c828da..ee93eb6d5a 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -170,9 +170,10 @@ newFlatWanteds orig theta
   where 
     inst_to_wanted loc pty 
           = do { v <- newWantedEvVar pty 
-               ; return $ mkNonCanonical loc $
+               ; return $ mkNonCanonical $
                  CtWanted { ctev_evar = v
-                          , ctev_pred = pty } }
+                          , ctev_pred = pty
+                          , ctev_loc = loc } }
 \end{code}
 
 %************************************************************************
@@ -874,8 +875,7 @@ zonkCt ct@(CHoleCan { cc_ev = ev })
        ; return $ ct { cc_ev = ev' } }
 zonkCt ct
   = do { fl' <- zonkCtEvidence (cc_ev ct)
-       ; return (CNonCanonical { cc_ev = fl'
-                               , cc_loc = cc_loc ct }) }
+       ; return (mkNonCanonical fl') }
 
 zonkCtEvidence :: CtEvidence -> TcM CtEvidence
 zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index b58d5ef6f8..cc93ca975a 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -913,19 +913,16 @@ data Ct
   = CDictCan {  -- e.g.  Num xi
       cc_ev :: CtEvidence,   -- See Note [Ct/evidence invariant]
       cc_class  :: Class,
-      cc_tyargs :: [Xi],
-
-      cc_loc  :: CtLoc
+      cc_tyargs :: [Xi]
     }
 
   | CIrredEvCan {  -- These stand for yet-unusable predicates
-      cc_ev :: CtEvidence,   -- See Note [Ct/evidence invariant]
+      cc_ev :: CtEvidence   -- See Note [Ct/evidence invariant]
         -- The ctev_pred of the evidence is
         -- of form   (tv xi1 xi2 ... xin)
         --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant fails
         --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails
         -- See Note [CIrredEvCan constraints]
-      cc_loc :: CtLoc
     }
 
   | CTyEqCan {  -- tv ~ xi      (recall xi means function free)
@@ -936,8 +933,7 @@ data Ct
        --   * We prefer unification variables on the left *JUST* for efficiency
       cc_ev :: CtEvidence,    -- See Note [Ct/evidence invariant]
       cc_tyvar  :: TcTyVar,
-      cc_rhs    :: Xi,
-      cc_loc    :: CtLoc
+      cc_rhs    :: Xi
     }
 
   | CFunEqCan {  -- F xis ~ xi
@@ -947,21 +943,17 @@ data Ct
       cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]
       cc_fun    :: TyCon,       -- A type function
       cc_tyargs :: [Xi],        -- Either under-saturated or exactly saturated
-      cc_rhs    :: Xi,          --    *never* over-saturated (because if so
+      cc_rhs    :: Xi           --    *never* over-saturated (because if so
                                 --    we should have decomposed)
-
-      cc_loc  :: CtLoc
     }
 
   | CNonCanonical {        -- See Note [NonCanonical Semantics]
-      cc_ev  :: CtEvidence,
-      cc_loc :: CtLoc
+      cc_ev  :: CtEvidence
     }
 
   | CHoleCan {             -- Treated as an "insoluble" constraint
                            -- See Note [Insoluble constraints]
       cc_ev  :: CtEvidence,
-      cc_loc :: CtLoc,
       cc_occ :: OccName    -- The name of this hole
     }
 \end{code}
@@ -1039,11 +1031,11 @@ the evidence may *not* be fully zonked; we are careful not to look at it
 during constraint solving.  See Note [Evidence field of CtEvidence]
 
 \begin{code}
-mkNonCanonical :: CtLoc -> CtEvidence -> Ct
-mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc }
+mkNonCanonical :: CtEvidence -> Ct
+mkNonCanonical ev = CNonCanonical { cc_ev = ev }
 
 mkNonCanonicalCt :: Ct -> Ct
-mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct }
+mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
 
 ctEvidence :: Ct -> CtEvidence
 ctEvidence = cc_ev
@@ -1384,15 +1376,18 @@ may be un-zonked.
 \begin{code}
 data CtEvidence
   = CtGiven { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]
-            , ctev_evtm :: EvTerm }        -- See Note [Evidence field of CtEvidence]
+            , ctev_evtm :: EvTerm          -- See Note [Evidence field of CtEvidence]
+            , ctev_loc  :: CtLoc }
     -- Truly given, not depending on subgoals
     -- NB: Spontaneous unifications belong here
 
   | CtWanted { ctev_pred :: TcPredType     -- See Note [Ct/evidence invariant]
-             , ctev_evar :: EvVar }        -- See Note [Evidence field of CtEvidence]
+             , ctev_evar :: EvVar          -- See Note [Evidence field of CtEvidence]
+             , ctev_loc  :: CtLoc }
     -- Wanted goal
 
-  | CtDerived { ctev_pred :: TcPredType }
+  | CtDerived { ctev_pred :: TcPredType
+              , ctev_loc  :: CtLoc }
     -- A goal that we don't really have to solve and can't immediately
     -- rewrite anything other than a derived (there's no evidence!)
     -- but if we do manage to solve it may help in solving other goals.
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index d2b9ea3edf..ca95914306 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -627,7 +627,8 @@ prepareInertsForImplications is
       where
         ev = ctEvidence funeq
         given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev)
-                           , ctev_pred = ctev_pred ev }
+                           , ctev_pred = ctev_pred ev
+                           , ctev_loc  = ctev_loc ev }
 
     given_from_wanted _ fhm = fhm -- Drop derived constraints
 
@@ -1034,9 +1035,10 @@ traceFireTcS ct doc
     do { dflags <- getDynFlags
        ; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $
     do { n <- TcM.readTcRef (tcs_count env)
-       ; let msg = int n <> brackets (ppr (ctLocDepth (cc_loc ct)))
-                   <+> ppr (ctEvidence ct) <> colon <+> doc
+       ; let msg = int n <> brackets (ppr (ctLocDepth (ctev_loc ev)))
+                   <+> ppr ev <> colon <+> doc
        ; TcM.debugDumpTcRn msg } }
+  where ev = cc_ev ct
 
 runTcS :: TcS a                -- What to run
        -> TcM (a, Bag EvBind)
@@ -1421,7 +1423,8 @@ newFlattenSkolem ev fam_ty
 
        ; let rhs_ty = mkTyVarTy tv
              ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty
-                            , ctev_evtm = EvCoercion (mkTcReflCo fam_ty) }
+                            , ctev_evtm = EvCoercion (mkTcReflCo fam_ty)
+                            , ctev_loc =  ctev_loc ev }
        ; dflags <- getDynFlags
        ; updInertTcS $ \ is@(IS { inert_fsks = fsks }) ->
             extendFlatCache dflags fam_ty ctev rhs_ty
@@ -1431,7 +1434,7 @@ newFlattenSkolem ev fam_ty
 
   | otherwise  -- Wanted or Derived: make new unification variable
   = do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty)
-       ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty)
+       ; ctev <- newWantedEvVarNC (ctev_loc ev) (mkTcEqPred fam_ty rhs_ty)
                                    -- NC (no-cache) version because we've already
                                    -- looked in the solved goals an inerts (lookupFlatEqn)
        ; dflags <- getDynFlags
@@ -1531,43 +1534,43 @@ setEvBind the_ev tm
        ; tc_evbinds <- getTcEvBinds
        ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
 
-newGivenEvVar :: TcPredType -> EvTerm -> TcS CtEvidence
+newGivenEvVar :: CtLoc -> TcPredType -> EvTerm -> TcS CtEvidence
 -- Make a new variable of the given PredType,
 -- immediately bind it to the given term
 -- and return its CtEvidence
-newGivenEvVar pred rhs
+newGivenEvVar loc pred rhs
   = do { new_ev <- wrapTcS $ TcM.newEvVar pred
        ; setEvBind new_ev rhs
-       ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) }
+       ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) }
 
-newWantedEvVarNC :: TcPredType -> TcS CtEvidence
+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
 -- Don't look up in the solved/inerts; we know it's not there
-newWantedEvVarNC pty
+newWantedEvVarNC loc pty
   = do { new_ev <- wrapTcS $ TcM.newEvVar pty
-       ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })}
+       ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })}
 
-newWantedEvVar :: TcPredType -> TcS MaybeNew
-newWantedEvVar pty
+newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
+newWantedEvVar loc pty
   = do { mb_ct <- lookupInInerts pty
        ; case mb_ct of
             Just ctev | not (isDerived ctev)
                       -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
                             ; return (Cached (ctEvTerm ctev)) }
-            _ -> do { ctev <- newWantedEvVarNC pty
+            _ -> do { ctev <- newWantedEvVarNC loc pty
                     ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
                     ; return (Fresh ctev) } }
 
-newDerived :: TcPredType -> TcS (Maybe CtEvidence)
+newDerived :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
 -- Returns Nothing    if cached,
 --         Just pred  if not cached
-newDerived pty
+newDerived loc pty
   = do { mb_ct <- lookupInInerts pty
        ; return (case mb_ct of
                     Just {} -> Nothing
-                    Nothing -> Just (CtDerived { ctev_pred = pty })) }
+                    Nothing -> Just (CtDerived { ctev_pred = pty, ctev_loc = loc })) }
 
-instDFunConstraints :: TcThetaType -> TcS [MaybeNew]
-instDFunConstraints = mapM newWantedEvVar
+instDFunConstraints :: CtLoc -> TcThetaType -> TcS [MaybeNew]
+instDFunConstraints loc = mapM (newWantedEvVar loc)
 \end{code}
 
 
@@ -1616,18 +1619,18 @@ xCtFlavor :: CtEvidence            -- Original flavor
           -> XEvTerm               -- Instructions about how to manipulate evidence
           -> TcS [CtEvidence]
 
-xCtFlavor (CtGiven { ctev_evtm = tm }) ptys xev
+xCtFlavor (CtGiven { ctev_evtm = tm, ctev_loc = loc }) ptys xev
   = ASSERT( equalLength ptys (ev_decomp xev tm) )
-    zipWithM newGivenEvVar ptys (ev_decomp xev tm)
+    zipWithM (newGivenEvVar loc) ptys (ev_decomp xev tm)
     -- See Note [Bind new Givens immediately]
 
-xCtFlavor (CtWanted { ctev_evar = evar }) ptys xev
-  = do { new_evars <- mapM newWantedEvVar ptys
+xCtFlavor (CtWanted { ctev_evar = evar, ctev_loc = loc }) ptys xev
+  = do { new_evars <- mapM (newWantedEvVar loc) ptys
        ; setEvBind evar (ev_comp xev (getEvTerms new_evars))
        ; return (freshGoals new_evars) }
 
-xCtFlavor (CtDerived {}) ptys _xev
-  = do { ders <- mapM newDerived ptys
+xCtFlavor (CtDerived { ctev_loc = loc }) ptys _xev
+  = do { ders <- mapM (newDerived loc) ptys
        ; return (catMaybes ders) }
 
 -----------------------------
@@ -1659,7 +1662,7 @@ Main purpose: create new evidence for new_pred;
 -}
 
 
-rewriteCtFlavor (CtDerived {}) new_pred _co
+rewriteCtFlavor (CtDerived { ctev_loc = loc }) new_pred _co
   = -- If derived, don't even look at the coercion.
     -- This is very important, DO NOT re-order the equations for
     -- rewriteCtFlavor to put the isTcReflCo test first!
@@ -1667,7 +1670,7 @@ rewriteCtFlavor (CtDerived {}) new_pred _co
     -- was produced by flattening, may contain suspended calls to
     -- (ctEvTerm c), which fails for Derived constraints.
     -- (Getting this wrong caused Trac #7384.)
-    newDerived new_pred
+    newDerived loc new_pred
 
 rewriteCtFlavor old_ev new_pred co
   | isTcReflCo co -- If just reflexivity then you may re-use the same variable
@@ -1680,14 +1683,14 @@ rewriteCtFlavor old_ev new_pred co
        -- However, if they *do* look the same, we'd prefer to stick with old_pred
        -- then retain the old type, so that error messages come out mentioning synonyms
 
-rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
-  = do { new_ev <- newGivenEvVar new_pred new_tm  -- See Note [Bind new Givens immediately]
+rewriteCtFlavor (CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co
+  = do { new_ev <- newGivenEvVar loc new_pred new_tm  -- See Note [Bind new Givens immediately]
        ; return (Just new_ev) }
   where
     new_tm = mkEvCast old_tm (mkTcSymCo co)  -- mkEvCast optimises ReflCo
 
-rewriteCtFlavor (CtWanted { ctev_evar = evar }) new_pred co
-  = do { new_evar <- newWantedEvVar new_pred
+rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
+  = do { new_evar <- newWantedEvVar loc new_pred
        ; setEvBind evar (mkEvCast (getEvTerm new_evar) co)
        ; case new_evar of
             Fresh ctev -> return (Just ctev)
@@ -1741,13 +1744,13 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
             phi1 = Type.substTy subst1 body1
             phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2
             skol_info = UnifyForAllSkol skol_tvs phi1
-        ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2)
+        ; mev <- newWantedEvVar loc (mkTcEqPred phi1 phi2)
         ; coe_inside <- case mev of
             Cached ev_tm -> return (evTermCoercion ev_tm)
             Fresh ctev   -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
                                ; env <- wrapTcS $ TcM.getLclEnv
                                ; let ev_binds = TcEvBinds ev_binds_var
-                                     new_ct = mkNonCanonical loc ctev
+                                     new_ct = mkNonCanonical ctev
                                      new_co = evTermCoercion (ctEvTerm ctev)
                                      new_untch = pushUntouchables (tcl_untch env)
                                ; let wc = WC { wc_flat  = singleCt new_ct
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index b226e4bb72..4a24504860 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -539,9 +539,10 @@ uType, uType_defer
 uType_defer origin ty1 ty2
   = do { eqv <- newEq ty1 ty2
        ; loc <- getCtLoc origin
-       ; let ctev = CtWanted { ctev_evar = eqv
-                             , ctev_pred = mkTcEqPred ty1 ty2 }
-       ; emitFlat $ mkNonCanonical loc ctev 
+       ; emitFlat $ mkNonCanonical $
+             CtWanted { ctev_evar = eqv
+                      , ctev_pred = mkTcEqPred ty1 ty2
+                      , ctev_loc = loc }
 
        -- Error trace only
        -- NB. do *not* call mkErrInfo unless tracing is on, because