TcErrors.lhs 50.9 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 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
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 44
import Util
import FastString
import Outputable
import DynFlags
45
import Data.List        ( partition, mapAccumL )
46 47 48 49 50 51 52 53 54 55 56 57
\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?

58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
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
77

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
  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 ()
112 113 114
-- Important precondition:
-- WantedConstraints are fully zonked and unflattened, that is,
-- zonkWC has already been applied to these constraints.
115
report_unsolved mb_binds_var defer wanted
116
  | isEmptyWC wanted
117
  = return ()
118
  | otherwise
119
  = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
120

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

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

142
       ; reportWanteds err_ctxt wanted }
143

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

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

          , 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
          , cec_defer :: Bool       -- True <=> -fdefer-type-errors
                                    -- Irrelevant if cec_binds = Nothing
164 165
      }

166 167 168 169 170 171 172 173 174
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
175 176

  | otherwise
177
  = reportWanteds ctxt' wanted
178
  where
179 180 181 182 183 184
    (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
185
                 , cec_binds = case cec_binds ctxt of
186 187 188 189 190
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
191 192
  = do { reportOrDefer ctxt tidy_cts
       ; mapBagM_ (reportImplic ctxt) implics }
193
  where
194
    env = cec_tidy ctxt
195
    tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
196 197 198
                  -- 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
199
                  -- See Note [Do not report derived but soluble errors]
200

201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
reportOrDefer :: ReportErrCtxt -> Cts -> TcM ()
reportOrDefer ctxt@(CEC { cec_binds = mb_binds_var
                        , cec_defer = defer_errs }) cts
  | Just ev_binds_var <- mb_binds_var
  , defer_errs  -- -fdefer-type-errors: Defer all
                -- See Note [Deferring coercion errors to runtime]
  = mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) cts

  | Just ev_binds_var <- mb_binds_var
                -- No -fdefer-type-errors: Defer only holes
                -- See Note [Deferring coercion errors to runtime]
  = do { let (holes, non_holes) = partitionBag isHoleCt cts
       ; reportFlats ctxt non_holes
       ; mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) holes }
      -- Thijs had something about extending the tidy-env, but I don't know why

  | otherwise   -- Defer nothing
  = reportFlats ctxt cts
219 220 221

deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
               -> Ct -> TcM ()
222
-- See Note [Deferring coercion errors to runtime]
223
deferToRuntime ev_binds_var ctxt mk_err_msg ct 
Simon Peyton Jones's avatar
Simon Peyton Jones committed
224
  | CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
225 226 227
  = do { ctxt' <- relevantBindings ctxt ct
       ; err <- setCtLoc loc $
                mk_err_msg ctxt' ct
Ian Lynagh's avatar
Ian Lynagh committed
228
       ; dflags <- getDynFlags
229
       ; let err_msg = pprLocErrMsg err
Ian Lynagh's avatar
Ian Lynagh committed
230
             err_fs  = mkFastString $ showSDoc dflags $
231 232 233
                       err_msg $$ text "(deferred type error)"

         -- Create the binding
234
       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs)
235 236 237 238 239 240 241

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

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

242 243
reportFlats :: ReportErrCtxt -> Cts -> TcM ()
reportFlats ctxt flats    -- Here 'flats' includes insolble goals
244 245 246 247
  = tryReporters 
      [ -- First deal with things that are utterly wrong
        -- Like Int ~ Bool (incl nullary TyCons)
        -- or  Int ~ t a   (AppTy on one side)
248 249
        ("Utterly wrong",  utterly_wrong,   mkGroupReporter mkEqErr)
      , ("Holes",          is_hole,         mkUniReporter mkHoleError)
250 251 252 253

        -- Report equalities of form (a~ty).  They are usually
        -- skolem-equalities, and they cause confusing knock-on 
        -- effects in other errors; see test T4093b.
254 255 256 257
      , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1)
      , ("Unambiguous",          unambiguous, reportFlatErrs) ]
      reportAmbigErrs
      ctxt (bagToList flats)
258 259 260 261 262 263
  where
    utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool

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

264 265
    is_hole ct _ = isHoleCt ct

266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297
    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

-----------------
mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Context is already set
mkFlatErr ctxt ct   -- The constraint is always wanted
298 299
  | isHoleCt ct
  = mkHoleError ctxt ct
300
  | otherwise
301
  = case classifyPredType (ctPred ct) of
302 303
      ClassPred cls _ | isIPClass cls -> mkIPErr   ctxt [ct]
                      | otherwise     -> mkDictErr ctxt [ct]
304 305 306 307
      IrredPred {}  -> mkIrredErr ctxt [ct]
      EqPred {}     -> mkEqErr1 ctxt ct
      TuplePred {}  -> panic "mkFlat"
      
308
reportAmbigErrs :: Reporter
309 310 311 312 313 314
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

315
reportFlatErrs :: Reporter
316 317 318 319
-- 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
320
reportFlatErrs
321
  = tryReporters
322 323 324 325 326
      [ ("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 })
327
  where
328 329 330 331 332 333
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

    go [] dicts ips irreds
      = (dicts, ips, irreds)
    go (ct:cts) dicts ips irreds
334 335
      | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds
      | otherwise
336 337 338
      = case classifyPredType (ctPred ct) of
          ClassPred {}  -> go cts (ct:dicts) ips irreds
          IrredPred {}  -> go cts dicts ips (ct:irreds)
339
          _             -> panic "reportFlatErrs"
batterseapower's avatar
batterseapower committed
340 341
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
342 343
    -- And EqPreds are dealt with by the is_equality test

344 345

--------------------------------------------
346
--      Reporters
347 348
--------------------------------------------

349 350 351 352 353 354 355 356 357 358 359 360 361 362
type Reporter = ReportErrCtxt -> [Ct] -> TcM ()

mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
-- Reports errors one at a time
mkUniReporter mk_err ctxt 
  = mapM_ $ \ct -> 
   do { ctxt' <- relevantBindings ctxt ct
      ; err <- setCtFlavorLoc (cc_ev ct) $
               mk_err ctxt' ct; 
      ; reportError err }

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

366
mkGroupReporter _ _ [] 
367
  = return ()
368 369 370 371 372 373
mkGroupReporter mk_err ctxt (ct1 : rest)
  = do { ctxt' <- relevantBindings ctxt ct1
       ; err <- setCtFlavorLoc flavor $ 
                mk_err ctxt' cts
       ; reportError err
       ; mkGroupReporter mk_err ctxt others }
374
  where
375
   flavor            = cc_ev ct1
376 377
   cts               = ct1 : friends
   (friends, others) = partition is_friend rest
378
   is_friend friend  = cc_ev friend `same_group` flavor
379

380
   same_group :: CtEvidence -> CtEvidence -> Bool
Simon Peyton Jones's avatar
Simon Peyton Jones committed
381 382 383
   same_group (CtGiven   {ctev_gloc = l1}) (CtGiven   {ctev_gloc = l2}) = same_loc l1 l2
   same_group (CtWanted  {ctev_wloc = l1}) (CtWanted  {ctev_wloc = l2}) = same_loc l1 l2
   same_group (CtDerived {ctev_wloc = l1}) (CtDerived {ctev_wloc = l2}) = same_loc l1 l2
384
   same_group _ _ = False
385

386
   same_loc :: CtLoc o -> CtLoc o -> Bool
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406
   same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2


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) 
       ; go reporters cts
       ; traceTc "tryReporters }" empty }
  where
    go [] cts = deflt ctxt 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 ctxt yeses
      where
       yeses = filter keep_me cts
       keep_me ct = pred ct (classifyPredType (ctPred ct))
407 408

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

412
pprWithArising :: [Ct] -> (WantedLoc, SDoc)
413 414
-- Print something like
--    (Eq a) arising from a use of x at y
415 416
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
417
-- Works for Wanted/Derived only
418 419
pprWithArising [] 
  = panic "pprWithArising"
420 421
pprWithArising (ct:cts)
  | null cts
422
  = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) 
dimitris's avatar
dimitris committed
423
                     (pprTheta [ctPred ct]))
424 425
  | otherwise
  = (loc, vcat (map ppr_one (ct:cts)))
426
  where
427 428 429
    loc = ctWantedLoc ct
    ppr_one ct = hang (parens (pprType (ctPred ct))) 
                    2 (pprArisingAt (ctWantedLoc ct))
430

431 432
mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg
mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
433

434 435 436
type UserGiven = ([EvVar], GivenLoc)

getUserGivens :: ReportErrCtxt -> [UserGiven]
437
-- One item for each enclosing implication
438
getUserGivens (CEC {cec_encl = ctxt})
439
  = reverse $
440 441
    [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
                    , not (null givens) ]
442 443
\end{code}

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 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493
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
494 495 496 497 498 499 500
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
501 502 503
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
  = mkErrorReport ctxt msg
batterseapower's avatar
batterseapower committed
504
  where
505 506 507 508
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
509 510
\end{code}

511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551
\begin{code}
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError ctxt ct@(CHoleCan {})
  = do { let env0 = cec_tidy ctxt
       ; let vars = tyVarsOfCt ct

       ; zonked_vars <- zonkTyVarsAndFV vars

       ; (env1, zonked_ty) <- zonkTidyTcType env0 (cc_hole_ty ct)

       ; let (env2, tyvars) = tidyOpenTyVars env1 (varSetElems zonked_vars)

       ; tyvars_msg <- mapM loc_msg tyvars

       ; traceTc "mkHoleError" (ppr env2)

       ; let msg = (text "Found hole" <+> quotes (text "_") <+> text "with type") <+> pprType zonked_ty
                   $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)

       ; mkErrorReport ctxt msg
       }
  where
    loc_msg tv = case tcTyVarDetails tv of
                    SkolemTv {} -> return $ (quotes $ ppr tv) <+> skol_msg
                    MetaTv {} -> do { tyvar <- readMetaTyVar tv
                                    ; return $ case tyvar of
                                        (Indirect ty) -> (quotes $ pprType ty) <+> skol_msg
                                        Flexi -> (quotes $ ppr tv) <+> text "is a free type variable"
                                    }
                    det -> return $ pprTcTyVarDetails det
                where skol_msg = ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)

    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

mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
\end{code}
552 553 554 555 556 557 558 559

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

\begin{code}
560 561 562 563
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
  = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts
       ; mkErrorReport ctxt' (msg $$ ambig_err) }
564
  where
565 566 567 568
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
569 570
    msg | null givens
        = addArising orig $
571 572
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
573
        | otherwise
574
        = couldNotDeduce givens (preds, orig)
575 576 577 578 579 580 581 582 583 584
\end{code}


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

\begin{code}
585 586 587 588 589 590 591 592 593
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
594
  = if isGiven flav then 
dimitris's avatar
dimitris committed
595 596 597 598 599 600
      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' }
601
  where
dimitris's avatar
dimitris committed
602

603
    flav = cc_ev ct
dimitris's avatar
dimitris committed
604

Simon Peyton Jones's avatar
Simon Peyton Jones committed
605
    inaccessible_msg (CtGiven { ctev_gloc = loc }) 
606 607
       = hang (ptext (sLit "Inaccessible code in"))
            2 (ppr (ctLocOrigin loc))
dimitris's avatar
dimitris committed
608 609
    -- If a Solved then we should not report inaccessible code
    inaccessible_msg _ = empty
610

dimitris's avatar
dimitris committed
611
    (ty1, ty2) = getEqPredTys (ctPred ct)
612 613 614 615 616 617 618 619 620 621 622 623 624 625

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

626 627 628 629 630 631 632 633
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
634 635 636
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
637 638 639
  | otherwise                        = reportEqErr ctxt ct oriented ty1 ty2

reportEqErr ctxt ct oriented ty1 ty2
640 641 642 643
  = 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
644
-- tv1 and ty2 are already tidied
645
mkTyVarEqErr ctxt ct oriented tv1 ty2
646 647 648 649 650 651
  -- Occurs check
  | isNothing (occurCheckExpand tv1 ty2)
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '~', ppr ty2])
    in mkErrorReport ctxt occCheckMsg

652 653 654
  |  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)
655 656
  = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2)
                  (misMatchOrCND ctxt ct oriented ty1 ty2)
657 658 659

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

  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
665
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
666 667 668 669
        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
670
    do { let msg = misMatchMsg oriented ty1 ty2
671 672 673 674 675 676
             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
677
                           , sep [ (if isSingleton esc_skols 
678 679
                                    then ptext (sLit "This (rigid, skolem) type variable is")
                                    else ptext (sLit "These (rigid, skolem) type variables are"))
680
                                   <+> ptext (sLit "bound by")
681
                                 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
682
       ; mkErrorReport ctxt (msg $$ extra1) }
683 684 685 686 687 688

  -- 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) $
689
    do { let msg = misMatchMsg oriented ty1 ty2
690 691 692
             extra = quotes (ppr tv1)
                 <+> sep [ ptext (sLit "is untouchable")
                         , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
693
                         , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
694
       ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
695

696
  | otherwise
697 698 699 700
  = 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.
701
  where         
702 703 704
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
705

706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731
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) || 
732
    isGivenCt ct
733 734 735 736
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
737
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
738 739 740 741
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

742
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
743
couldNotDeduce givens (wanteds, orig)
744
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
745 746 747 748 749
         , vcat (pp_givens givens)]

pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
pp_givens givens 
   = case givens of
750 751 752
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
dimitris's avatar
dimitris committed
753 754 755 756
    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
757

758
addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
759 760
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
761
addExtraTyVarInfo ctxt ty1 ty2
762
  = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
763
  where
764 765
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
766

767
tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
768
-- Shows a bit of extra info about skolem constants
769
tyVarExtraInfoMsg implics ty
770
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
771 772 773 774 775 776 777 778 779 780 781
  , 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
782 783 784 785 786 787 788
   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
789
 
790 791 792 793 794 795 796 797 798
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

799
--------------------
800 801 802 803 804 805 806 807 808 809 810 811
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")
812 813

mkExpectedActualMsg :: Type -> Type -> SDoc
814
mkExpectedActualMsg exp_ty act_ty
815 816
  = vcat [ text "Expected type:" <+> ppr exp_ty
         , text "  Actual type:" <+> ppr act_ty ]
817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836
\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}
837 838
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
839 840 841 842 843 844 845
  = 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
846 847 848
       -- 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
849 850
       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
       ; mkErrorReport ctxt err }
851
  where
852 853 854 855 856 857 858 859 860 861
    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) }
862
      where
863
        (clas, tys) = getClassPredTys (ctPred ct)
864

865 866 867 868 869 870 871 872
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) }
873

874 875
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
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 914 915 916
  | 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
917 918

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

923 924 925
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
926

927 928 929 930
    inst_decl_fixes
      | all_tyvars = []
      | otherwise  = [ sep [ ptext (sLit "add an instance declaration for")
                           , pprParendType pred] ]
931

932 933 934
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
935

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

939
    -- Normal overlap error
940
    overlap_msg
941 942
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
943
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
944

945
             ,  if not (null matching_givens) then 
946
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
947
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
948 949
                else empty

950 951 952
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

953 954 955 956 957 958 959
             ,  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.
960
                  sep [ ptext (sLit "There exists a (perhaps superclass) match:") 
961
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
962 963
                else empty 

964 965 966
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
967
    		else 	-- One match
968
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
969
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
970
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
971 972 973
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
974 975 976 977
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
978 979
            matching_givens = mapCatMaybes matchable givens

980 981 982 983 984 985 986
            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
987 988 989 990 991 992 993 994
                      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
995

996 997 998
    -- Overlap error because of Safe Haskell (first 
    -- match should be the most specific match)
    safe_haskell_msg
999 1000
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
1001
                        <+> pprType (mkClassPred clas tys))
1002
             , sep [ptext (sLit "The matching instance is:"),
1003 1004 1005 1006 1007 1008 1009
                    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])
                    ]
             ]
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024

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
1025

1026 1027 1028 1029 1030 1031
----------------------
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
1032
quickFlattenTy ty@(LitTy {})    = return ty
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075
  -- 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}
1076 1077 1078 1079 1080 1081
mkAmbigMsg :: ReportErrCtxt -> [Ct] 
           -> TcM (ReportErrCtxt, Bool, SDoc)
mkAmbigMsg ctxt cts
  | isEmptyVarSet ambig_tv_set
  = return (ctxt, False, empty)
  | otherwise
1082
  = do { dflags <- getDynFlags
1083 1084 1085 1086 1087 1088 1089
       
       ; 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) }
1090
  where
1091 1092 1093 1094 1095
    ct1_bndrs = case cts of
                  (ct1:_) -> ASSERT( not (isGivenCt ct1) )
                             tcl_bndrs (ctLocEnv (ctWantedLoc ct1))
                  [] -> panic "mkAmbigMsg"
 
1096 1097 1098 1099 1100 1101 1102
    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"
                 
1103
    mk_msg dflags ambig_ids
1104 1105 1106 1107 1108 1109 1110 1111
      | 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"
1112
             , mk_extra_msg dflags ambig_ids ]
1113
  
1114 1115
    mk_extra_msg dflags ambig_ids
      | null ambig_ids
1116
      = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
1117 1118 1119
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
1120
      | otherwise 
1121 1122
      = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:"))
	          2 (pprWithCommas (quotes . ppr) ambig_ids)
1123 1124 1125 1126 1127 1128 1129
             , 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!
             ]
1130

1131
getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
1132 1133
-- Get the skolem info for a type variable 
-- from the implication constraint that binds it
1134
getSkolemInfo [] tv
1135
  = pprPanic "No skolem info:" (ppr tv)
1136

1137
getSkolemInfo (implic:implics) tv
1138
  | tv `elem` ic_skols implic = ic_loc implic
1139
  | otherwise                 = getSkolemInfo implics tv
1140

1141
-----------------------
1142
-- relevantBindings looks at the value environment and finds values whose
1143 1144 1145 1146
-- 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.

1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163
relevantBindings :: ReportErrCtxt
                 -> Ct
                 -> TcM ReportErrCtxt
                 -- cec_extra includes info about relevant bindings
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 
         then return ctxt
         else return (ctxt { cec_tidy = tidy_env'  
                           , cec_extra = doc $$ cec_extra ctxt }) }
1164
  where
1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189
    lcl_env = ctEvEnv (cc_ev ct)
    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 }