TcErrors.lhs 38.7 KB
Newer Older
1
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
2 3 4 5 6 7 8
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

9
module TcErrors( 
10 11 12
       reportUnsolved,
       warnDefaulting,
       unifyCtxt,
13 14 15

       flattenForAllErrorTcS,
       solverDepthErrorTcS
16 17 18 19 20 21 22 23
  ) where

#include "HsVersions.h"

import TcRnMonad
import TcMType
import TcSMonad
import TcType
24
import TypeRep
batterseapower's avatar
batterseapower committed
25
import Type
26
import Kind ( isKind )
batterseapower's avatar
batterseapower committed
27
import Class
dimitris's avatar
dimitris committed
28
import Unify ( tcMatchTys )
29 30 31 32 33
import Inst
import InstEnv
import TyCon
import Name
import NameEnv
34
import Id	( idType )
35 36 37 38 39
import Var
import VarSet
import VarEnv
import SrcLoc
import Bag
batterseapower's avatar
batterseapower committed
40
import BasicTypes ( IPName )
41
import ListSetOps( equivClasses )
42
import Maybes( mapCatMaybes )
43 44 45 46 47
import Util
import FastString
import Outputable
import DynFlags
import Data.List( partition )
batterseapower's avatar
batterseapower committed
48
import Control.Monad( when, unless, filterM )
49 50 51 52 53 54 55 56 57 58 59 60 61
\end{code}

%************************************************************************
%*									*
\section{Errors and contexts}
%*									*
%************************************************************************

ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?

\begin{code}
62 63 64
reportUnsolved :: WantedConstraints -> TcM ()
reportUnsolved wanted
  | isEmptyWC wanted
65 66
  = return ()
  | otherwise
67 68
  = do {   -- Zonk to un-flatten any flatten-skols
       ; wanted  <- zonkWC wanted
69

70
       ; env0 <- tcInitTidyEnv
71 72 73 74
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
             free_tvs = tyVarsOfWC wanted
             err_ctxt = CEC { cec_encl  = []
                            , cec_insol = insolubleWC wanted
75
                            , cec_extra = empty
76 77
                            , cec_tidy  = tidy_env }
             tidy_wanted = tidyWC tidy_env wanted
78

79
       ; traceTc "reportUnsolved" (ppr tidy_wanted)
80

81
       ; reportTidyWanteds err_ctxt tidy_wanted }
82

83 84 85
--------------------------------------------
--      Internal functions
--------------------------------------------
86 87 88 89

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
90 91 92 93 94
          , cec_tidy  :: TidyEnv
          , cec_extra :: SDoc       -- Add this to each error message
          , cec_insol :: Bool       -- True <=> we are reporting insoluble errors only
                                    --      Main effect: don't say "Cannot deduce..."
                                    --      when reporting equality errors; see misMatchOrCND
95 96 97 98
      }

reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
reportTidyImplic ctxt implic
99 100 101 102 103 104 105
  | BracketSkol <- ctLocOrigin (ic_loc implic)
  , not insoluble  -- For Template Haskell brackets report only
  = return ()      -- definite errors. The whole thing will be re-checked
                   -- later when we plug it in, and meanwhile there may
                   -- certainly be un-satisfied constraints

  | otherwise
106 107
  = reportTidyWanteds ctxt' (ic_wanted implic)
  where
108 109 110 111
    insoluble = ic_insol implic
    ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
                 , cec_insol = insoluble }

112
reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
113 114 115 116 117
reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
  | cec_insol ctxt     -- If there are any insolubles, report only them
                       -- because they are unconditionally wrong
                       -- Moreover, if any of the insolubles are givens, stop right there
                       -- ignoring nested errors, because the code is inaccessible
118
  = do { let (given, other) = partitionBag (isGivenOrSolved . cc_flavor) insols
119 120 121 122 123 124 125 126
             insol_implics  = filterBag ic_insol implics
       ; if isEmptyBag given
         then do { mapBagM_ (reportInsoluble ctxt) other
                 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
         else mapBagM_ (reportInsoluble ctxt) given }

  | otherwise          -- No insoluble ones
  = ASSERT( isEmptyBag insols )
127 128 129 130
    do { let flat_evs = bagToList $ mapBag to_wev flats
             to_wev ct | Wanted wl <- cc_flavor ct = mkEvVarX (cc_id ct) wl
                       | otherwise = panic "reportTidyWanteds: unsolved is not wanted!"
             (ambigs, non_ambigs) = partition     is_ambiguous flat_evs
batterseapower's avatar
batterseapower committed
131
       	     (tv_eqs, others)     = partitionWith is_tv_eq     non_ambigs
132 133 134

       ; groupErrs (reportEqErrs ctxt) tv_eqs
       ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
135
       ; mapBagM_ (reportTidyImplic ctxt) implics
136

137 138
       	   -- Only report ambiguity if no other errors (at all) happened
	   -- See Note [Avoiding spurious errors] in TcSimplify
139
       ; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs }
140
  where
141 142 143
	-- Report equalities of form (a~ty) first.  They are usually
	-- skolem-equalities, and they cause confusing knock-on 
	-- effects in other errors; see test T4093b.
batterseapower's avatar
batterseapower committed
144 145 146 147 148
    is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c)
               , tcIsTyVarTy ty1 || tcIsTyVarTy ty2
               = Left (c, (ty1, ty2))
               | otherwise
               = Right (c, evVarOfPred c)
149

150 151 152 153
	-- Treat it as "ambiguous" if 
	--   (a) it is a class constraint
        --   (b) it constrains only type variables
	--       (else we'd prefer to report it as "no instance for...")
154
        --   (c) it mentions a (presumably un-filled-in) meta type variable
155
    is_ambiguous d = isTyVarClassPred pred
batterseapower's avatar
batterseapower committed
156
                  && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred))
157
		  where   
158 159
                     pred = evVarOfPred d

160 161 162 163 164 165
reportInsoluble :: ReportErrCtxt -> Ct -> TcM ()
-- Precondition: insolubles are always NonCanonicals! 
reportInsoluble ctxt ct
  | ev <- cc_id ct
  , flav <- cc_flavor ct 
  , Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev)
166 167 168 169
  = setCtFlavorLoc flav $
    do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
       ; reportEqErr ctxt2 ty1 ty2 }
  | otherwise
170
  = pprPanic "reportInsoluble" (pprEvVarWithType (cc_id ct))
171
  where
172
    inaccessible_msg | Given loc GivenOrig <- (cc_flavor ct)
dimitris's avatar
dimitris committed
173
                       -- If a GivenSolved then we should not report inaccessible code
174 175 176
                     = hang (ptext (sLit "Inaccessible code in"))
                          2 (ppr (ctLocOrigin loc))
                     | otherwise = empty
177

178
reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
179
-- The [PredType] are already tidied
180
reportFlat ctxt flats origin
batterseapower's avatar
batterseapower committed
181 182 183 184
  = do { unless (null dicts)  $ reportDictErrs   ctxt dicts  origin
       ; unless (null eqs)    $ reportEqErrs     ctxt eqs    origin
       ; unless (null ips)    $ reportIPErrs     ctxt ips    origin
       ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin }
185
  where
186
    (dicts, eqs, ips, irreds) = go_many (map classifyPredType flats)
batterseapower's avatar
batterseapower committed
187 188 189 190 191 192 193 194 195 196 197 198 199

    go_many []     = ([], [], [], [])
    go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds')
      where (as, bs, cs, ds) = go t
            (as', bs', cs', ds') = go_many ts

    go (ClassPred cls tys) = ([(cls, tys)], [], [], [])
    go (EqPred ty1 ty2)    = ([], [(ty1, ty2)], [], [])
    go (IPPred ip ty)      = ([], [], [(ip, ty)], [])
    go (IrredPred ty)      = ([], [], [], [ty])
    go (TuplePred {})      = panic "reportFlat"
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
200 201 202 203 204

--------------------------------------------
--      Support code 
--------------------------------------------

batterseapower's avatar
batterseapower committed
205 206
groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group
	  -> [(WantedEvVar, a)]	                -- Unsolved wanteds
207 208 209 210 211 212
          -> TcM ()
-- Group together insts with the same origin
-- We want to report them together in error messages

groupErrs _ [] 
  = return ()
batterseapower's avatar
batterseapower committed
213
groupErrs report_err ((wanted, x) : wanteds)
214
  = do  { setCtLoc the_loc $
batterseapower's avatar
batterseapower committed
215
          report_err the_xs (ctLocOrigin the_loc)
216 217
	; groupErrs report_err others }
  where
218
   the_loc           = evVarX wanted
219
   the_key	     = mk_key the_loc
batterseapower's avatar
batterseapower committed
220 221
   the_xs            = x:map snd friends
   (friends, others) = partition (is_friend . fst) wanteds
222 223 224 225 226 227 228 229 230 231 232
   is_friend friend  = mk_key (evVarX friend) `same_key` the_key

   mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
   mk_key loc = (ctLocSpan loc, ctLocOrigin loc)

   same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
   same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
   same_orig ScOrigin          ScOrigin          = True
   same_orig DerivOrigin       DerivOrigin       = True
   same_orig DefaultOrigin     DefaultOrigin     = True
   same_orig _ _ = False
233 234 235


-- Add the "arising from..." part to a message about bunch of dicts
236 237
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig msg = msg $$ nest 2 (pprArising orig)
238 239 240 241

pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
-- Print something like
--    (Eq a) arising from a use of x at y
242 243
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
244 245
pprWithArising [] 
  = panic "pprWithArising"
246
pprWithArising [EvVarX ev loc]
247
  = (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc)))
248 249 250
pprWithArising ev_vars
  = (first_loc, vcat (map ppr_one ev_vars))
  where
251 252
    first_loc = evVarX (head ev_vars)
    ppr_one (EvVarX v loc)
batterseapower's avatar
batterseapower committed
253
       = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc)
254 255 256 257

addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)

258 259
getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
-- One item for each enclosing implication
260
getUserGivens (CEC {cec_encl = ctxt})
261
  = reverse $
262 263
    [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
                    , not (null givens) ]
264 265
\end{code}

batterseapower's avatar
batterseapower committed
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
reportIrredsErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportIrredsErrs ctxt irreds orig
  = addErrorReport ctxt msg
  where
    givens = getUserGivens ctxt
    msg = couldNotDeduce givens (irreds, orig)
\end{code}

281 282 283 284 285 286 287 288

%************************************************************************
%*									*
                Implicit parameter errors
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
289
reportIPErrs :: ReportErrCtxt -> [(IPName Name, Type)] -> CtOrigin -> TcM ()
290
reportIPErrs ctxt ips orig
291
  = addErrorReport ctxt msg
292
  where
293 294 295 296
    givens = getUserGivens ctxt
    msg | null givens
        = addArising orig $
          sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
batterseapower's avatar
batterseapower committed
297
              , nest 2 (pprTheta (map (uncurry mkIPPred) ips)) ] 
298
        | otherwise
batterseapower's avatar
batterseapower committed
299
        = couldNotDeduce givens (map (uncurry mkIPPred) ips, orig)
300 301 302 303 304 305 306 307 308 309
\end{code}


%************************************************************************
%*									*
                Equality errors
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
310
reportEqErrs :: ReportErrCtxt -> [(Type, Type)] -> CtOrigin -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
311
-- The [PredType] are already tidied
312
reportEqErrs ctxt eqs orig
313 314
  = do { orig' <- zonkTidyOrigin ctxt orig
       ; mapM_ (report_one orig') eqs }
315
  where
batterseapower's avatar
batterseapower committed
316
    report_one orig (ty1, ty2)
317 318
      = do { let extra = getWantedEqExtra orig ty1 ty2
                 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
319
           ; reportEqErr ctxt' ty1 ty2 }
320

321 322 323 324 325
getWantedEqExtra ::  CtOrigin -> TcType -> TcType -> SDoc
getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
                 ty1 ty2
  -- If the types in the error message are the same as the types we are unifying,
  -- don't add the extra expected/actual message
326 327
  | act `eqType` ty1 && exp `eqType` ty2 = empty
  | exp `eqType` ty1 && act `eqType` ty2 = empty
328
  | otherwise                            = mkExpectedActualMsg act exp
329 330 331

getWantedEqExtra orig _ _ = pprArising orig

332
reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
333
-- ty1 and ty2 are already tidied
334 335 336
reportEqErr ctxt ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
337

338 339 340
  | otherwise	-- Neither side is a type variable
    		-- Since the unsolved constraint is canonical, 
		-- it must therefore be of form (F tys ~ ty)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
341
  = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
342

343

344
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
345
-- tv1 and ty2 are already tidied
346
reportTyVarEqErr ctxt tv1 ty2
347 348 349 350
  |  isSkolemTyVar tv1 	  -- ty2 won't be a meta-tyvar, or else the thing would
     		   	  -- be oriented the other way round; see TcCanonical.reOrient
  || isSigTyVar tv1 && not (isTyVarTy ty2)
  = addErrorReport (addExtraInfo ctxt ty1 ty2)
351
                   (misMatchOrCND ctxt ty1 ty2)
352 353 354 355 356 357

  -- So tv is a meta tyvar, and presumably it is
  -- an *untouchable* meta tyvar, else it'd have been unified
  | not (k2 `isSubKind` k1)   	 -- Kind error
  = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)

358 359 360 361 362 363
  -- Occurs check
  | tv1 `elemVarSet` tyVarsOfType ty2
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '=', ppr ty2])
    in addErrorReport ctxt occCheckMsg

364 365 366 367 368 369 370 371 372
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
  , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
        implic_loc = ic_loc implic
  , not (null esc_skols)
  = setCtLoc implic_loc $	-- Override the error message location from the
    	     			-- place the equality arose to the implication site
    do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
       ; let msg = misMatchMsg ty1 ty2
373 374 375 376 377 378
             esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
                             <+> pprQuotedList esc_skols
                           , ptext (sLit "would escape") <+>
                             if isSingleton esc_skols then ptext (sLit "its scope")
                                                      else ptext (sLit "their scope") ]
             extra1 = vcat [ nest 2 $ esc_doc
379
                           , sep [ (if isSingleton esc_skols 
380 381
                                    then ptext (sLit "This (rigid, skolem) type variable is")
                                    else ptext (sLit "These (rigid, skolem) type variables are"))
382
                                   <+> ptext (sLit "bound by")
383
                                 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
384 385 386 387 388 389 390
       ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
  , let implic_loc = ic_loc implic
        given      = ic_given implic
  = setCtLoc (ic_loc implic) $
391 392 393 394
    do { let msg = misMatchMsg ty1 ty2
             extra = quotes (ppr tv1)
                 <+> sep [ ptext (sLit "is untouchable")
                         , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
395
                         , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
396 397
       ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }

398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413
  | otherwise
  = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
    return () 
    	-- I don't think this should happen, and if it does I want to know
	-- Trac #5130 happened because an actual type error was not
	-- reported at all!  So not reporting is pretty dangerous.
	-- 
	-- OLD, OUT OF DATE COMMENT
        -- This can happen, by a recursive decomposition of frozen
        -- occurs check constraints
        -- Example: alpha ~ T Int alpha has frozen.
        --          Then alpha gets unified to T beta gamma
        -- So now we have  T beta gamma ~ T Int (T beta gamma)
        -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
        -- The (gamma ~ T beta gamma) is the occurs check, but
        -- the (beta ~ Int) isn't an error at all.  So return ()
414
  where         
415 416 417
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
418 419 420 421 422 423 424 425 426 427 428 429 430 431

mkTyFunInfoMsg :: TcType -> TcType -> SDoc
-- See Note [Non-injective type functions]
mkTyFunInfoMsg ty1 ty2
  | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
  , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
  , tc1 == tc2, isSynFamilyTyCon tc1
  = ptext (sLit "NB:") <+> quotes (ppr tc1) 
    <+> ptext (sLit "is a type function") <> (pp_inj tc1)
  | otherwise = empty
  where       
    pp_inj tc | isInjectiveTyCon tc = empty
              | otherwise = ptext (sLit (", and may not be injective"))

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
432 433
misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
misMatchOrCND ctxt ty1 ty2
434 435 436
  | cec_insol ctxt = misMatchMsg ty1 ty2    -- If the equality is unconditionally
                                            -- insoluble, don't report the context
  | null givens    = misMatchMsg ty1 ty2
batterseapower's avatar
batterseapower committed
437
  | otherwise      = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig)
438 439 440 441 442 443 444 445
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig)
  = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
              2 (pprArising orig)
dimitris's avatar
dimitris committed
446 447 448 449 450
         , vcat (pp_givens givens)]

pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
pp_givens givens 
   = case givens of
451 452 453
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
dimitris's avatar
dimitris committed
454 455 456 457
    where ppr_given herald (gs,loc)
           = hang (herald <+> pprEvVarTheta gs)
                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
                       , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
458

459 460 461 462
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
addExtraInfo ctxt ty1 ty2
463
  = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
464
  where
465 466
    extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
467 468

misMatchMsg :: TcType -> TcType -> SDoc	   -- Types are already tidy
469 470 471 472 473 474
misMatchMsg ty1 ty2 
  = sep [ ptext cm_ty_or_knd <+> quotes (ppr ty1)
	, nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
  where cm_ty_or_knd
          | isKind ty1 = sLit "Couldn't match kind"
          | otherwise  = sLit "Couldn't match type"
475 476 477 478 479 480 481 482 483 484

kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
kindErrorMsg ty1 ty2
  = vcat [ ptext (sLit "Kind incompatibility when matching types:")
         , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
                        , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
  where
    k1 = typeKind ty1
    k2 = typeKind ty2

485
typeExtraInfoMsg :: [Implication] -> Type -> SDoc
486
-- Shows a bit of extra info about skolem constants
487
typeExtraInfoMsg implics ty
488
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
    SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
    FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
    RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
    MetaTv {}     -> empty

 | otherwise             -- Normal case
 = empty

 where
   ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
   ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
                               sep [ppr info, ptext (sLit "at") <+> ppr loc]]
 
505 506 507
--------------------
unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
508 509 510
  = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
        ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
        ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
511 512 513 514 515

mkExpectedActualMsg :: Type -> Type -> SDoc
mkExpectedActualMsg act_ty exp_ty
  = vcat [ text "Expected type" <> colon <+> ppr exp_ty
         , text "  Actual type" <> colon <+> ppr act_ty ]
516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
\end{code}

Note [Non-injective type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very confusing to get a message like
     Couldn't match expected type `Depend s'
            against inferred type `Depend s1'
so mkTyFunInfoMsg adds:
       NB: `Depend' is type function, and hence may not be injective

Warn of loopy local equalities that were dropped.


%************************************************************************
%*									*
                 Type-class errors
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
536
reportDictErrs :: ReportErrCtxt -> [(Class, [Type])] -> CtOrigin -> TcM ()	
537
reportDictErrs ctxt wanteds orig
538
  = do { inst_envs <- tcGetInstEnvs
batterseapower's avatar
batterseapower committed
539
       ; non_overlaps <- filterM (reportOverlap ctxt inst_envs orig) wanteds
540 541
       ; unless (null non_overlaps) $
         addErrorReport ctxt (mk_no_inst_err non_overlaps) }
542
  where
batterseapower's avatar
batterseapower committed
543
    mk_no_inst_err :: [(Class, [Type])] -> SDoc
544
    mk_no_inst_err wanteds
545
      | null givens     -- Top level
546
      = vcat [ addArising orig $
547 548 549
               ptext (sLit "No instance") <> plural min_wanteds
                    <+> ptext (sLit "for") <+> pprTheta min_wanteds
             , show_fixes (fixes2 ++ fixes3) ]
550

551 552
      | otherwise
      = vcat [ couldNotDeduce givens (min_wanteds, orig)
553
             , show_fixes (fixes1 ++ fixes2 ++ fixes3) ]
554
      where
555
        givens = getUserGivens ctxt
batterseapower's avatar
batterseapower committed
556
        min_wanteds = mkMinimalBySCs (map (uncurry mkClassPred) wanteds)
557

558 559 560 561 562 563
        fixes2 = case instance_dicts of
                   []  -> []
                   [_] -> [sep [ptext (sLit "add an instance declaration for"),
                                pprTheta instance_dicts]]
                   _   -> [sep [ptext (sLit "add instance declarations for"),
                                pprTheta instance_dicts]]
564 565 566 567 568
        fixes3 = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []

        instance_dicts = filterOut isTyVarClassPred min_wanteds
569 570 571
		-- Insts for which it is worth suggesting an adding an 
		-- instance declaration.  Exclude tyvar dicts.

572 573 574
        drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
                        nest 2 $ ptext (sLit "so you can specify the instance context yourself")]

575 576 577 578 579
	show_fixes :: [SDoc] -> SDoc
	show_fixes []     = empty
	show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
				 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]

580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596
        fixes1 | (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt)
               = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds
                        <+> ptext (sLit "to the context of")
	              , nest 2 $ ppr_skol orig $$ 
                                 vcat [ ptext (sLit "or") <+> ppr_skol orig 
                                      | orig <- origs ]
                 ]    ]
               | otherwise = []

        ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
        ppr_skol skol_info      = ppr skol_info

	-- Do not suggest adding constraints to an *inferred* type signature!
        get_good_orig ic = case ctLocOrigin (ic_loc ic) of 
                             SigSkol (InfSigCtxt {}) _ -> Nothing
                             origin                    -> Just origin

597
reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
batterseapower's avatar
batterseapower committed
598
              -> (Class, [Type]) -> TcM Bool
599 600
-- Report an overlap error if this class constraint results
-- from an overlap (returning Nothing), otherwise return (Just pred)
batterseapower's avatar
batterseapower committed
601
reportOverlap ctxt inst_envs orig (clas, tys)
602 603 604 605
  = do { tys_flat <- mapM quickFlattenTy tys
           -- Note [Flattening in error message generation]

       ; case lookupInstEnv inst_envs clas tys_flat of
batterseapower's avatar
batterseapower committed
606
                ([], _, _) -> return True            -- No match
607
                res        -> do { addErrorReport ctxt (mk_overlap_msg res)
batterseapower's avatar
batterseapower committed
608
                                 ; return False } }
609
  where
610 611
    -- Normal overlap error
    mk_overlap_msg (matches, unifiers, False)
612 613
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
614
				<+> pprType (mkClassPred clas tys))
615 616
    	     ,	sep [ptext (sLit "Matching instances") <> colon,
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
dimitris's avatar
dimitris committed
617

618 619 620
             ,  if not (null matching_givens) then 
                  sep [ptext (sLit "Matching givens (or their superclasses)") <> colon
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
621 622
                else empty

623 624 625 626 627 628 629 630 631
             ,  if null matching_givens && isSingleton matches && null unifiers then
                -- Intuitively, some given matched the wanted in their
                -- flattened or rewritten (from given equalities) form
                -- but the matcher can't figure that out because the
                -- constraints are non-flat and non-rewritten so we
                -- simply report back the whole given
                -- context. Accelerate Smart.hs showed this problem.
                  sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
632 633
                else empty 

634 635 636
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
637
    		else 	-- One match
638
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
639
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
640
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
641 642 643
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
644 645 646 647
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
648 649
            matching_givens = mapCatMaybes matchable givens

650 651 652 653 654 655 656
            matchable (evvars,gloc) 
              = case ev_vars_matching of
                     [] -> Nothing
                     _  -> Just $ hang (pprTheta ev_vars_matching)
                                    2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
                                           , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
batterseapower's avatar
batterseapower committed
657 658 659 660 661 662 663 664
                      ev_var_matches ty = case getClassPredTys_maybe ty of
                         Just (clas', tys')
                           | clas' == clas
                           , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
                           -> True 
                           | otherwise
                           -> any ev_var_matches (immSuperClasses clas' tys')
                         Nothing -> False
665

666
    -- Overlap error because of Safe Haskell (first match should be the most
667
    -- specific match)
668
    mk_overlap_msg (matches, _unifiers, True)
669 670
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
671
                        <+> pprType (mkClassPred clas tys))
672 673 674 675 676 677 678 679 680 681
             , sep [ptext (sLit "The matching instance is") <> colon,
                    nest 2 (pprInstance $ head ispecs)]
             , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
                    , ptext $ sLit "overlap instances from the same module, however it"
                    , ptext $ sLit "overlaps the following instances from different modules:"
                    , nest 2 (vcat [pprInstances $ tail ispecs])
                    ]
             ]
        where
            ispecs = [ispec | (ispec, _) <- matches]
dimitris's avatar
dimitris committed
682

683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731
----------------------
quickFlattenTy :: TcType -> TcM TcType
-- See Note [Flattening in error message generation]
quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
quickFlattenTy ty@(TyVarTy {})  = return ty
quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
  -- Don't flatten because of the danger or removing a bound variable
quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (AppTy fy1 fy2) }
quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (FunTy fy1 fy2) }
quickFlattenTy (TyConApp tc tys)
    | not (isSynFamilyTyCon tc)
    = do { fys <- mapM quickFlattenTy tys 
         ; return (TyConApp tc fys) }
    | otherwise
    = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
                -- Ignore the arguments of the type family funtys
         ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
         ; flat_resttys <- mapM quickFlattenTy resttys
         ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
\end{code}

Note [Flattening in error message generation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (C (Maybe (F x))), where F is a type function, and we have
instances
                C (Maybe Int) and C (Maybe a)
Since (F x) might turn into Int, this is an overlap situation, and
indeed (because of flattening) the main solver will have refrained
from solving.  But by the time we get to error message generation, we've
un-flattened the constraint.  So we must *re*-flatten it before looking
up in the instance environment, lest we only report one matching
instance when in fact there are two.

Re-flattening is pretty easy, because we don't need to keep track of
evidence.  We don't re-use the code in TcCanonical because that's in
the TcS monad, and we are in TcM here.

Note [Quick-flatten polytypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
flattening any further.  After all, there can be no instance declarations
that match such things.  And flattening under a for-all is problematic
anyway; consider C (forall a. F a)

\begin{code}
732 733
reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt ambigs 
734
-- Divide into groups that share a common set of ambiguous tyvars
735 736 737
  = mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs) 
 where
    ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d)))
738 739 740
                   | d <- ambigs ]
    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2

741 742 743 744 745 746 747 748

reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM ()
-- The pairs all have the same [TcTyVar]
reportAmbigGroup ctxt pairs
  = setCtLoc loc $
    do { dflags <- getDOpts
       ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs)
       ; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) }
749
  where
750 751 752 753 754 755 756 757 758
    (wev, tvs) : _ = pairs
    (loc, pp_wanteds) = pprWithArising (map fst pairs)
    main_msg = sep [ text "Ambiguous type variable" <> plural tvs
	             <+> pprQuotedList tvs
                     <+> text "in the constraint" <> plural pairs <> colon
                   , nest 2 pp_wanteds ]

    mk_msg dflags docs 
        | any isRuntimeUnkSkol tvs  -- See Note [Runtime skolems]
759
        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
760 761 762 763 764 765 766 767
                   (pprWithCommas ppr tvs),
                 ptext (sLit "Use :print or :force to determine these types")]

        | DerivOrigin <- ctLocOrigin (evVarX wev)
        = ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead")

        | null docs 
        = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
768 769 770
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
771
        | otherwise
772 773
	= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
		nest 2 (vcat docs),
774 775 776 777 778 779 780 781 782 783
		mono_fix dflags]

    mono_fix :: DynFlags -> SDoc
    mono_fix dflags
      = ptext (sLit "Probable fix:") <+> vcat
     	[ptext (sLit "give these definition(s) an explicit type signature"),
     	 if xopt Opt_MonomorphismRestriction dflags
         then ptext (sLit "or use -XNoMonomorphismRestriction")
         else empty]	-- Only suggest adding "-XNoMonomorphismRestriction"
     			-- if it is not already set!
784

785 786 787 788 789 790 791 792
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
  = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
    UnkSkol
getSkolemInfo (implic:implics) tv
  | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
  | otherwise                       = getSkolemInfo implics tv

793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827
-----------------------
-- findGlobals looks at the value environment and finds values whose
-- types mention any of the offending type variables.  It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.

mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
mkEnvSigMsg what env_sigs
 | null env_sigs = empty
 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
                    , nest 2 (vcat env_sigs) ]

findGlobals :: ReportErrCtxt
            -> TcTyVarSet
            -> TcM (TidyEnv, [SDoc])

findGlobals ctxt tvs 
  = do { lcl_ty_env <- case cec_encl ctxt of 
                        []    -> getLclTypeEnv
                        (i:_) -> return (ic_env i)
       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
  where
    go tidy_env acc [] = return (tidy_env, acc)
    go tidy_env acc (thing : things) = do
        (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
	case maybe_doc of
	  Just d  -> go tidy_env1 (d:acc) things
	  Nothing -> go tidy_env1 acc     things

    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty

-----------------------
find_thing :: TidyEnv -> (TcType -> Bool)
           -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
find_thing tidy_env ignore_it (ATcId { tct_id = id })
828 829
  = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
       ; if ignore_it tidy_ty then
830 831
	   return (tidy_env, Nothing)
         else do 
832
       { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
833 834 835 836 837
		       , nest 2 (parens (ptext (sLit "bound at") <+>
			 	   ppr (getSrcLoc id)))]
       ; return (tidy_env', Just msg) } }

find_thing tidy_env ignore_it (ATyVar tv ty)
838 839
  = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
       ; if ignore_it tidy_ty then
840 841 842 843 844 845
	    return (tidy_env, Nothing)
         else do
       { let -- The name tv is scoped, so we don't need to tidy it
            msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
                      , nest 2 bound_at]

846
            eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
847 848 849 850 851 852 853 854 855
		     , getOccName tv == getOccName tv' = empty
		     | otherwise = equals <+> ppr tidy_ty
		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
	    bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 
       ; return (tidy_env1, Just msg) } }

find_thing _ _ thing = pprPanic "find_thing" (ppr thing)

856
warnDefaulting :: [Ct] -> Type -> TcM ()
857
warnDefaulting wanteds default_ty
858
  = do { warn_default <- woptM Opt_WarnTypeDefaults
859 860 861
       ; env0 <- tcInitTidyEnv
       ; let wanted_bag = listToBag wanteds
             tidy_env = tidyFreeTyVars env0 $
862 863 864
                        tyVarsOfCts wanted_bag
             tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag
             (loc, ppr_wanteds) = pprWithArising (map mk_wev (bagToList tidy_wanteds))
865 866 867
             warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                <+> quotes (ppr default_ty))
                            2 ppr_wanteds
868
       ; setCtLoc loc $ warnTc warn_default warn_msg }
869 870 871 872 873 874 875
  where mk_wev :: Ct -> WantedEvVar 
        mk_wev ct 
           | ev <- cc_id ct 
           , Wanted wloc <- cc_flavor ct
           = EvVarX ev wloc -- must return a WantedEvVar 
        mk_wev _ct = panic "warnDefaulting: encountered non-wanted for defaulting"

876 877
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
878 879 880
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
881 882
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.  
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
883

884 885 886
%************************************************************************
%*									*
                 Error from the canonicaliser
887
	 These ones are called *during* constraint simplification
888 889 890 891
%*									*
%************************************************************************

\begin{code}
892
solverDepthErrorTcS :: Int -> [Ct] -> TcS a
893 894 895 896 897 898
solverDepthErrorTcS depth stack
  | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
  = wrapErrTcS $ failWith msg
  | otherwise
  = wrapErrTcS $ 
    setCtFlavorLoc (cc_flavor top_item) $
899 900 901 902 903
    do { ev_vars <- mapM (zonkEvVar . cc_id) stack
       ; env0 <- tcInitTidyEnv
       ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
             tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
       ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
904 905 906 907 908
  where
    top_item = head stack
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]

909 910
flattenForAllErrorTcS :: CtFlavor -> TcType -> TcS a
flattenForAllErrorTcS fl ty
911
  = wrapErrTcS        $ 
912 913 914 915 916 917 918
    setCtFlavorLoc fl $ 
    do { env0 <- tcInitTidyEnv
       ; let (env1, ty') = tidyOpenType env0 ty 
             msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
                       , ppr ty' ]
       ; failWithTcM (env1, msg) }
\end{code}
919 920 921 922 923 924 925 926 927

%************************************************************************
%*									*
                 Setting the context
%*									*
%************************************************************************

\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
dimitris's avatar
dimitris committed
928 929 930
setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc)   thing = setCtLoc loc thing
setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951
\end{code}

%************************************************************************
%*									*
                 Tidying
%*									*
%************************************************************************

\begin{code}
zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType env ty = do { ty' <- zonkTcType ty
                           ; return (tidyOpenType env ty') }

zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
  = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
       ; (_env2, exp') <- zonkTidyTcType env1            exp
       ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
       -- Drop the returned env on the floor; we may conceivably thereby get
       -- inconsistent naming between uses of this function
zonkTidyOrigin _ orig = return orig
952
\end{code}