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

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

       flattenForAllErrorTcS,
       solverDepthErrorTcS
16
17
18
19
  ) where

#include "HsVersions.h"

20
import TcCanonical( occurCheckExpand )
21
22
23
import TcRnMonad
import TcMType
import TcType
24
import TypeRep
batterseapower's avatar
batterseapower committed
25
import Type
26
import Kind ( isKind )
27
import Unify            ( tcMatchTys )
28
29
30
import Inst
import InstEnv
import TyCon
31
import TcEvidence
32
33
import Name
import NameEnv
34
import Id               ( idType )
35
36
37
38
import Var
import VarSet
import VarEnv
import Bag
39
40
import Maybes
import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
41
import SrcLoc           ( noSrcSpan )
42
43
44
45
import Util
import FastString
import Outputable
import DynFlags
46
import Data.List        ( partition, mapAccumL )
47
48
49
50
51
52
53
54
55
56
57
58
59
\end{code}

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

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

\begin{code}
60
61
62
63
64
65
-- We keep an environment mapping coercion ids to the error messages they
-- trigger; this is handy for -fwarn--type-errors
type ErrEnv = VarEnv [ErrMsg]

reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind)
reportUnsolved runtimeCoercionErrors wanted
66
  | isEmptyWC wanted
67
  = return emptyBag
68
  | otherwise
69
  = do {   -- Zonk to un-flatten any flatten-skols
70
         wanted  <- zonkWC wanted
71

72
       ; env0 <- tcInitTidyEnv
73
74
75
76
77
78
       ; defer <- if runtimeCoercionErrors 
                  then do { ev <- newTcEvBinds
                          ; return (Just ev) }
                  else return Nothing

       ; errs_so_far <- ifErrsM (return True) (return False)
79
80
81
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
             free_tvs = tyVarsOfWC wanted
             err_ctxt = CEC { cec_encl  = []
82
83
84
85
                            , cec_insol = errs_so_far || insolubleWC wanted
                                          -- Don't report ambiguity errors if
                                          -- there are any other solid errors 
                                          -- to report
86
                            , cec_extra = empty
87
88
89
                            , cec_tidy  = tidy_env
                            , cec_defer = defer }

90
91
       ; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs)
                                         , ppr wanted ])
92

93
       ; reportWanteds err_ctxt wanted
94

95
96
97
       ; case defer of
           Nothing -> return emptyBag
           Just ev -> getTcEvBinds ev }
98

99
100
101
--------------------------------------------
--      Internal functions
--------------------------------------------
102
103
104
105

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
106
                                       -- ic_skols and givens are tidied, rest are not
107
108
          , cec_tidy  :: TidyEnv
          , cec_extra :: SDoc       -- Add this to each error message
109
110
111
112
113
114
          , cec_insol :: Bool       -- True <=> do not report errors involving 
                                    --          ambiguous errors
          , cec_defer :: Maybe EvBindsVar 
                         -- Nothinng <=> errors are, well, errors
                         -- Just ev  <=> make errors into warnings, and emit evidence
                         --              bindings into 'ev' for unsolved constraints
115
116
      }

117
118
119
120
121
122
123
124
125
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                 , ic_wanted = wanted, ic_binds = evb
                                 , ic_insol = insoluble, ic_loc = loc })
  | BracketSkol <- ctLocOrigin loc
  , not insoluble -- For Template Haskell brackets report only
  = return ()     -- definite errors. The whole thing will be re-checked
                  -- later when we plug it in, and meanwhile there may
                  -- certainly be un-satisfied constraints
126
127

  | otherwise
128
  = reportWanteds ctxt' wanted
129
  where
130
131
132
133
134
135
136
137
138
139
140
141
142
    (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
    implic' = implic { ic_skols = tvs'
                     , ic_given = map (tidyEvVar env1) given
                     , ic_loc   = tidyGivenLoc env1 loc }
    ctxt' = ctxt { cec_tidy  = env1
                 , cec_encl  = implic' : cec_encl ctxt
                 , cec_defer = case cec_defer ctxt of
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
  = reportTidyWanteds ctxt tidy_insols tidy_flats implics
143
  where
144
145
146
147
148
149
150
151
152
153
154
155
156
    env = cec_tidy ctxt
    tidy_insols = mapBag (tidyCt env) insols
    tidy_flats  = mapBag (tidyCt env) flats

reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM ()
reportTidyWanteds ctxt insols flats implics
  | Just ev_binds_var <- cec_defer ctxt
  = do { -- Defer errors to runtime
         -- See Note [Deferring coercion errors to runtime] in TcSimplify
         mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) 
                  (flats `unionBags` insols)
       ; mapBagM_ (reportImplic ctxt) implics }

157
  | otherwise
158
159
160
161
162
163
164
  = do { reportInsolsAndFlats ctxt insols flats
       ; mapBagM_ (reportImplic ctxt) implics }
             

deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
               -> Ct -> TcM ()
deferToRuntime ev_binds_var ctxt mk_err_msg ct 
165
  | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
166
167
  = do { err <- setCtLoc loc $
                mk_err_msg ctxt ct
Ian Lynagh's avatar
Ian Lynagh committed
168
       ; dflags <- getDynFlags
169
       ; let err_msg = pprLocErrMsg err
Ian Lynagh's avatar
Ian Lynagh committed
170
             err_fs  = mkFastString $ showSDoc dflags $
171
172
173
                       err_msg $$ text "(deferred type error)"

         -- Create the binding
174
       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs)
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

         -- And emit a warning
       ; reportWarning (makeIntoWarning err) }

  | otherwise   -- Do not set any evidence for Given/Derived
  = return ()   

reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM ()
reportInsolsAndFlats ctxt insols flats
  = tryReporters 
      [ -- First deal with things that are utterly wrong
        -- Like Int ~ Bool (incl nullary TyCons)
        -- or  Int ~ t a   (AppTy on one side)
        ("Utterly wrong",  utterly_wrong,   groupErrs (mkEqErr ctxt))

        -- Report equalities of form (a~ty).  They are usually
        -- skolem-equalities, and they cause confusing knock-on 
        -- effects in other errors; see test T4093b.
      , ("Skolem equalities",    skolem_eq,       mkReporter (mkEqErr1 ctxt))

      , ("Unambiguous",          unambiguous,     reportFlatErrs ctxt) ]
      (reportAmbigErrs ctxt)
      (bagToList (insols `unionBags` flats))
  where
    utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool

    utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 
    utterly_wrong _ _ = False

    skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
    skolem_eq _ _ = False

    unambiguous ct pred 
      | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct)))
      = True
      | otherwise 
      = case pred of
          EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
          _              -> False

---------------
isRigid, isRigidOrSkol :: Type -> Bool
isRigid ty 
  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
  | Just {} <- tcSplitAppTy_maybe ty        = True
  | isForAllTy ty                           = True
  | otherwise                               = False

isRigidOrSkol ty 
  | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv
  | otherwise                    = isRigid ty

isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
                      Just (tc,_) | isSynFamilyTyCon tc -> Just tc
                      _ -> Nothing

-----------------
type Reporter = [Ct] -> TcM ()

mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM ()
-- Reports errors one at a time
237
mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $
238
239
240
241
                                              mk_err ct; 
                                     ; reportError err })

tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter
242
-- Use the first reporter in the list whose predicate says True
243
244
245
246
tryReporters reporters deflt cts
  = do { traceTc "tryReporters {" (ppr cts) 
       ; go reporters cts
       ; traceTc "tryReporters }" empty }
247
  where
248
249
250
251
252
253
254
255
256
257
258
259
260
261
    go [] cts = deflt cts 
    go ((str, pred, reporter) : rs) cts
      | null yeses  = traceTc "tryReporters: no" (text str) >> 
                      go rs cts
      | otherwise   = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> 
                      reporter yeses
      where
       yeses = filter keep_me cts
       keep_me ct = pred ct (classifyPredType (ctPred ct))

-----------------
mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Context is already set
mkFlatErr ctxt ct   -- The constraint is always wanted
262
263
  | isIPPred (ctPred ct) = mkIPErr    ctxt [ct]
  | otherwise
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
  = case classifyPredType (ctPred ct) of
      ClassPred {}  -> mkDictErr  ctxt [ct]
      IrredPred {}  -> mkIrredErr ctxt [ct]
      EqPred {}     -> mkEqErr1 ctxt ct
      TuplePred {}  -> panic "mkFlat"
      
reportAmbigErrs :: ReportErrCtxt -> Reporter
reportAmbigErrs ctxt cts
  | cec_insol ctxt = return ()
  | otherwise      = reportFlatErrs ctxt cts
          -- Only report ambiguity if no other errors (at all) happened
          -- See Note [Avoiding spurious errors] in TcSimplify

reportFlatErrs :: ReportErrCtxt -> Reporter
-- Called once for non-ambigs, once for ambigs
-- Report equality errors, and others only if we've done all 
-- the equalities.  The equality errors are more basic, and
-- can lead to knock on type-class errors
reportFlatErrs ctxt cts
  = tryReporters
      [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ]
      (\cts -> do { let (dicts, ips, irreds) = go cts [] [] []
                  ; groupErrs (mkIPErr    ctxt) ips   
                  ; groupErrs (mkIrredErr ctxt) irreds
                  ; groupErrs (mkDictErr  ctxt) dicts })
      cts
290
  where
291
292
293
294
295
296
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

    go [] dicts ips irreds
      = (dicts, ips, irreds)
    go (ct:cts) dicts ips irreds
297
298
      | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds
      | otherwise
299
300
301
302
      = case classifyPredType (ctPred ct) of
          ClassPred {}  -> go cts (ct:dicts) ips irreds
          IrredPred {}  -> go cts dicts ips (ct:irreds)
          _             -> panic "mkFlat"
batterseapower's avatar
batterseapower committed
303
304
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
305
306
    -- And EqPreds are dealt with by the is_equality test

307
308
309
310
311

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

312
313
groupErrs :: ([Ct] -> TcM ErrMsg)  -- Deal with one group
	  -> [Ct]	           -- Unsolved wanteds
314
          -> TcM ()
315
-- Group together insts from same location
316
317
318
319
-- We want to report them together in error messages

groupErrs _ [] 
  = return ()
320
321
322
323
groupErrs mk_err (ct1 : rest)
  = do  { err <- setCtFlavorLoc flavor $ mk_err cts
        ; reportError err
        ; groupErrs mk_err others }
324
  where
325
   flavor            = cc_ev ct1
326
327
   cts               = ct1 : friends
   (friends, others) = partition is_friend rest
328
   is_friend friend  = cc_ev friend `same_group` flavor
329

330
331
332
333
   same_group :: CtEvidence -> CtEvidence -> Bool
   same_group (Given   {ctev_gloc = l1}) (Given   {ctev_gloc = l2}) = same_loc l1 l2
   same_group (Wanted  {ctev_wloc = l1}) (Wanted  {ctev_wloc = l2}) = same_loc l1 l2
   same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2
334
   same_group _ _ = False
335

336
337
   same_loc :: CtLoc o -> CtLoc o -> Bool
   same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2
338
339

-- Add the "arising from..." part to a message about bunch of dicts
340
addArising :: CtOrigin -> SDoc -> SDoc
341
addArising orig msg = hang msg 2 (pprArising orig)
342

343
pprWithArising :: [Ct] -> (WantedLoc, SDoc)
344
345
-- Print something like
--    (Eq a) arising from a use of x at y
346
347
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
348
-- Works for Wanted/Derived only
349
350
pprWithArising [] 
  = panic "pprWithArising"
351
352
pprWithArising (ct:cts)
  | null cts
353
  = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) 
dimitris's avatar
dimitris committed
354
                     (pprTheta [ctPred ct]))
355
356
  | otherwise
  = (loc, vcat (map ppr_one (ct:cts)))
357
  where
358
359
360
    loc = ctWantedLoc ct
    ppr_one ct = hang (parens (pprType (ctPred ct))) 
                    2 (pprArisingAt (ctWantedLoc ct))
361

362
363
mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg
mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
364

365
366
367
type UserGiven = ([EvVar], GivenLoc)

getUserGivens :: ReportErrCtxt -> [UserGiven]
368
-- One item for each enclosing implication
369
getUserGivens (CEC {cec_encl = ctxt})
370
  = reverse $
371
372
    [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
                    , not (null givens) ]
373
374
\end{code}

batterseapower's avatar
batterseapower committed
375
376
377
378
379
380
381
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
382
383
384
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
  = mkErrorReport ctxt msg
batterseapower's avatar
batterseapower committed
385
  where
386
387
388
389
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
390
391
\end{code}

392
393
394
395
396
397
398
399

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

\begin{code}
400
401
402
403
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
  = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts
       ; mkErrorReport ctxt' (msg $$ ambig_err) }
404
  where
405
406
407
408
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
409
410
    msg | null givens
        = addArising orig $
411
412
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
413
        | otherwise
414
        = couldNotDeduce givens (preds, orig)
415
416
417
418
419
420
421
422
423
424
\end{code}


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

\begin{code}
425
426
427
428
429
430
431
432
433
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
-- Don't have multiple equality errors from the same location
-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
mkEqErr _ [] = panic "mkEqErr"

mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Wanted constraints only!
mkEqErr1 ctxt ct
434
  = if isGiven flav then 
dimitris's avatar
dimitris committed
435
436
437
438
439
440
      let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav }
      in mkEqErr_help ctx2 ct False ty1 ty2
    else
      do { let orig = ctLocOrigin (getWantedLoc flav)
         ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig
         ; mk_err ctxt1 orig' }
441
  where
dimitris's avatar
dimitris committed
442

443
    flav = cc_ev ct
dimitris's avatar
dimitris committed
444

445
446
447
    inaccessible_msg (Given { ctev_gloc = loc }) 
       = hang (ptext (sLit "Inaccessible code in"))
            2 (ppr (ctLocOrigin loc))
dimitris's avatar
dimitris committed
448
449
    -- If a Solved then we should not report inaccessible code
    inaccessible_msg _ = empty
450

dimitris's avatar
dimitris committed
451
    (ty1, ty2) = getEqPredTys (ctPred ct)
452
453
454
455
456
457
458
459
460
461
462
463
464
465

       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
    mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) 
      | act `pickyEqType` ty1
      , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True  ty2 ty1
      | exp `pickyEqType` ty1
      , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True  ty1 ty2
      | otherwise             = mkEqErr_help ctxt2 ct False ty1 ty2
      where
        ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 }
        msg   = mkExpectedActualMsg exp act
    mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2

466
467
468
469
470
471
472
473
mkEqErr_help, reportEqErr 
   :: ReportErrCtxt
   -> Ct
   -> Bool     -- True  <=> Types are correct way round;
               --           report "expected ty1, actual ty2"
               -- False <=> Just report a mismatch without orientation
               --           The ReportErrCtxt has expected/actual 
   -> TcType -> TcType -> TcM ErrMsg
474
475
476
mkEqErr_help ctxt ct oriented ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1
477
478
479
  | otherwise                        = reportEqErr ctxt ct oriented ty1 ty2

reportEqErr ctxt ct oriented ty1 ty2
480
481
482
483
  = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2
       ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) }

mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
484
-- tv1 and ty2 are already tidied
485
mkTyVarEqErr ctxt ct oriented tv1 ty2
486
487
488
  |  isSkolemTyVar tv1 	  -- ty2 won't be a meta-tyvar, or else the thing would
     		   	  -- be oriented the other way round; see TcCanonical.reOrient
  || isSigTyVar tv1 && not (isTyVarTy ty2)
489
490
  = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2)
                  (misMatchOrCND ctxt ct oriented ty1 ty2)
491
492
493

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

497
  -- Occurs check
498
  | isNothing (occurCheckExpand tv1 ty2)
499
500
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '=', ppr ty2])
501
    in mkErrorReport ctxt occCheckMsg
502

503
504
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
505
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
506
507
508
509
        implic_loc = ic_loc implic
  , not (null esc_skols)
  = setCtLoc implic_loc $	-- Override the error message location from the
    	     			-- place the equality arose to the implication site
510
511
    do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1)
       ; let msg = misMatchMsg oriented ty1 ty2
512
513
514
515
516
517
             esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
                             <+> pprQuotedList esc_skols
                           , ptext (sLit "would escape") <+>
                             if isSingleton esc_skols then ptext (sLit "its scope")
                                                      else ptext (sLit "their scope") ]
             extra1 = vcat [ nest 2 $ esc_doc
518
                           , sep [ (if isSingleton esc_skols 
519
520
                                    then ptext (sLit "This (rigid, skolem) type variable is")
                                    else ptext (sLit "These (rigid, skolem) type variables are"))
521
                                   <+> ptext (sLit "bound by")
522
                                 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
523
       ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
524
525
526
527
528
529

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
  , let implic_loc = ic_loc implic
        given      = ic_given implic
  = setCtLoc (ic_loc implic) $
530
    do { let msg = misMatchMsg oriented ty1 ty2
531
532
533
             extra = quotes (ppr tv1)
                 <+> sep [ ptext (sLit "is untouchable")
                         , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
534
                         , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
535
       ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
536

537
  | otherwise
538
539
540
541
  = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2
        -- This *can* happen (Trac #6123, and test T2627b)
        -- Consider an ambiguous top-level constraint (a ~ F a)
        -- Not an occurs check, becuase F is a type function.
542
  where         
543
544
545
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
546

547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt
-- Report (a) ambiguity if either side is a type function application
--            e.g. F a0 ~ Int    
--        (b) warning about injectivity if both sides are the same
--            type function application   F a ~ F b
--            See Note [Non-injective type functions]
mkEqInfoMsg ctxt ct ty1 ty2
  = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2
                                  then mkAmbigMsg ctxt [ct]
                                  else return (ctxt, False, empty)
       ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) }
  where
    mb_fun1 = isTyFun_maybe ty1
    mb_fun2 = isTyFun_maybe ty2
    tyfun_msg | Just tc1 <- mb_fun1
              , Just tc2 <- mb_fun2
              , tc1 == tc2 
              = ptext (sLit "NB:") <+> quotes (ppr tc1) 
                <+> ptext (sLit "is a type function, and may not be injective")
              | otherwise = empty

misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc
-- If oriented then ty1 is expected, ty2 is actual
misMatchOrCND ctxt ct oriented ty1 ty2
  | null givens || 
    (isRigid ty1 && isRigid ty2) || 
573
    isGiven (cc_ev ct)
574
575
576
577
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
578
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
579
580
581
582
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

583
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
584
couldNotDeduce givens (wanteds, orig)
585
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
586
587
588
589
590
         , vcat (pp_givens givens)]

pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
pp_givens givens 
   = case givens of
591
592
593
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
dimitris's avatar
dimitris committed
594
595
596
597
    where ppr_given herald (gs,loc)
           = hang (herald <+> pprEvVarTheta gs)
                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
                       , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
598

599
addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
600
601
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
602
addExtraTyVarInfo ctxt ty1 ty2
603
  = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
604
  where
605
606
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
607

608
tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
609
-- Shows a bit of extra info about skolem constants
610
tyVarExtraInfoMsg implics ty
611
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
612
613
614
615
616
617
618
619
620
621
622
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
    SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
    FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
    RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
    MetaTv {}     -> empty

 | otherwise             -- Normal case
 = empty
 where
623
624
625
626
627
628
629
   ppr_skol given_loc tv_loc
     = case skol_info of
         UnkSkol -> ptext (sLit "is an unknown type variable")
         _ -> sep [ ptext (sLit "is a rigid type variable bound by"),
                    sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
     where
       skol_info = ctLocOrigin given_loc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
630
 
631
632
633
634
635
636
637
638
639
kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
kindErrorMsg ty1 ty2
  = vcat [ ptext (sLit "Kind incompatibility when matching types:")
         , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
                        , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
  where
    k1 = typeKind ty1
    k2 = typeKind ty2

640
--------------------
641
642
643
644
645
646
647
648
649
650
651
652
misMatchMsg :: Bool -> TcType -> TcType -> SDoc	   -- Types are already tidy
-- If oriented then ty1 is expected, ty2 is actual
misMatchMsg oriented ty1 ty2 
  | oriented
  = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1)
        , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ]
  | otherwise
  = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
        , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ]
  where 
    what | isKind ty1 = ptext (sLit "kind")
         | otherwise  = ptext (sLit "type")
653
654

mkExpectedActualMsg :: Type -> Type -> SDoc
655
mkExpectedActualMsg exp_ty act_ty
656
657
  = vcat [ text "Expected type:" <+> ppr exp_ty
         , text "  Actual type:" <+> ppr act_ty ]
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
\end{code}

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

Warn of loopy local equalities that were dropped.


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

\begin{code}
678
679
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
680
681
682
683
684
685
686
687
688
  = ASSERT( not (null cts) )
    do { inst_envs <- tcGetInstEnvs
       ; lookups   <- mapM (lookup_cls_inst inst_envs) cts
       ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups

       -- Report definite no-instance errors, 
       -- or (iff there are none) overlap errors
       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
       ; mkErrorReport ctxt err }
689
  where
690
691
692
693
694
695
696
697
698
699
    no_givens = null (getUserGivens ctxt)
    is_no_inst (ct, (matches, unifiers, _))
      =  no_givens 
      && null matches 
      && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
           
    lookup_cls_inst inst_envs ct
      = do { tys_flat <- mapM quickFlattenTy tys
                -- Note [Flattening in error message generation]
           ; return (ct, lookupInstEnv inst_envs clas tys_flat) }
700
      where
701
        (clas, tys) = getClassPredTys (ctPred ct)
702

703
704
705
706
707
708
709
710
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
             -> TcM (ReportErrCtxt, SDoc)
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) 
  | null matches  -- No matches but perhaps several unifiers
  = do { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct]
       ; return (ctxt', cannot_resolve_msg is_ambig ambig_msg) }
711

712
713
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
714

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
  | otherwise
  = return (ctxt, safe_haskell_msg)
  where
    orig        = ctLocOrigin (ctWantedLoc ct)
    pred        = ctPred ct
    (clas, tys) = getClassPredTys pred
    ispecs      = [ispec | (ispec, _) <- matches]
    givens      = getUserGivens ctxt
    all_tyvars  = all isTyVarTy tys

    cannot_resolve_msg has_ambig_tvs ambig_msg
      = vcat [ addArising orig (no_inst_herald <+> pprParendType pred)
             , vcat (pp_givens givens)
             , if has_ambig_tvs && (not (null unifiers) || not (null givens))
               then ambig_msg $$ potential_msg
               else empty
             , show_fixes (inst_decl_fixes
                           ++ add_to_ctxt_fixes has_ambig_tvs
                           ++ drv_fixes) ]

    potential_msg
      | null unifiers = empty
      | otherwise 
      = hang (if isSingleton unifiers 
              then ptext (sLit "Note: there is a potential instance available:")
              else ptext (sLit "Note: there are several potential instances:"))
    	   2 (ppr_insts unifiers)

    add_to_ctxt_fixes has_ambig_tvs
      | not has_ambig_tvs && all_tyvars
      , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt)
      = [sep [ ptext (sLit "add") <+> pprParendType pred
               <+> ptext (sLit "to the context of")
	     , nest 2 $ ppr_skol orig $$ 
                        vcat [ ptext (sLit "or") <+> ppr_skol orig 
                             | orig <- origs ] ] ]
      | otherwise = []

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

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

761
762
763
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
764

765
766
767
768
    inst_decl_fixes
      | all_tyvars = []
      | otherwise  = [ sep [ ptext (sLit "add an instance declaration for")
                           , pprParendType pred] ]
769

770
771
772
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
773

774
775
    drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
                 2 (ptext (sLit "so you can specify the instance context yourself"))
776

777
    -- Normal overlap error
778
    overlap_msg
779
780
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
781
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
782

783
             ,  if not (null matching_givens) then 
784
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
785
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
786
787
                else empty

788
789
790
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

791
792
793
794
795
796
797
             ,  if null matching_givens && isSingleton matches && null unifiers then
                -- Intuitively, some given matched the wanted in their
                -- flattened or rewritten (from given equalities) form
                -- but the matcher can't figure that out because the
                -- constraints are non-flat and non-rewritten so we
                -- simply report back the whole given
                -- context. Accelerate Smart.hs showed this problem.
798
                  sep [ ptext (sLit "There exists a (perhaps superclass) match:") 
799
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
800
801
                else empty 

802
803
804
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
805
    		else 	-- One match
806
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
807
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
808
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
809
810
811
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
812
813
814
815
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
816
817
            matching_givens = mapCatMaybes matchable givens

818
819
820
821
822
823
824
            matchable (evvars,gloc) 
              = case ev_vars_matching of
                     [] -> Nothing
                     _  -> Just $ hang (pprTheta ev_vars_matching)
                                    2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
                                           , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
batterseapower's avatar
batterseapower committed
825
826
827
828
829
830
831
832
                      ev_var_matches ty = case getClassPredTys_maybe ty of
                         Just (clas', tys')
                           | clas' == clas
                           , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
                           -> True 
                           | otherwise
                           -> any ev_var_matches (immSuperClasses clas' tys')
                         Nothing -> False
833

834
835
836
    -- Overlap error because of Safe Haskell (first 
    -- match should be the most specific match)
    safe_haskell_msg
837
838
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
839
                        <+> pprType (mkClassPred clas tys))
840
             , sep [ptext (sLit "The matching instance is:"),
841
842
843
844
845
846
847
                    nest 2 (pprInstance $ head ispecs)]
             , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
                    , ptext $ sLit "overlap instances from the same module, however it"
                    , ptext $ sLit "overlaps the following instances from different modules:"
                    , nest 2 (vcat [pprInstances $ tail ispecs])
                    ]
             ]
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862

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

ppr_insts :: [ClsInst] -> SDoc
ppr_insts insts
  = pprInstances (take 3 insts) $$ dot_dot_message
  where
    n_extra = length insts - 3
    dot_dot_message 
       | n_extra <= 0 = empty
       | otherwise    = ptext (sLit "...plus") 
                        <+> speakNOf n_extra (ptext (sLit "other"))
dimitris's avatar
dimitris committed
863

864
865
866
867
868
869
----------------------
quickFlattenTy :: TcType -> TcM TcType
-- See Note [Flattening in error message generation]
quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
quickFlattenTy ty@(TyVarTy {})  = return ty
quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
870
quickFlattenTy ty@(LitTy {})    = return ty
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
  -- Don't flatten because of the danger or removing a bound variable
quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (AppTy fy1 fy2) }
quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (FunTy fy1 fy2) }
quickFlattenTy (TyConApp tc tys)
    | not (isSynFamilyTyCon tc)
    = do { fys <- mapM quickFlattenTy tys 
         ; return (TyConApp tc fys) }
    | otherwise
    = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
                -- Ignore the arguments of the type family funtys
         ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
         ; flat_resttys <- mapM quickFlattenTy resttys
         ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
\end{code}

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

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

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

\begin{code}
914
915
916
917
918
919
mkAmbigMsg :: ReportErrCtxt -> [Ct] 
           -> TcM (ReportErrCtxt, Bool, SDoc)
mkAmbigMsg ctxt cts
  | isEmptyVarSet ambig_tv_set
  = return (ctxt, False, empty)
  | otherwise
920
  = do { dflags <- getDynFlags
921
922
       ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set
       ; return (ctxt', True, mk_msg dflags gbl_docs) }
923
  where
924
925
926
927
928
929
930
    ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) 
                         emptyVarSet cts
    ambig_tvs = varSetElems ambig_tv_set
    
    is_or_are | isSingleton ambig_tvs = text "is"
              | otherwise             = text "are"
                 
931
    mk_msg dflags docs 
932
933
934
935
936
937
938
939
940
941
942
943
944
      | any isRuntimeUnkSkol ambig_tvs  -- See Note [Runtime skolems]
      =  vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
                   <+> pprQuotedList ambig_tvs
              , ptext (sLit "Use :print or :force to determine these types")]
      | otherwise
      = vcat [ text "The type variable" <> plural ambig_tvs
	          <+> pprQuotedList ambig_tvs
                  <+> is_or_are <+> text "ambiguous"
             , mk_extra_msg dflags docs ]
  
    mk_extra_msg dflags docs
      | null docs
      = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
945
946
947
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
948
949
950
951
952
953
954
955
956
957
      | otherwise 
      = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:")
	     , nest 2 (vcat docs)
             , ptext (sLit "Probable fix:") <+> vcat
     	          [ ptext (sLit "give these definition(s) an explicit type signature")
     	          , if xopt Opt_MonomorphismRestriction dflags
                    then ptext (sLit "or use -XNoMonomorphismRestriction")
                    else empty ]    -- Only suggest adding "-XNoMonomorphismRestriction"
     			            -- if it is not already set!
             ]
958

959
getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
960
961
-- Get the skolem info for a type variable 
-- from the implication constraint that binds it
962
963
getSkolemInfo [] tv
  = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
964
965
    CtLoc UnkSkol noSrcSpan []

966
getSkolemInfo (implic:implics) tv
967
  | tv `elem` ic_skols implic = ic_loc implic
968
  | otherwise                 = getSkolemInfo implics tv
969

970
971
972
973
974
975
976
977
978
979
980
981
982
983
-----------------------
-- findGlobals looks at the value environment and finds values whose
-- types mention any of the offending type variables.  It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.

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

findGlobals :: ReportErrCtxt
            -> TcTyVarSet
984
            -> TcM (ReportErrCtxt, [SDoc])
985
986
987
988
989
990
991

findGlobals ctxt tvs 
  = do { lcl_ty_env <- case cec_encl ctxt of 
                        []    -> getLclTypeEnv
                        (i:_) -> return (ic_env i)
       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
  where
992
993
994
995
996
997
    go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc)
    go tidy_env acc (thing : things)
       = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
	    ; case maybe_doc of
	        Just d  -> go tidy_env1 (d:acc) things
	        Nothing -> go tidy_env1 acc     things }
998
999
1000
1001
1002
1003
1004

    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty

-----------------------
find_thing :: TidyEnv -> (TcType -> Bool)
           -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
find_thing tidy_env ignore_it (ATcId { tct_id = id })
1005
1006
  = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
       ; if ignore_it tidy_ty then
1007
1008
	   return (tidy_env, Nothing)
         else do 
1009
       { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
1010
1011
1012
1013
		       , nest 2 (parens (ptext (sLit "bound at") <+>
			 	   ppr (getSrcLoc id)))]
       ; return (tidy_env', Just msg) } }

1014
1015
1016
find_thing tidy_env ignore_it (ATyVar name tv)
  = do { ty <- zonkTcTyVar tv
       ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty
1017
       ; if ignore_it tidy_ty then
1018
1019
1020
	    return (tidy_env, Nothing)
         else do
       { let -- The name tv is scoped, so we don't need to tidy it
1021
            msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff
1022
1023
                      , nest 2 bound_at]

1024
            eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
1025
		     , getOccName name == getOccName tv' = empty
1026
1027
		     | otherwise = equals <+> ppr tidy_ty
		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
1028
	    bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name)
1029
1030
1031
1032
1033
 
       ; return (tidy_env1, Just msg) } }

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

1034
warnDefaulting :: [Ct] -> Type -> TcM ()
1035
warnDefaulting wanteds default_ty
1036
  = do { warn_default <- woptM Opt_WarnTypeDefaults
1037
1038
1039
       ; env0 <- tcInitTidyEnv
       ; let wanted_bag = listToBag wanteds
             tidy_env = tidyFreeTyVars env0 $
1040
1041
                        tyVarsOfCts wanted_bag
             tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag
1042
             (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1043
1044
1045
             warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                <+> quotes (ppr default_ty))
                            2 ppr_wanteds
1046
1047
1048
       ; setCtLoc loc $ warnTc warn_default warn_msg }
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1049
1050
1051
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
1052
1053
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.  
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1054

1055
1056
1057
%************************************************************************
%*									*
                 Error from the canonicaliser
1058
	 These ones are called *during* constraint simplification
1059
1060
1061
1062
%*									*
%************************************************************************

\begin{code}
1063
solverDepthErrorTcS :: Int -> [Ct] -> TcM a
1064
1065
solverDepthErrorTcS depth stack
  | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
1066
  = failWith msg
1067
  | otherwise
1068
  = setCtFlavorLoc (cc_ev top_item) $
dimitris's avatar
dimitris committed
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
    do { zstack <- mapM zonkCt stack
       ; env0 <- tcInitTidyEnv
       ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack
             tidy_env = tidyFreeTyVars env0 zstack_tvs
             tidy_cts = map (tidyCt tidy_env) zstack
       ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) }
  where
    top_item = head stack
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]

{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ...
1081
  = setCtFlavorLoc (cc_ev top_item) $
1082
1083
1084
1085
1086
    do { ev_vars <- mapM (zonkEvVar . cc_id) stack
       ; env0 <- tcInitTidyEnv
       ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
             tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
       ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
1087
1088
1089
1090
  where
    top_item = head stack
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
dimitris's avatar
dimitris committed
1091
1092
-}

1093

1094
flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a
1095
flattenForAllErrorTcS fl ty
1096
  = setCtFlavorLoc fl $ 
1097
1098
1099
1100
1101
1102
    do { env0 <- tcInitTidyEnv
       ; let (env1, ty') = tidyOpenType env0 ty 
             msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
                       , ppr ty' ]
       ; failWithTcM (env1, msg) }
\end{code}
1103
1104
1105
1106
1107
1108
1109
1110

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

\begin{code}
1111
1112
1113
1114
setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a
setCtFlavorLoc (Wanted  { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Given   { ctev_gloc = loc }) thing = setCtLoc loc thing
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
\end{code}

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

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

1128
zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin)
1129
1130
zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
  = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
1131
1132
1133
1134
       ; (env2, exp') <- zonkTidyTcType env1            exp
       ; return ( ctxt { cec_tidy = env2 }
                , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
zonkTidyOrigin ctxt orig = return (ctxt, orig)
1135
\end{code}