Implememt -fdefer-type-errors (Trac #5624)
[ghc.git] / compiler / typecheck / TcErrors.lhs
1 \begin{code}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# OPTIONS -fno-warn-tabs #-}
4 -- The above warning supression flag is a temporary kludge.
5 -- While working on this module you are encouraged to remove it and
6 -- detab the module (please do the detabbing in a separate patch). See
7 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
8 -- for details
9
10 module TcErrors( 
11        reportUnsolved, ErrEnv,
12        warnDefaulting,
13        unifyCtxt,
14        misMatchMsg,
15
16        flattenForAllErrorTcS,
17        solverDepthErrorTcS
18   ) where
19
20 #include "HsVersions.h"
21
22 import TcRnMonad
23 import TcMType
24 import TcType
25 import TypeRep
26 import Type
27 import Kind ( isKind )
28 import Unify            ( tcMatchTys )
29 import Inst
30 import InstEnv
31 import TyCon
32 import TcEvidence
33 import Name
34 import NameEnv
35 import Id               ( idType )
36 import Var
37 import VarSet
38 import VarEnv
39 import Bag
40 import Maybes
41 import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
42 import Util
43 import FastString
44 import Outputable
45 import DynFlags
46 import Data.List        ( partition, mapAccumL )
47 import Data.Either      ( partitionEithers )
48 -- import Control.Monad    ( when )
49 \end{code}
50
51 %************************************************************************
52 %*                                                                      *
53 \section{Errors and contexts}
54 %*                                                                      *
55 %************************************************************************
56
57 ToDo: for these error messages, should we note the location as coming
58 from the insts, or just whatever seems to be around in the monad just
59 now?
60
61 \begin{code}
62 -- We keep an environment mapping coercion ids to the error messages they
63 -- trigger; this is handy for -fwarn--type-errors
64 type ErrEnv = VarEnv [ErrMsg]
65
66 reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind)
67 reportUnsolved runtimeCoercionErrors wanted
68   | isEmptyWC wanted
69   = return emptyBag
70   | otherwise
71   = do {   -- Zonk to un-flatten any flatten-skols
72          wanted  <- zonkWC wanted
73
74        ; env0 <- tcInitTidyEnv
75        ; defer <- if runtimeCoercionErrors 
76                   then do { ev <- newTcEvBinds
77                           ; return (Just ev) }
78                   else return Nothing
79
80        ; errs_so_far <- ifErrsM (return True) (return False)
81        ; let tidy_env = tidyFreeTyVars env0 free_tvs
82              free_tvs = tyVarsOfWC wanted
83              err_ctxt = CEC { cec_encl  = []
84                             , cec_insol = errs_so_far
85                             , cec_extra = empty
86                             , cec_tidy  = tidy_env
87                             , cec_defer = defer }
88
89        ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted)
90
91        ; reportWanteds err_ctxt wanted
92
93        ; case defer of
94            Nothing -> return emptyBag
95            Just ev -> getTcEvBinds ev }
96
97 --------------------------------------------
98 --      Internal functions
99 --------------------------------------------
100
101 data ReportErrCtxt 
102     = CEC { cec_encl :: [Implication]  -- Enclosing implications
103                                        --   (innermost first)
104                                        -- ic_skols and givens are tidied, rest are not
105           , cec_tidy  :: TidyEnv
106           , cec_extra :: SDoc       -- Add this to each error message
107           , cec_insol :: Bool       -- True <=> do not report errors involving 
108                                     --          ambiguous errors
109           , cec_defer :: Maybe EvBindsVar 
110                          -- Nothinng <=> errors are, well, errors
111                          -- Just ev  <=> make errors into warnings, and emit evidence
112                          --              bindings into 'ev' for unsolved constraints
113       }
114
115 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
116 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
117                                  , ic_wanted = wanted, ic_binds = evb
118                                  , ic_insol = insoluble, ic_loc = loc })
119   | BracketSkol <- ctLocOrigin loc
120   , not insoluble -- For Template Haskell brackets report only
121   = return ()     -- definite errors. The whole thing will be re-checked
122                   -- later when we plug it in, and meanwhile there may
123                   -- certainly be un-satisfied constraints
124
125   | otherwise
126   = reportWanteds ctxt' wanted
127   where
128     (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
129     implic' = implic { ic_skols = tvs'
130                      , ic_given = map (tidyEvVar env1) given
131                      , ic_loc   = tidyGivenLoc env1 loc }
132     ctxt' = ctxt { cec_tidy  = env1
133                  , cec_encl  = implic' : cec_encl ctxt
134                  , cec_defer = case cec_defer ctxt of
135                                  Nothing -> Nothing
136                                  Just {} -> Just evb }
137
138 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
139 reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
140   = reportTidyWanteds ctxt tidy_insols tidy_flats implics
141   where
142     env = cec_tidy ctxt
143     tidy_insols = mapBag (tidyCt env) insols
144     tidy_flats  = mapBag (tidyCt env) flats
145
146 reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM ()
147 reportTidyWanteds ctxt insols flats implics
148   | Just ev_binds_var <- cec_defer ctxt
149   = do { -- Defer errors to runtime
150          -- See Note [Deferring coercion errors to runtime] in TcSimplify
151          mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) 
152                   (flats `unionBags` insols)
153        ; mapBagM_ (reportImplic ctxt) implics }
154
155   | otherwise
156   = do { reportInsolsAndFlats ctxt insols flats
157        ; mapBagM_ (reportImplic ctxt) implics }
158              
159
160 deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
161                -> Ct -> TcM ()
162 deferToRuntime ev_binds_var ctxt mk_err_msg ct 
163   | Wanted loc <- cc_flavor ct
164   = do { err <- setCtLoc loc $
165                 mk_err_msg ctxt ct
166        ; let ev_id   = cc_id ct
167              err_msg = pprLocErrMsg err
168              err_fs  = mkFastString $ showSDoc $ 
169                        err_msg $$ text "(deferred type error)"
170
171          -- Create the binding
172        ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs)
173
174          -- And emit a warning
175        ; reportWarning (makeIntoWarning err) }
176
177   | otherwise   -- Do not set any evidence for Given/Derived
178   = return ()   
179
180 reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM ()
181 reportInsolsAndFlats ctxt insols flats
182   = tryReporters 
183       [ -- First deal with things that are utterly wrong
184         -- Like Int ~ Bool (incl nullary TyCons)
185         -- or  Int ~ t a   (AppTy on one side)
186         ("Utterly wrong",  utterly_wrong,   groupErrs (mkEqErr ctxt))
187
188         -- Report equalities of form (a~ty).  They are usually
189         -- skolem-equalities, and they cause confusing knock-on 
190         -- effects in other errors; see test T4093b.
191       , ("Skolem equalities",    skolem_eq,       mkReporter (mkEqErr1 ctxt))
192
193       , ("Unambiguous",          unambiguous,     reportFlatErrs ctxt) ]
194       (reportAmbigErrs ctxt)
195       (bagToList (insols `unionBags` flats))
196   where
197     utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool
198
199     utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 
200     utterly_wrong _ _ = False
201
202     skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
203     skolem_eq _ _ = False
204
205     unambiguous ct pred 
206       | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct)))
207       = True
208       | otherwise 
209       = case pred of
210           EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
211           _              -> False
212
213 ---------------
214 isRigid, isRigidOrSkol :: Type -> Bool
215 isRigid ty 
216   | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
217   | Just {} <- tcSplitAppTy_maybe ty        = True
218   | isForAllTy ty                           = True
219   | otherwise                               = False
220
221 isRigidOrSkol ty 
222   | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv
223   | otherwise                    = isRigid ty
224
225 isTyFun_maybe :: Type -> Maybe TyCon
226 isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
227                       Just (tc,_) | isSynFamilyTyCon tc -> Just tc
228                       _ -> Nothing
229
230 -----------------
231 type Reporter = [Ct] -> TcM ()
232
233 mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM ()
234 -- Reports errors one at a time
235 mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $
236                                               mk_err ct; 
237                                      ; reportError err })
238
239 tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter
240 tryReporters reporters deflt cts
241   = do { traceTc "tryReporters {" (ppr cts) 
242        ; go reporters cts
243        ; traceTc "tryReporters }" empty }
244   where
245     go [] cts = deflt cts 
246     go ((str, pred, reporter) : rs) cts
247       | null yeses  = traceTc "tryReporters: no" (text str) >> 
248                       go rs cts
249       | otherwise   = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> 
250                       reporter yeses
251       where
252        yeses = filter keep_me cts
253        keep_me ct = pred ct (classifyPredType (ctPred ct))
254
255 -----------------
256 mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg
257 -- Context is already set
258 mkFlatErr ctxt ct   -- The constraint is always wanted
259   = case classifyPredType (ctPred ct) of
260       ClassPred {}  -> mkDictErr  ctxt [ct]
261       IPPred {}     -> mkIPErr    ctxt [ct]
262       IrredPred {}  -> mkIrredErr ctxt [ct]
263       EqPred {}     -> mkEqErr1 ctxt ct
264       TuplePred {}  -> panic "mkFlat"
265       
266 reportAmbigErrs :: ReportErrCtxt -> Reporter
267 reportAmbigErrs ctxt cts
268   | cec_insol ctxt = return ()
269   | otherwise      = reportFlatErrs ctxt cts
270           -- Only report ambiguity if no other errors (at all) happened
271           -- See Note [Avoiding spurious errors] in TcSimplify
272
273 reportFlatErrs :: ReportErrCtxt -> Reporter
274 -- Called once for non-ambigs, once for ambigs
275 -- Report equality errors, and others only if we've done all 
276 -- the equalities.  The equality errors are more basic, and
277 -- can lead to knock on type-class errors
278 reportFlatErrs ctxt cts
279   = tryReporters
280       [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ]
281       (\cts -> do { let (dicts, ips, irreds) = go cts [] [] []
282                   ; groupErrs (mkIPErr    ctxt) ips   
283                   ; groupErrs (mkIrredErr ctxt) irreds
284                   ; groupErrs (mkDictErr  ctxt) dicts })
285       cts
286   where
287     is_equality _ (EqPred {}) = True
288     is_equality _ _           = False
289
290     go [] dicts ips irreds
291       = (dicts, ips, irreds)
292     go (ct:cts) dicts ips irreds
293       = case classifyPredType (ctPred ct) of
294           ClassPred {}  -> go cts (ct:dicts) ips irreds
295           IPPred {}     -> go cts dicts (ct:ips) irreds
296           IrredPred {}  -> go cts dicts ips (ct:irreds)
297           _             -> panic "mkFlat"
298     -- TuplePreds should have been expanded away by the constraint
299     -- simplifier, so they shouldn't show up at this point
300     -- And EqPreds are dealt with by the is_equality test
301
302
303 --------------------------------------------
304 --      Support code 
305 --------------------------------------------
306
307 groupErrs :: ([Ct] -> TcM ErrMsg)  -- Deal with one group
308           -> [Ct]                  -- Unsolved wanteds
309           -> TcM ()
310 -- Group together insts from same location
311 -- We want to report them together in error messages
312
313 groupErrs _ [] 
314   = return ()
315 groupErrs mk_err (ct1 : rest)
316   = do  { err <- setCtFlavorLoc flavor $ mk_err cts
317         ; reportError err
318         ; groupErrs mk_err others }
319   where
320    flavor            = cc_flavor ct1
321    cts               = ct1 : friends
322    (friends, others) = partition is_friend rest
323    is_friend friend  = cc_flavor friend `same_group` flavor
324
325    same_group :: CtFlavor -> CtFlavor -> Bool
326    same_group (Given l1 _) (Given l2 _) = same_loc l1 l2
327    same_group (Derived l1) (Derived l2) = same_loc l1 l2
328    same_group (Wanted l1)  (Wanted l2)  = same_loc l1 l2
329    same_group _ _ = False
330
331    same_loc :: CtLoc o -> CtLoc o -> Bool
332    same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2
333
334 -- Add the "arising from..." part to a message about bunch of dicts
335 addArising :: CtOrigin -> SDoc -> SDoc
336 addArising orig msg = msg $$ nest 2 (pprArising orig)
337
338 pprWithArising :: [Ct] -> (WantedLoc, SDoc)
339 -- Print something like
340 --    (Eq a) arising from a use of x at y
341 --    (Show a) arising from a use of p at q
342 -- Also return a location for the error message
343 -- Works for Wanted/Derived only
344 pprWithArising [] 
345   = panic "pprWithArising"
346 pprWithArising (ct:cts)
347   | null cts
348   = (loc, hang (pprEvVarTheta [cc_id ct]) 
349              2 (pprArising (ctLocOrigin (ctWantedLoc ct))))
350   | otherwise
351   = (loc, vcat (map ppr_one (ct:cts)))
352   where
353     loc = ctWantedLoc ct
354     ppr_one ct = hang (parens (pprType (ctPred ct))) 
355                     2 (pprArisingAt (ctWantedLoc ct))
356
357 mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg
358 mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
359
360 type UserGiven = ([EvVar], GivenLoc)
361
362 getUserGivens :: ReportErrCtxt -> [UserGiven]
363 -- One item for each enclosing implication
364 getUserGivens (CEC {cec_encl = ctxt})
365   = reverse $
366     [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
367                     , not (null givens) ]
368 \end{code}
369
370 %************************************************************************
371 %*                  *
372                 Irreducible predicate errors
373 %*                  *
374 %************************************************************************
375
376 \begin{code}
377 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
378 mkIrredErr ctxt cts 
379   = mkErrorReport ctxt msg
380   where
381     (ct1:_) = cts
382     orig    = ctLocOrigin (ctWantedLoc ct1)
383     givens  = getUserGivens ctxt
384     msg = couldNotDeduce givens (map ctPred cts, orig)
385 \end{code}
386
387
388 %************************************************************************
389 %*                                                                      *
390                 Implicit parameter errors
391 %*                                                                      *
392 %************************************************************************
393
394 \begin{code}
395 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
396 mkIPErr ctxt cts
397   = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts
398        ; mkErrorReport ctxt' (msg $$ ambig_err) }
399   where
400     (ct1:_) = cts
401     orig    = ctLocOrigin (ctWantedLoc ct1)
402     preds   = map ctPred cts
403     givens  = getUserGivens ctxt
404     msg | null givens
405         = addArising orig $
406           sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
407               , nest 2 (pprTheta preds) ] 
408         | otherwise
409         = couldNotDeduce givens (preds, orig)
410 \end{code}
411
412
413 %************************************************************************
414 %*                                                                      *
415                 Equality errors
416 %*                                                                      *
417 %************************************************************************
418
419 \begin{code}
420 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
421 -- Don't have multiple equality errors from the same location
422 -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
423 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
424 mkEqErr _ [] = panic "mkEqErr"
425
426 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
427 -- Wanted constraints only!
428 mkEqErr1 ctxt ct
429   = case cc_flavor ct of
430        Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2
431               where
432                  ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ 
433                                 inaccessible_msg gl gk }  
434     
435        flav -> do { let orig = ctLocOrigin (getWantedLoc flav)
436                   ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig
437                   ; mk_err ctxt1 orig' }
438   where
439      -- If a GivenSolved then we should not report inaccessible code
440     inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in"))
441                                         2 (ppr (ctLocOrigin loc))
442     inaccessible_msg _ _ = empty
443
444     (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct))
445
446        -- If the types in the error message are the same as the types
447        -- we are unifying, don't add the extra expected/actual message
448     mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) 
449       | act `pickyEqType` ty1
450       , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True  ty2 ty1
451       | exp `pickyEqType` ty1
452       , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True  ty1 ty2
453       | otherwise             = mkEqErr_help ctxt2 ct False ty1 ty2
454       where
455         ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 }
456         msg   = mkExpectedActualMsg exp act
457     mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2
458
459 mkEqErr_help :: ReportErrCtxt
460              -> Ct
461              -> Bool     -- True  <=> Types are correct way round;
462                          --           report "expected ty1, actual ty2"
463                          -- False <=> Just report a mismatch without orientation
464                          --           The ReportErrCtxt has expected/actual 
465              -> TcType -> TcType -> TcM ErrMsg
466 mkEqErr_help ctxt ct oriented ty1 ty2
467   | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2
468   | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1
469   | otherwise   -- Neither side is a type variable
470   = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2
471        ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) }
472
473 mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg
474 -- tv1 and ty2 are already tidied
475 mkTyVarEqErr ctxt ct oriented tv1 ty2
476   |  isSkolemTyVar tv1    -- ty2 won't be a meta-tyvar, or else the thing would
477                           -- be oriented the other way round; see TcCanonical.reOrient
478   || isSigTyVar tv1 && not (isTyVarTy ty2)
479   = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2)
480                   (misMatchOrCND ctxt ct oriented ty1 ty2)
481
482   -- So tv is a meta tyvar, and presumably it is
483   -- an *untouchable* meta tyvar, else it'd have been unified
484   | not (k2 `isSubKind` k1)      -- Kind error
485   = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
486
487   -- Occurs check
488   | tv1 `elemVarSet` tyVarsOfType ty2
489   = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
490                            (sep [ppr ty1, char '=', ppr ty2])
491     in mkErrorReport ctxt occCheckMsg
492
493   -- Check for skolem escape
494   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
495   , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
496         implic_loc = ic_loc implic
497   , not (null esc_skols)
498   = setCtLoc implic_loc $       -- Override the error message location from the
499                                 -- place the equality arose to the implication site
500     do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1)
501        ; let msg = misMatchMsg oriented ty1 ty2
502              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
503                              <+> pprQuotedList esc_skols
504                            , ptext (sLit "would escape") <+>
505                              if isSingleton esc_skols then ptext (sLit "its scope")
506                                                       else ptext (sLit "their scope") ]
507              extra1 = vcat [ nest 2 $ esc_doc
508                            , sep [ (if isSingleton esc_skols 
509                                     then ptext (sLit "This (rigid, skolem) type variable is")
510                                     else ptext (sLit "These (rigid, skolem) type variables are"))
511                                    <+> ptext (sLit "bound by")
512                                  , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
513        ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
514
515   -- Nastiest case: attempt to unify an untouchable variable
516   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
517   , let implic_loc = ic_loc implic
518         given      = ic_given implic
519   = setCtLoc (ic_loc implic) $
520     do { let msg = misMatchMsg oriented ty1 ty2
521              extra = quotes (ppr tv1)
522                  <+> sep [ ptext (sLit "is untouchable")
523                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
524                          , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
525        ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
526
527   | otherwise
528   = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
529     panic "mkTyVarEqErr"
530         -- I don't think this should happen, and if it does I want to know
531         -- Trac #5130 happened because an actual type error was not
532         -- reported at all!  So not reporting is pretty dangerous.
533         -- 
534         -- OLD, OUT OF DATE COMMENT
535         -- This can happen, by a recursive decomposition of frozen
536         -- occurs check constraints
537         -- Example: alpha ~ T Int alpha has frozen.
538         --          Then alpha gets unified to T beta gamma
539         -- So now we have  T beta gamma ~ T Int (T beta gamma)
540         -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
541         -- The (gamma ~ T beta gamma) is the occurs check, but
542         -- the (beta ~ Int) isn't an error at all.  So return ()
543   where         
544     k1  = tyVarKind tv1
545     k2  = typeKind ty2
546     ty1 = mkTyVarTy tv1
547
548 mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt
549 -- Report (a) ambiguity if either side is a type function application
550 --            e.g. F a0 ~ Int    
551 --        (b) warning about injectivity if both sides are the same
552 --            type function application   F a ~ F b
553 --            See Note [Non-injective type functions]
554 mkEqInfoMsg ctxt ct ty1 ty2
555   = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2
556                                   then mkAmbigMsg ctxt [ct]
557                                   else return (ctxt, False, empty)
558        ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) }
559   where
560     mb_fun1 = isTyFun_maybe ty1
561     mb_fun2 = isTyFun_maybe ty2
562     tyfun_msg | Just tc1 <- mb_fun1
563               , Just tc2 <- mb_fun2
564               , tc1 == tc2 
565               = ptext (sLit "NB:") <+> quotes (ppr tc1) 
566                 <+> ptext (sLit "is a type function, and may not be injective")
567               | otherwise = empty
568
569 misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc
570 -- If oriented then ty1 is expected, ty2 is actual
571 misMatchOrCND ctxt ct oriented ty1 ty2
572   | null givens || 
573     (isRigid ty1 && isRigid ty2) || 
574     isGivenOrSolved (cc_flavor ct)
575        -- If the equality is unconditionally insoluble
576        -- or there is no context, don't report the context
577   = misMatchMsg oriented ty1 ty2
578   | otherwise      
579   = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig)
580   where
581     givens = getUserGivens ctxt
582     orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)
583
584 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
585 couldNotDeduce givens (wanteds, orig)
586   = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
587               2 (pprArising orig)
588          , vcat (pp_givens givens)]
589
590 pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
591 pp_givens givens 
592    = case givens of
593          []     -> []
594          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
595                  : map (ppr_given (ptext (sLit "or from"))) gs
596     where ppr_given herald (gs,loc)
597            = hang (herald <+> pprEvVarTheta gs)
598                 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
599                        , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
600
601 addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
602 -- Add on extra info about the types themselves
603 -- NB: The types themselves are already tidied
604 addExtraTyVarInfo ctxt ty1 ty2
605   = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
606   where
607     extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
608     extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
609
610 tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
611 -- Shows a bit of extra info about skolem constants
612 tyVarExtraInfoMsg implics ty
613   | Just tv <- tcGetTyVar_maybe ty
614   , isTcTyVar tv, isSkolemTyVar tv
615   , let pp_tv = quotes (ppr tv)
616  = case tcTyVarDetails tv of
617     SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
618     FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
619     RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
620     MetaTv {}     -> empty
621
622  | otherwise             -- Normal case
623  = empty
624
625  where
626    ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
627    ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
628                                sep [ppr info, ptext (sLit "at") <+> ppr loc]]
629  
630 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
631 kindErrorMsg ty1 ty2
632   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
633          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
634                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
635   where
636     k1 = typeKind ty1
637     k2 = typeKind ty2
638
639 --------------------
640 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
641 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
642   = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
643         ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
644         ; return (env2, mkExpectedActualMsg exp_ty' act_ty') }
645
646 misMatchMsg :: Bool -> TcType -> TcType -> SDoc    -- Types are already tidy
647 -- If oriented then ty1 is expected, ty2 is actual
648 misMatchMsg oriented ty1 ty2 
649   | oriented
650   = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1)
651         , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ]
652   | otherwise
653   = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
654         , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ]
655   where 
656     what | isKind ty1 = ptext (sLit "kind")
657          | otherwise  = ptext (sLit "type")
658
659 mkExpectedActualMsg :: Type -> Type -> SDoc
660 mkExpectedActualMsg exp_ty act_ty
661   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
662          , text "  Actual type" <> colon <+> ppr act_ty ]
663 \end{code}
664
665 Note [Non-injective type functions]
666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
667 It's very confusing to get a message like
668      Couldn't match expected type `Depend s'
669             against inferred type `Depend s1'
670 so mkTyFunInfoMsg adds:
671        NB: `Depend' is type function, and hence may not be injective
672
673 Warn of loopy local equalities that were dropped.
674
675
676 %************************************************************************
677 %*                                                                      *
678                  Type-class errors
679 %*                                                                      *
680 %************************************************************************
681
682 \begin{code}
683 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
684 mkDictErr ctxt cts 
685   = do { inst_envs <- tcGetInstEnvs
686        ; stuff <- mapM (mkOverlap ctxt inst_envs orig) cts
687        ; let (non_overlaps, overlap_errs) = partitionEithers stuff
688        ; if null non_overlaps
689          then mkErrorReport ctxt (vcat overlap_errs)
690          else do
691        { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt cts
692        ; mkErrorReport ctxt' 
693             (vcat [ mkNoInstErr givens non_overlaps orig
694                   , ambig_msg
695                   , mk_no_inst_fixes is_ambig non_overlaps]) } }
696   where
697     (ct1:_) = cts
698     orig    = ctLocOrigin (ctWantedLoc ct1)
699
700     givens = getUserGivens ctxt
701
702     mk_no_inst_fixes is_ambig cts 
703       | null givens = show_fixes (fixes2 ++ fixes3)
704       | otherwise   = show_fixes (fixes1 ++ fixes2 ++ fixes3) 
705       where
706         min_wanteds = map ctPred cts
707         instance_dicts = filterOut isTyVarClassPred min_wanteds
708                 -- Insts for which it is worth suggesting an adding an 
709                 -- instance declaration.  Exclude tyvar dicts.
710
711         fixes2 = case instance_dicts of
712                    []  -> []
713                    [_] -> [sep [ptext (sLit "add an instance declaration for"),
714                                 pprTheta instance_dicts]]
715                    _   -> [sep [ptext (sLit "add instance declarations for"),
716                                 pprTheta instance_dicts]]
717         fixes3 = case orig of
718                    DerivOrigin -> [drv_fix]
719                    _           -> []
720
721         drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
722                         nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
723
724         fixes1 | not is_ambig
725                , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt)
726                = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds
727                         <+> ptext (sLit "to the context of")
728                       , nest 2 $ ppr_skol orig $$ 
729                                  vcat [ ptext (sLit "or") <+> ppr_skol orig 
730                                       | orig <- origs ]
731                  ]    ]
732                | otherwise = []
733
734         ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
735         ppr_skol skol_info      = ppr skol_info
736
737         -- Do not suggest adding constraints to an *inferred* type signature!
738         get_good_orig ic = case ctLocOrigin (ic_loc ic) of 
739                              SigSkol (InfSigCtxt {}) _ -> Nothing
740                              origin                    -> Just origin
741
742
743     show_fixes :: [SDoc] -> SDoc
744     show_fixes []     = empty
745     show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
746                            , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
747
748 mkNoInstErr :: [UserGiven] -> [Ct] -> CtOrigin -> SDoc
749 mkNoInstErr givens cts orig
750   | null givens     -- Top level
751   = addArising orig $
752     ptext (sLit "No instance") <> plural cts
753     <+> ptext (sLit "for") <+> pprTheta theta
754
755   | otherwise
756   = couldNotDeduce givens (theta, orig)
757   where
758    theta = map ctPred cts
759
760 mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
761           -> Ct -> TcM (Either Ct SDoc)
762 -- Report an overlap error if this class constraint results
763 -- from an overlap (returning Left clas), otherwise return (Right pred)
764 mkOverlap ctxt inst_envs orig ct
765   = do { tys_flat <- mapM quickFlattenTy tys
766            -- Note [Flattening in error message generation]
767
768        ; case lookupInstEnv inst_envs clas tys_flat of
769                 ([], _, _) -> return (Left ct)    -- No match
770                 res        -> return (Right (mk_overlap_msg res)) }
771   where
772     (clas, tys) = getClassPredTys (ctPred ct)
773
774     -- Normal overlap error
775     mk_overlap_msg (matches, unifiers, False)
776       = ASSERT( not (null matches) )
777         vcat [  addArising orig (ptext (sLit "Overlapping instances for") 
778                                 <+> pprType (mkClassPred clas tys))
779              ,  sep [ptext (sLit "Matching instances") <> colon,
780                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
781
782              ,  if not (null matching_givens) then 
783                   sep [ptext (sLit "Matching givens (or their superclasses)") <> colon
784                       , nest 2 (vcat matching_givens)]
785                 else empty
786
787              ,  if null matching_givens && isSingleton matches && null unifiers then
788                 -- Intuitively, some given matched the wanted in their
789                 -- flattened or rewritten (from given equalities) form
790                 -- but the matcher can't figure that out because the
791                 -- constraints are non-flat and non-rewritten so we
792                 -- simply report back the whole given
793                 -- context. Accelerate Smart.hs showed this problem.
794                   sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon
795                       , nest 2 (vcat (pp_givens givens))]
796                 else empty 
797
798              ,  if not (isSingleton matches)
799                 then    -- Two or more matches
800                      empty
801                 else    -- One match
802                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
803                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
804                               if null (matching_givens) then
805                                    vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
806                                           ptext (sLit "when compiling the other instance declarations")]
807                               else empty])]
808         where
809             ispecs = [ispec | (ispec, _) <- matches]
810
811             givens = getUserGivens ctxt
812             matching_givens = mapCatMaybes matchable givens
813
814             matchable (evvars,gloc) 
815               = case ev_vars_matching of
816                      [] -> Nothing
817                      _  -> Just $ hang (pprTheta ev_vars_matching)
818                                     2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
819                                            , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
820                 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
821                       ev_var_matches ty = case getClassPredTys_maybe ty of
822                          Just (clas', tys')
823                            | clas' == clas
824                            , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
825                            -> True 
826                            | otherwise
827                            -> any ev_var_matches (immSuperClasses clas' tys')
828                          Nothing -> False
829
830     -- Overlap error because of Safe Haskell (first match should be the most
831     -- specific match)
832     mk_overlap_msg (matches, _unifiers, True)
833       = ASSERT( length matches > 1 )
834         vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
835                         <+> pprType (mkClassPred clas tys))
836              , sep [ptext (sLit "The matching instance is") <> colon,
837                     nest 2 (pprInstance $ head ispecs)]
838              , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
839                     , ptext $ sLit "overlap instances from the same module, however it"
840                     , ptext $ sLit "overlaps the following instances from different modules:"
841                     , nest 2 (vcat [pprInstances $ tail ispecs])
842                     ]
843              ]
844         where
845             ispecs = [ispec | (ispec, _) <- matches]
846
847 ----------------------
848 quickFlattenTy :: TcType -> TcM TcType
849 -- See Note [Flattening in error message generation]
850 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
851 quickFlattenTy ty@(TyVarTy {})  = return ty
852 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
853   -- Don't flatten because of the danger or removing a bound variable
854 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
855                                     ; fy2 <- quickFlattenTy ty2
856                                     ; return (AppTy fy1 fy2) }
857 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
858                                     ; fy2 <- quickFlattenTy ty2
859                                     ; return (FunTy fy1 fy2) }
860 quickFlattenTy (TyConApp tc tys)
861     | not (isSynFamilyTyCon tc)
862     = do { fys <- mapM quickFlattenTy tys 
863          ; return (TyConApp tc fys) }
864     | otherwise
865     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
866                 -- Ignore the arguments of the type family funtys
867          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
868          ; flat_resttys <- mapM quickFlattenTy resttys
869          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
870 \end{code}
871
872 Note [Flattening in error message generation]
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
874 Consider (C (Maybe (F x))), where F is a type function, and we have
875 instances
876                 C (Maybe Int) and C (Maybe a)
877 Since (F x) might turn into Int, this is an overlap situation, and
878 indeed (because of flattening) the main solver will have refrained
879 from solving.  But by the time we get to error message generation, we've
880 un-flattened the constraint.  So we must *re*-flatten it before looking
881 up in the instance environment, lest we only report one matching
882 instance when in fact there are two.
883
884 Re-flattening is pretty easy, because we don't need to keep track of
885 evidence.  We don't re-use the code in TcCanonical because that's in
886 the TcS monad, and we are in TcM here.
887
888 Note [Quick-flatten polytypes]
889 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
890 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
891 flattening any further.  After all, there can be no instance declarations
892 that match such things.  And flattening under a for-all is problematic
893 anyway; consider C (forall a. F a)
894
895 \begin{code}
896 mkAmbigMsg :: ReportErrCtxt -> [Ct] 
897            -> TcM (ReportErrCtxt, Bool, SDoc)
898 mkAmbigMsg ctxt cts
899   | isEmptyVarSet ambig_tv_set
900   = return (ctxt, False, empty)
901   | otherwise
902   = do { dflags <- getDOpts
903        ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set
904        ; return (ctxt', True, mk_msg dflags gbl_docs) }
905   where
906     ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) 
907                          emptyVarSet cts
908     ambig_tvs = varSetElems ambig_tv_set
909     
910     is_or_are | isSingleton ambig_tvs = text "is"
911               | otherwise             = text "are"
912                  
913     mk_msg dflags docs 
914       | any isRuntimeUnkSkol ambig_tvs  -- See Note [Runtime skolems]
915       =  vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
916                    <+> pprQuotedList ambig_tvs
917               , ptext (sLit "Use :print or :force to determine these types")]
918       | otherwise
919       = vcat [ text "The type variable" <> plural ambig_tvs
920                   <+> pprQuotedList ambig_tvs
921                   <+> is_or_are <+> text "ambiguous"
922              , mk_extra_msg dflags docs ]
923   
924     mk_extra_msg dflags docs
925       | null docs
926       = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
927                         -- This happens in things like
928                         --      f x = show (read "foo")
929                         -- where monomorphism doesn't play any role
930       | otherwise 
931       = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:")
932              , nest 2 (vcat docs)
933              , ptext (sLit "Probable fix:") <+> vcat
934                   [ ptext (sLit "give these definition(s) an explicit type signature")
935                   , if xopt Opt_MonomorphismRestriction dflags
936                     then ptext (sLit "or use -XNoMonomorphismRestriction")
937                     else empty ]    -- Only suggest adding "-XNoMonomorphismRestriction"
938                                     -- if it is not already set!
939              ]
940
941 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
942 -- Get the skolem info for a type variable 
943 -- from the implication constraint that binds it
944 getSkolemInfo [] tv
945   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
946     UnkSkol
947 getSkolemInfo (implic:implics) tv
948   | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic)
949   | otherwise                 = getSkolemInfo implics tv
950
951 -----------------------
952 -- findGlobals looks at the value environment and finds values whose
953 -- types mention any of the offending type variables.  It has to be
954 -- careful to zonk the Id's type first, so it has to be in the monad.
955 -- We must be careful to pass it a zonked type variable, too.
956
957 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
958 mkEnvSigMsg what env_sigs
959  | null env_sigs = empty
960  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
961                     , nest 2 (vcat env_sigs) ]
962
963 findGlobals :: ReportErrCtxt
964             -> TcTyVarSet
965             -> TcM (ReportErrCtxt, [SDoc])
966
967 findGlobals ctxt tvs 
968   = do { lcl_ty_env <- case cec_encl ctxt of 
969                         []    -> getLclTypeEnv
970                         (i:_) -> return (ic_env i)
971        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
972   where
973     go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc)
974     go tidy_env acc (thing : things)
975        = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
976             ; case maybe_doc of
977                 Just d  -> go tidy_env1 (d:acc) things
978                 Nothing -> go tidy_env1 acc     things }
979
980     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
981
982 -----------------------
983 find_thing :: TidyEnv -> (TcType -> Bool)
984            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
985 find_thing tidy_env ignore_it (ATcId { tct_id = id })
986   = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
987        ; if ignore_it tidy_ty then
988            return (tidy_env, Nothing)
989          else do 
990        { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
991                        , nest 2 (parens (ptext (sLit "bound at") <+>
992                                    ppr (getSrcLoc id)))]
993        ; return (tidy_env', Just msg) } }
994
995 find_thing tidy_env ignore_it (ATyVar tv ty)
996   = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
997        ; if ignore_it tidy_ty then
998             return (tidy_env, Nothing)
999          else do
1000        { let -- The name tv is scoped, so we don't need to tidy it
1001             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
1002                       , nest 2 bound_at]
1003
1004             eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
1005                      , getOccName tv == getOccName tv' = empty
1006                      | otherwise = equals <+> ppr tidy_ty
1007                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
1008             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
1009  
1010        ; return (tidy_env1, Just msg) } }
1011
1012 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
1013
1014 warnDefaulting :: [Ct] -> Type -> TcM ()
1015 warnDefaulting wanteds default_ty
1016   = do { warn_default <- woptM Opt_WarnTypeDefaults
1017        ; env0 <- tcInitTidyEnv
1018        ; let wanted_bag = listToBag wanteds
1019              tidy_env = tidyFreeTyVars env0 $
1020                         tyVarsOfCts wanted_bag
1021              tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag
1022              (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1023              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
1024                                 <+> quotes (ppr default_ty))
1025                             2 ppr_wanteds
1026        ; setCtLoc loc $ warnTc warn_default warn_msg }
1027 \end{code}
1028
1029 Note [Runtime skolems]
1030 ~~~~~~~~~~~~~~~~~~~~~~
1031 We want to give a reasonably helpful error message for ambiguity
1032 arising from *runtime* skolems in the debugger.  These
1033 are created by in RtClosureInspect.zonkRTTIType.  
1034
1035 %************************************************************************
1036 %*                                                                      *
1037                  Error from the canonicaliser
1038          These ones are called *during* constraint simplification
1039 %*                                                                      *
1040 %************************************************************************
1041
1042 \begin{code}
1043 solverDepthErrorTcS :: Int -> [Ct] -> TcM a
1044 solverDepthErrorTcS depth stack
1045   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
1046   = failWith msg
1047   | otherwise
1048   = setCtFlavorLoc (cc_flavor top_item) $
1049     do { ev_vars <- mapM (zonkEvVar . cc_id) stack
1050        ; env0 <- tcInitTidyEnv
1051        ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
1052              tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
1053        ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
1054   where
1055     top_item = head stack
1056     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
1057                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
1058
1059 flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a
1060 flattenForAllErrorTcS fl ty
1061   = setCtFlavorLoc fl $ 
1062     do { env0 <- tcInitTidyEnv
1063        ; let (env1, ty') = tidyOpenType env0 ty 
1064              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
1065                        , ppr ty' ]
1066        ; failWithTcM (env1, msg) }
1067 \end{code}
1068
1069 %************************************************************************
1070 %*                                                                      *
1071                  Setting the context
1072 %*                                                                      *
1073 %************************************************************************
1074
1075 \begin{code}
1076 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
1077 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
1078 setCtFlavorLoc (Derived loc)   thing = setCtLoc loc thing
1079 setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
1080 \end{code}
1081
1082 %************************************************************************
1083 %*                                                                      *
1084                  Tidying
1085 %*                                                                      *
1086 %************************************************************************
1087
1088 \begin{code}
1089 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
1090 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
1091                            ; return (tidyOpenType env ty') }
1092
1093 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin)
1094 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
1095   = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
1096        ; (env2, exp') <- zonkTidyTcType env1            exp
1097        ; return ( ctxt { cec_tidy = env2 }
1098                 , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
1099 zonkTidyOrigin ctxt orig = return (ctxt, orig)
1100 \end{code}