TcErrors.lhs 48.2 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, reportAllUnsolved,
12
       warnDefaulting,
13
14

       solverDepthErrorTcS
15
16
17
18
  ) where

#include "HsVersions.h"

19
import TcCanonical( occurCheckExpand )
20
import TcRnTypes
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
import Name
33
import Id 
34
35
36
37
import Var
import VarSet
import VarEnv
import Bag
38
39
import Maybes
import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
40
import BasicTypes 
41
42
43
import Util
import FastString
import Outputable
44
import SrcLoc
45
import DynFlags
46
import Data.List        ( partition, mapAccumL )
47
48
49
50
51
52
53
54
55
56
57
58
\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?

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Note [Deferring coercion errors to runtime]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
While developing, sometimes it is desirable to allow compilation to succeed even
if there are type errors in the code. Consider the following case:

  module Main where

  a :: Int
  a = 'a'

  main = print "b"

Even though `a` is ill-typed, it is not used in the end, so if all that we're
interested in is `main` it is handy to be able to ignore the problems in `a`.

Since we treat type equalities as evidence, this is relatively simple. Whenever
we run into a type mismatch in TcUnify, we normally just emit an error. But it
is always safe to defer the mismatch to the main constraint solver. If we do
that, `a` will get transformed into
78

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
  co :: Int ~ Char
  co = ...

  a :: Int
  a = 'a' `cast` co

The constraint solver would realize that `co` is an insoluble constraint, and
emit an error with `reportUnsolved`. But we can also replace the right-hand side
of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
to compile, and it will run fine unless we evaluate `a`. This is what
`deferErrorsToRuntime` does.

It does this by keeping track of which errors correspond to which coercion
in TcErrors. TcErrors.reportTidyWanteds does not print the errors
and does not fail if -fwarn-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.

\begin{code}
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
  = do { binds_var <- newTcEvBinds
       ; defer <- doptM Opt_DeferTypeErrors
       ; report_unsolved (Just binds_var) defer wanted
       ; getTcEvBinds binds_var }

reportAllUnsolved :: WantedConstraints -> TcM ()
-- Report all unsolved goals, even if -fdefer-type-errors is on
-- See Note [Deferring coercion errors to runtime]
reportAllUnsolved wanted 
  = report_unsolved Nothing (panic "reportAllUnsolved") wanted

report_unsolved :: Maybe EvBindsVar  -- cec_binds
                -> Bool              -- cec_defer
                -> WantedConstraints -> TcM ()
113
114
115
-- Important precondition:
-- WantedConstraints are fully zonked and unflattened, that is,
-- zonkWC has already been applied to these constraints.
116
report_unsolved mb_binds_var defer wanted
117
  | isEmptyWC wanted
118
  = return ()
119
  | otherwise
120
  = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
121

122
       ; env0 <- tcInitTidyEnv
123
124
125
                 
            -- If we are deferring we are going to need /all/ evidence around,
            -- including the evidence produced by unflattening (zonkWC)
126
       ; errs_so_far <- ifErrsM (return True) (return False)
127
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
128
             free_tvs = tyVarsOfWC wanted
129
             err_ctxt = CEC { cec_encl  = []
130
131
132
133
                            , cec_insol = errs_so_far || insolubleWC wanted
                                          -- Don't report ambiguity errors if
                                          -- there are any other solid errors 
                                          -- to report
134
                            , cec_tidy  = tidy_env
135
136
137
                            , cec_defer    = defer
                            , cec_suppress = False
                            , cec_binds    = mb_binds_var }
138

139
140
141
       ; traceTc "reportUnsolved (after unflattening):" $ 
         vcat [ pprTvBndrs (varSetElems free_tvs)
              , ppr wanted ]
142

143
       ; reportWanteds err_ctxt wanted }
144

145
146
147
--------------------------------------------
--      Internal functions
--------------------------------------------
148
149
150
151

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
152
                                       -- ic_skols and givens are tidied, rest are not
153
          , cec_tidy  :: TidyEnv
154
155
          , cec_insol :: Bool       -- True <=> do not report errors involving 
                                    --          ambiguous errors
156
157
158
159
160
161

          , cec_binds :: Maybe EvBindsVar 
                         -- Nothinng <=> Report all errors, including holes; no bindings
                         -- Just ev  <=> make some errors (depending on cec_defer)
                         --              into warnings, and emit evidence bindings
                         --              into 'ev' for unsolved constraints
162

163
164
          , cec_defer :: Bool       -- True <=> -fdefer-type-errors
                                    -- Irrelevant if cec_binds = Nothing
165
166
167
          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                    --          so create bindings if need be, but
                                    --          don't issue any more errors/warnings
168
169
      }

170
171
172
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                 , ic_wanted = wanted, ic_binds = evb
173
174
                                 , ic_insol = insoluble, ic_info = info })
  | BracketSkol <- info
175
176
177
178
  , 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
179
180

  | otherwise
181
  = reportWanteds ctxt' wanted
182
  where
183
    (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
184
    (env2, info') = tidySkolemInfo env1 info
185
    implic' = implic { ic_skols = tvs'
186
187
188
                     , ic_given = map (tidyEvVar env2) given
                     , ic_info  = info' }
    ctxt' = ctxt { cec_tidy  = env2
189
                 , cec_encl  = implic' : cec_encl ctxt
190
                 , cec_binds = case cec_binds ctxt of
191
192
193
194
195
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
196
  = do { reportFlats ctxt tidy_cts
197
       ; mapBagM_ (reportImplic ctxt) implics }
198
  where
199
    env = cec_tidy ctxt
200
    tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
201
202
203
                  -- All the Derived ones have been filtered out alrady
                  -- by the constraint solver. This is ok; we don't want
                  -- to report unsolved Derived goals as error
204
                  -- See Note [Do not report derived but soluble errors]
205

206
207
reportFlats :: ReportErrCtxt -> Cts -> TcM ()
reportFlats ctxt flats    -- Here 'flats' includes insolble goals
208
209
210
211
  = tryReporters 
      [ -- First deal with things that are utterly wrong
        -- Like Int ~ Bool (incl nullary TyCons)
        -- or  Int ~ t a   (AppTy on one side)
212
213
        ("Utterly wrong",  utterly_wrong,   mkGroupReporter mkEqErr)
      , ("Holes",          is_hole,         mkUniReporter mkHoleError)
214
215
216
217

        -- Report equalities of form (a~ty).  They are usually
        -- skolem-equalities, and they cause confusing knock-on 
        -- effects in other errors; see test T4093b.
218
219
220
221
      , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1)
      , ("Unambiguous",          unambiguous, reportFlatErrs) ]
      reportAmbigErrs
      ctxt (bagToList flats)
222
223
224
225
226
227
  where
    utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool

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

228
229
    is_hole ct _ = isHoleCt ct

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
    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

-----------------
259
reportAmbigErrs :: Reporter
260
261
262
263
264
265
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

266
reportFlatErrs :: Reporter
267
268
269
270
-- 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
271
reportFlatErrs
272
  = tryReporters
273
274
275
276
277
      [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
      (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
                       ; mkGroupReporter mkIPErr    ctxt ips   
                       ; mkGroupReporter mkIrredErr ctxt irreds
                       ; mkGroupReporter mkDictErr  ctxt dicts })
278
  where
279
280
281
282
283
284
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

    go [] dicts ips irreds
      = (dicts, ips, irreds)
    go (ct:cts) dicts ips irreds
285
286
      | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds
      | otherwise
287
288
289
      = case classifyPredType (ctPred ct) of
          ClassPred {}  -> go cts (ct:dicts) ips irreds
          IrredPred {}  -> go cts dicts ips (ct:irreds)
290
          _             -> panic "reportFlatErrs"
batterseapower's avatar
batterseapower committed
291
292
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
293
294
    -- And EqPreds are dealt with by the is_equality test

295
296

--------------------------------------------
297
--      Reporters
298
299
--------------------------------------------

300
301
302
303
304
305
type Reporter = ReportErrCtxt -> [Ct] -> TcM ()

mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
-- Reports errors one at a time
mkUniReporter mk_err ctxt 
  = mapM_ $ \ct -> 
306
307
308
    do { err <- mk_err ctxt ct
       ; maybeReportError ctxt err ct
       ; maybeAddDeferredBinding ctxt err ct }
309
310
311
312

mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                             -- Make error message for a group
                -> Reporter  -- Deal with lots of constraints
313
-- Group together insts from same location
314
315
-- We want to report them together in error messages

316
mkGroupReporter _ _ [] 
317
  = return ()
318
mkGroupReporter mk_err ctxt (ct1 : rest)
319
320
321
322
  = do { err <- mk_err ctxt cts
       ; maybeReportError ctxt err ct1
       ; mapM_ (maybeAddDeferredBinding ctxt err) (ct1:rest)
               -- Add deferred bindings for all
323
       ; mkGroupReporter mk_err ctxt others }
324
  where
325
   loc               = cc_loc ct1
326
327
   cts               = ct1 : friends
   (friends, others) = partition is_friend rest
328
   is_friend friend  = cc_loc friend `same_loc` loc
329

330
   same_loc :: CtLoc -> CtLoc -> Bool
331
332
   same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2

333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- Report the error and/or make a deferred binding for it
maybeReportError ctxt err ct
  | cec_suppress ctxt
  = return ()
  | isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
  = reportWarning (makeIntoWarning err)
  | otherwise
  = reportError err

maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
maybeAddDeferredBinding ctxt err ct
  | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
    -- Only add deferred bindings for Wanted constraints
  , isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
  , Just ev_binds_var <- cec_binds ctxt  -- We hvae somewhere to put the bindings
  = do { dflags <- getDynFlags
       ; let err_msg = pprLocErrMsg err
             err_fs  = mkFastString $ showSDoc dflags $
                       err_msg $$ text "(deferred type error)"

         -- Create the binding
       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }

  | otherwise   -- Do not set any evidence for Given/Derived
  = return ()   
360
361
362
363
364
365

tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] 
             -> Reporter -> Reporter
-- Use the first reporter in the list whose predicate says True
tryReporters reporters deflt ctxt cts
  = do { traceTc "tryReporters {" (ppr cts) 
366
       ; go ctxt reporters cts
367
368
       ; traceTc "tryReporters }" empty }
  where
369
370
371
372
373
374
375
376
377
378
    go ctxt [] cts = deflt ctxt cts 
    go ctxt ((str, pred, reporter) : rs) cts
      | null yeses  = do { traceTc "tryReporters: no" (text str)
                         ; go ctxt rs cts }
      | otherwise   = do { traceTc "tryReporters: yes" (text str <+> ppr yeses)
                         ; reporter ctxt yeses :: TcM ()
                         ; go (ctxt { cec_suppress = True }) rs nos }
                         -- Carry on with the rest, because we must make
                         -- deferred bindings for them if we have 
                         -- -fdefer-type-errors
379
      where
380
       (yeses, nos) = partition keep_me cts
381
       keep_me ct = pred ct (classifyPredType (ctPred ct))
382
383

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

387
pprWithArising :: [Ct] -> (CtLoc, SDoc)
388
389
-- Print something like
--    (Eq a) arising from a use of x at y
390
391
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
392
-- Works for Wanted/Derived only
393
394
pprWithArising [] 
  = panic "pprWithArising"
395
396
pprWithArising (ct:cts)
  | null cts
397
  = (loc, addArising (ctLocOrigin loc) 
dimitris's avatar
dimitris committed
398
                     (pprTheta [ctPred ct]))
399
400
  | otherwise
  = (loc, vcat (map ppr_one (ct:cts)))
401
  where
402
    loc = cc_loc ct
403
    ppr_one ct = hang (parens (pprType (ctPred ct))) 
404
                    2 (pprArisingAt (cc_loc ct))
405

406
407
408
409
410
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg 
  = do { let tcl_env = ctLocEnv (cc_loc ct)
       ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
       ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
411

412
type UserGiven = ([EvVar], SkolemInfo, SrcSpan)
413
414

getUserGivens :: ReportErrCtxt -> [UserGiven]
415
-- One item for each enclosing implication
416
getUserGivens (CEC {cec_encl = ctxt})
417
  = reverse $
418
419
420
    [ (givens, info, tcl_loc env) 
    | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt
    , not (null givens) ]
421
422
\end{code}

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
Note [Do not report derived but soluble errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The wc_flats include Derived constraints that have not been solved, but are
not insoluble (in that case they'd be in wc_insols).  We do not want to report
these as errors:

* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
  an unsolved [D] Eq a, and we do not want to report that; it's just noise.

* Functional dependencies.  For givens, consider
      class C a b | a -> b
      data T a where
         MkT :: C a d => [d] -> T a
      f :: C a b => T a -> F Int
      f (MkT xs) = length xs
  Then we get a [D] b~d.  But there *is* a legitimate call to
  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should
  not reject the program.

  For wanteds, something similar
      data T a where
        MkT :: C Int b => a -> b -> T a 
      g :: C Int c => c -> ()
      f :: T a -> ()
      f (MkT x y) = g x
  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
  But again f (MkT True True) is a legitimate call.

(We leave the Deriveds in wc_flat until reportErrors, so that we don't lose
derived superclasses between iterations of the solver.)

For functional dependencies, here is a real example, 
stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs

  class C a b | a -> b
  g :: C a b => a -> b -> () 
  f :: C a b => a -> b -> () 
  f xa xb = 
      let loop = g xa 
      in loop xb

We will first try to infer a type for loop, and we will succeed:
    C a b' => b' -> ()
Subsequently, we will type check (loop xb) and all is good. But, 
recall that we have to solve a final implication constraint: 
    C a b => (C a b' => .... cts from body of loop .... )) 
And now we have a problem as we will generate an equality b ~ b' and fail to 
solve it. 


batterseapower's avatar
batterseapower committed
473
474
475
476
477
478
479
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
480
481
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
482
483
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
batterseapower's avatar
batterseapower committed
484
  where
485
    (ct1:_) = cts
486
    orig    = ctLocOrigin (cc_loc ct1)
487
488
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
489

490
----------------
491
492
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError ctxt ct@(CHoleCan {})
493
494
495
  = do { let tyvars = varSetElems (tyVarsOfCt ct)
             tyvars_msg = map loc_msg tyvars
             msg = (text "Found hole" <+> quotes (text "_") 
496
                    <+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
497
                   $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
498
499
       ; (ctxt, binds_doc) <- relevantBindings ctxt ct
       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
500
  where
501
502
503
504
505
506
507
    loc_msg tv 
       = case tcTyVarDetails tv of
          SkolemTv {} -> quotes (ppr tv) <+> skol_msg
          MetaTv {}   -> quotes (ppr tv) <+> text "is a free type variable"
          det -> pprTcTyVarDetails det
       where 
          skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
508
509

mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
510

511
----------------
512
513
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
514
515
516
  = do { (ctxt, _, ambig_err) <- mkAmbigMsg ctxt cts
       ; (ctxt, bind_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ ambig_err $$ bind_msg) }
517
  where
518
    (ct1:_) = cts
519
    orig    = ctLocOrigin (cc_loc ct1)
520
521
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
522
523
    msg | null givens
        = addArising orig $
524
525
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
526
        | otherwise
527
        = couldNotDeduce givens (preds, orig)
528
529
530
531
532
533
534
535
536
537
\end{code}


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

\begin{code}
538
539
540
541
542
543
544
545
546
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
547
548
549
550
551
552
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
       ; (ctxt, orig) <- zonkTidyOrigin ctxt orig
       ; if isGiven ev then 
           mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct False ty1 ty2
         else
           mk_err binds_msg orig }
553
  where
554
555
    ev         = cc_ev ct
    orig       = ctLocOrigin (cc_loc ct)
dimitris's avatar
dimitris committed
556
    (ty1, ty2) = getEqPredTys (ctPred ct)
557

558
559
560
    inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in"))
                               2 (ppr orig)

561
562
       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
563
    mk_err extra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) 
564
      | act `pickyEqType` ty1
565
      , exp `pickyEqType` ty2 = mkEqErr_help ctxt extra  ct True  ty2 ty1
566
      | exp `pickyEqType` ty1
567
568
      , act `pickyEqType` ty2 = mkEqErr_help ctxt extra  ct True  ty1 ty2
      | otherwise             = mkEqErr_help ctxt extra1 ct False ty1 ty2
569
      where
570
571
572
        extra1 = msg $$ extra
        msg    = mkExpectedActualMsg exp act
    mk_err extra _ = mkEqErr_help ctxt extra ct False ty1 ty2
573

574
mkEqErr_help, reportEqErr 
575
   :: ReportErrCtxt -> SDoc
576
577
578
579
580
581
   -> 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
582
583
584
585
mkEqErr_help ctxt extra ct oriented ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt extra ct oriented tv2 ty1
  | otherwise                        = reportEqErr  ctxt extra ct oriented ty1 ty2
586

587
588
589
590
reportEqErr ctxt extra1 ct oriented ty1 ty2
  = do { (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2
       ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2
                                   , extra2, extra1]) }
591

592
mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
593
-- tv1 and ty2 are already tidied
594
mkTyVarEqErr ctxt extra ct oriented tv1 ty2
595
596
597
598
  -- Occurs check
  | isNothing (occurCheckExpand tv1 ty2)
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '~', ppr ty2])
599
    in mkErrorMsg ctxt ct (occCheckMsg $$ extra)
600

601
602
603
  |  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)
604
605
606
  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
                             , extraTyVarInfo ctxt ty1 ty2
                             , extra ])
607
608
609

  -- So tv is a meta tyvar, and presumably it is
  -- an *untouchable* meta tyvar, else it'd have been unified
610
  | not (k2 `tcIsSubKind` k1)   	 -- Kind error
611
  = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
612
613
614

  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
615
616
  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
617
  , not (null esc_skols)
618
  = do { let msg = misMatchMsg oriented ty1 ty2
619
620
621
622
623
             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") ]
624
625
626
627
628
629
630
631
             tv_extra = vcat [ nest 2 $ esc_doc
                             , sep [ (if isSingleton esc_skols 
                                      then ptext (sLit "This (rigid, skolem) type variable is")
                                      else ptext (sLit "These (rigid, skolem) type variables are"))
                               <+> ptext (sLit "bound by")
                             , nest 2 $ ppr skol_info
                             , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
       ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
632
633
634

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
635
636
637
638
639
640
641
642
643
644
  , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
  = do { let msg = misMatchMsg oriented ty1 ty2
             untch_extra 
                = nest 2 $
                  sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
                      , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given
                      , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
                      , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
             tv_extra = extraTyVarInfo ctxt ty1 ty2
       ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, extra]) }
645

646
  | otherwise
647
  = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
648
649
650
        -- 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.
651
  where         
652
653
654
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
655

656
mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM (ReportErrCtxt, SDoc)
657
658
659
660
661
662
663
664
665
-- 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)
666
       ; return (ctxt', tyfun_msg $$ ambig_msg) }
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
  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) || 
682
    isGivenCt ct
683
684
685
686
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
687
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
688
689
690
691
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

692
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
693
couldNotDeduce givens (wanteds, orig)
694
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
695
696
         , vcat (pp_givens givens)]

697
pp_givens :: [UserGiven] -> [SDoc]
dimitris's avatar
dimitris committed
698
699
pp_givens givens 
   = case givens of
700
701
702
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
703
704
    where 
       ppr_given herald (gs, skol_info, loc)
dimitris's avatar
dimitris committed
705
           = hang (herald <+> pprEvVarTheta gs)
706
707
                2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                       , ptext (sLit "at") <+> ppr loc])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
708

709
extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc
710
711
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
712
713
extraTyVarInfo ctxt ty1 ty2
  = nest 2 (extra1 $$ extra2)
714
  where
715
716
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
717

718
tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
719
-- Shows a bit of extra info about skolem constants
720
tyVarExtraInfoMsg implics ty
721
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
722
723
724
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
725
    SkolemTv {}   -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
726
727
728
729
730
731
732
    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
 
733
734
735
736
737
738
739
740
741
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

742
--------------------
743
744
745
746
747
748
749
750
751
752
753
754
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")
755
756

mkExpectedActualMsg :: Type -> Type -> SDoc
757
mkExpectedActualMsg exp_ty act_ty
758
759
  = vcat [ text "Expected type:" <+> ppr exp_ty
         , text "  Actual type:" <+> ppr act_ty ]
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
\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}
780
781
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
782
783
784
785
786
787
788
  = 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
789
790
791
       -- But we report only one of them (hence 'head') becuase they all
       -- have the same source-location origin, to try avoid a cascade
       -- of error from one location
792
       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
793
       ; mkErrorMsg ctxt ct1 err }
794
  where
795
    ct1:_ = cts
796
797
798
799
800
801
802
803
804
805
    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) }
806
      where
807
        (clas, tys) = getClassPredTys (ctPred ct)
808

809
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
810
            -> TcM (ReportErrCtxt, SDoc)
811
812
813
814
-- 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
815
816
817
  = do { (ctxt, is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct]
       ; (ctxt, binds_msg) <- relevantBindings ctxt ct
       ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
818

819
820
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
821

822
823
824
  | otherwise
  = return (ctxt, safe_haskell_msg)
  where
825
    orig        = ctLocOrigin (cc_loc ct)
826
827
828
829
830
831
    pred        = ctPred ct
    (clas, tys) = getClassPredTys pred
    ispecs      = [ispec | (ispec, _) <- matches]
    givens      = getUserGivens ctxt
    all_tyvars  = all isTyVarTy tys

832
    cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
833
834
835
      = vcat [ addArising orig (no_inst_herald <+> pprParendType pred)
             , vcat (pp_givens givens)
             , if has_ambig_tvs && (not (null unifiers) || not (null givens))
836
               then ambig_msg $$ binds_msg $$ potential_msg
837
               else empty
838
             , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859

    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
860
861

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

866
867
868
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
869

870
871
872
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
873

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

877
    -- Normal overlap error
878
    overlap_msg
879
880
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
881
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
882

883
             ,  if not (null matching_givens) then 
884
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
885
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
886
887
                else empty

888
889
890
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

891
892
893
894
895
896
897
             ,  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.
898
                  sep [ ptext (sLit "There exists a (perhaps superclass) match:") 
899
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
900
901
                else empty 

902
903
904
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
905
    		else 	-- One match
906
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
907
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
908
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
909
910
911
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
912
913
914
915
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
916
917
            matching_givens = mapCatMaybes matchable givens

918
            matchable (evvars,skol_info,loc) 
919
920
921
              = case ev_vars_matching of
                     [] -> Nothing
                     _  -> Just $ hang (pprTheta ev_vars_matching)
922
923
                                    2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                                           , ptext (sLit "at") <+> ppr loc])
924
                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
batterseapower's avatar
batterseapower committed
925
926
927
928
929
930
931
932
                      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
933

934
935
936
    -- Overlap error because of Safe Haskell (first 
    -- match should be the most specific match)
    safe_haskell_msg
937
938
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
939
                        <+> pprType (mkClassPred clas tys))
940
             , sep [ptext (sLit "The matching instance is:"),
941
942
943
944
945
946
947
                    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])
                    ]
             ]
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962

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
963

964
965
966
967
968
969
----------------------
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
970
quickFlattenTy ty@(LitTy {})    = return ty
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
  -- 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}
1014
1015
1016
1017
1018
1019
mkAmbigMsg :: ReportErrCtxt -> [Ct] 
           -> TcM (ReportErrCtxt, Bool, SDoc)
mkAmbigMsg ctxt cts
  | isEmptyVarSet ambig_tv_set
  = return (ctxt, False, empty)
  | otherwise
1020
  = do { dflags <- getDynFlags
1021
1022
1023
1024
1025
1026
1027
       
       ; prs <- mapSndM zonkTcType $ 
                [ (id, idType id) | TcIdBndr id top_lvl <- ct1_bndrs
                                  , isTopLevel top_lvl ]
       ; let ambig_ids = [id | (id, zonked_ty) <- prs
                             , tyVarsOfType zonked_ty `intersectsVarSet` ambig_tv_set]
       ; return (ctxt, True, mk_msg dflags ambig_ids) }
1028
  where
1029
1030
    ct1:_ = cts
    ct1_bndrs = tcl_bndrs (ctLocEnv (cc_loc ct1))
1031
 
1032
1033
1034
1035
1036
1037
1038
    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"
                 
1039
    mk_msg dflags ambig_ids
1040
1041
1042
1043
1044
1045
1046
1047
      | 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"
1048
             , mk_extra_msg dflags ambig_ids ]
1049
  
1050
1051
    mk_extra_msg dflags ambig_ids
      | null ambig_ids
1052
      = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
1053
1054
1055
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
1056
      | otherwise 
1057
1058
      = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:"))
	          2 (pprWithCommas (quotes . ppr) ambig_ids)
1059
1060
1061
1062
1063
1064
1065
             , 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!
             ]
1066

1067
1068
1069
1070
1071
1072
1073
1074
1075

pprSkol :: SkolemInfo -> SrcLoc -> SDoc
pprSkol UnkSkol   _ 
  = ptext (sLit "is an unknown type variable")
pprSkol skol_info tv_loc 
  = sep [ ptext (sLit "is a rigid type variable bound by"),
          sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]

getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
1076
1077
-- Get the skolem info for a type variable 
-- from the implication constraint that binds it
1078
getSkolemInfo [] tv
1079
  = pprPanic "No skolem info:" (ppr tv)
1080

1081
getSkolemInfo (implic:implics) tv
1082
  | tv `elem` ic_skols implic = ic_info implic
1083
  | otherwise                 = getSkolemInfo implics tv
1084

1085
-----------------------
1086
-- relevantBindings looks at the value environment and finds values whose
1087
1088
1089
1090
-- 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.

1091
1092
relevantBindings :: ReportErrCtxt -> Ct
                 -> TcM (ReportErrCtxt, SDoc)
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
relevantBindings ctxt ct
  = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet) 
                                 (reverse (tcl_bndrs lcl_env))
         -- The 'reverse' makes us work from outside in
         -- Blargh; maybe have a flag for this "6"

       ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
       ; let doc = hang (ptext (sLit "Relevant bindings include")) 
                      2 (vcat docs)
       ; if null docs 
1103
1104
1105
         then return (ctxt, empty)
         else do { traceTc "rb" doc
                 ; return (ctxt { cec_tidy = tidy_env' }, doc) } } 
1106
  where
1107
    lcl_env = ctLocEnv (cc_loc ct)
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
    ct_tvs = tyVarsOfCt ct

    go :: TidyEnv -> (Int, TcTyVarSet)
       -> [TcIdBinder] -> TcM (TidyEnv, [SDoc])
    go tidy_env (_,_) []
       = return (tidy_env, [])
    go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs)
       | n_left <= 0, ct_tvs `subVarSet` tvs_seen
       =   -- We have run out of n_left, and we
           -- already have bindings mentioning all of ct_tvs
         go tidy_env (n_left,tvs_seen) tc_bndrs
       | otherwise
       = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
            ; let id_tvs = tyVarsOfType tidy_ty
                  doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty
		            , nest 2 (parens (ptext (sLit "bound at")
			    	 <+> ppr (getSrcLoc id)))]
            ; if id_tvs `intersectsVarSet` ct_tvs 
              && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen))
                       -- Either we n_left is big enough, 
                       -- or this binding mentions a new type variable
              then do { (env', docs) <- go tidy_env' (n_left - 1, tvs_seen `unionVarSet` id_tvs) tc_bndrs
                      ; return (env', doc:docs) }
	      else go tidy_env (n_left, tvs_seen) tc_bndrs }
1132
1133

-----------------------
1134
warnDefaulting :: Cts -> Type -> TcM ()
1135
warnDefaulting wanteds default_ty
1136
  = do { warn_default <- woptM Opt_WarnTypeDefaults
1137
       ; env0 <- tcInitTidyEnv
1138
1139
1140
       ; let tidy_env = tidyFreeTyVars env0 $
                        tyVarsOfCts wanteds
             tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
1141
             (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1142
1143
1144
             warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                <+> quotes (ppr default_ty))
                            2 ppr_wanteds
1145
1146
1147
       ; setCtLoc loc $ warnTc warn_default warn_msg }
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1148
1149
1150
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
1151
1152
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.  
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1153

1154
1155
1156
%************************************************************************
%*									*
                 Error from the canonicaliser
1157
	 These ones are called *during* constraint simplification
1158
1159
1160
1161
%*									*
%************************************************************************

\begin{code}
1162
1163
1164
1165
solverDepthErrorTcS :: Ct -> TcM a
solverDepthErrorTcS ct
  = setCtLoc loc $
    do { ct <- zonkCt ct
dimitris's avatar
dimitris committed
1166
       ; env0 <- tcInitTidyEnv
1167
1168
1169
       ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfCt ct)
             tidy_ct  = tidyCt tidy_env ct
       ; failWithTcM (tidy_env, hang msg 2 (ppr tidy_ct)) }
dimitris's avatar
dimitris committed
1170
  where
1171
1172
    loc   = cc_loc ct
    depth = ctLocDepth loc
dimitris's avatar
dimitris committed
1173
1174
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
\end{code}

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

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

1188
zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin)
1189
1190
1191
1192
zonkTidyOrigin ctxt (GivenOrigin skol_info)
  = do { skol_info1 <- zonkSkolemInfo skol_info
       ; let (env1, skol_info2) = tidySkolemInfo (cec_tidy ctxt) skol_info1
       ; return (ctxt { cec_tidy = env1 }, GivenOrigin skol_info2) }
1193
zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
1194
  = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
1195
1196
1197
1198
       ; (env2, exp') <- zonkTidyTcType env1            exp
       ; return ( ctxt { cec_tidy = env2 }
                , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
zonkTidyOrigin ctxt orig = return (ctxt, orig)
1199
\end{code}