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