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

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

       flattenForAllErrorTcS,
       solverDepthErrorTcS
16 17 18 19
  ) where

#include "HsVersions.h"

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

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

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

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

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

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

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

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

93
       ; reportWanteds err_ctxt wanted
94

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

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

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

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

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

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
  = reportTidyWanteds ctxt tidy_insols tidy_flats implics
143
  where
144 145
    env = cec_tidy ctxt
    tidy_insols = mapBag (tidyCt env) insols
146 147 148 149
    tidy_flats  = mapBag (tidyCt env) flats
                  -- 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
150
                  -- See Note [Do not report derived but soluble errors]
151 152 153 154 155 156 157 158 159 160

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

161
  | otherwise
162 163 164 165 166 167 168
  = do { reportInsolsAndFlats ctxt insols flats
       ; mapBagM_ (reportImplic ctxt) implics }
             

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-----------------
mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Context is already set
mkFlatErr ctxt ct   -- The constraint is always wanted
266 267
  | isIPPred (ctPred ct) = mkIPErr    ctxt [ct]
  | otherwise
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
  = case classifyPredType (ctPred ct) of
      ClassPred {}  -> mkDictErr  ctxt [ct]
      IrredPred {}  -> mkIrredErr ctxt [ct]
      EqPred {}     -> mkEqErr1 ctxt ct
      TuplePred {}  -> panic "mkFlat"
      
reportAmbigErrs :: ReportErrCtxt -> Reporter
reportAmbigErrs ctxt cts
  | cec_insol ctxt = return ()
  | otherwise      = reportFlatErrs ctxt cts
          -- Only report ambiguity if no other errors (at all) happened
          -- See Note [Avoiding spurious errors] in TcSimplify

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

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

311 312 313 314 315

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

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

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

334 335 336 337
   same_group :: CtEvidence -> CtEvidence -> Bool
   same_group (Given   {ctev_gloc = l1}) (Given   {ctev_gloc = l2}) = same_loc l1 l2
   same_group (Wanted  {ctev_wloc = l1}) (Wanted  {ctev_wloc = l2}) = same_loc l1 l2
   same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2
338
   same_group _ _ = False
339

340 341
   same_loc :: CtLoc o -> CtLoc o -> Bool
   same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2
342 343

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

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

366 367
mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg
mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
368

369 370 371
type UserGiven = ([EvVar], GivenLoc)

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

379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
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
429 430 431 432 433 434 435
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
436 437 438
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
  = mkErrorReport ctxt msg
batterseapower's avatar
batterseapower committed
439
  where
440 441 442 443
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
444 445
\end{code}

446 447 448 449 450 451 452 453

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

\begin{code}
454 455 456 457
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
  = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts
       ; mkErrorReport ctxt' (msg $$ ambig_err) }
458
  where
459 460 461 462
    (ct1:_) = cts
    orig    = ctLocOrigin (ctWantedLoc ct1)
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
463 464
    msg | null givens
        = addArising orig $
465 466
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
467
        | otherwise
468
        = couldNotDeduce givens (preds, orig)
469 470 471 472 473 474 475 476 477 478
\end{code}


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

\begin{code}
479 480 481 482 483 484 485 486 487
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
488
  = if isGiven flav then 
dimitris's avatar
dimitris committed
489 490 491 492 493 494
      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' }
495
  where
dimitris's avatar
dimitris committed
496

497
    flav = cc_ev ct
dimitris's avatar
dimitris committed
498

499 500 501
    inaccessible_msg (Given { ctev_gloc = loc }) 
       = hang (ptext (sLit "Inaccessible code in"))
            2 (ppr (ctLocOrigin loc))
dimitris's avatar
dimitris committed
502 503
    -- If a Solved then we should not report inaccessible code
    inaccessible_msg _ = empty
504

dimitris's avatar
dimitris committed
505
    (ty1, ty2) = getEqPredTys (ctPred ct)
506 507 508 509 510 511 512 513 514 515 516 517 518 519

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

520 521 522 523 524 525 526 527
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
528 529 530
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
531 532 533
  | otherwise                        = reportEqErr ctxt ct oriented ty1 ty2

reportEqErr ctxt ct oriented ty1 ty2
534 535 536 537
  = 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
538
-- tv1 and ty2 are already tidied
539
mkTyVarEqErr ctxt ct oriented tv1 ty2
540 541 542
  |  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)
543 544
  = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2)
                  (misMatchOrCND ctxt ct oriented ty1 ty2)
545 546 547

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

551
  -- Occurs check
552
  | isNothing (occurCheckExpand tv1 ty2)
553 554
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '=', ppr ty2])
555
    in mkErrorReport ctxt occCheckMsg
556

557 558
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
559
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
560 561 562 563
        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
564 565
    do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1)
       ; let msg = misMatchMsg oriented ty1 ty2
566 567 568 569 570 571
             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
572
                           , sep [ (if isSingleton esc_skols 
573 574
                                    then ptext (sLit "This (rigid, skolem) type variable is")
                                    else ptext (sLit "These (rigid, skolem) type variables are"))
575
                                   <+> ptext (sLit "bound by")
576
                                 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
577
       ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
578 579 580 581 582 583

  -- 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) $
584
    do { let msg = misMatchMsg oriented ty1 ty2
585 586 587
             extra = quotes (ppr tv1)
                 <+> sep [ ptext (sLit "is untouchable")
                         , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
588
                         , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
589
       ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
590

591
  | otherwise
592 593 594 595
  = 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.
596
  where         
597 598 599
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
600

601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
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) || 
627
    isGiven (cc_ev ct)
628 629 630 631
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
632
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
633 634 635 636
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

637
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
638
couldNotDeduce givens (wanteds, orig)
639
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
640 641 642 643 644
         , vcat (pp_givens givens)]

pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
pp_givens givens 
   = case givens of
645 646 647
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
dimitris's avatar
dimitris committed
648 649 650 651
    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
652

653
addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
654 655
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
656
addExtraTyVarInfo ctxt ty1 ty2
657
  = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
658
  where
659 660
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
661

662
tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
663
-- Shows a bit of extra info about skolem constants
664
tyVarExtraInfoMsg implics ty
665
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
666 667 668 669 670 671 672 673 674 675 676
  , 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
677 678 679 680 681 682 683
   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
684
 
685 686 687 688 689 690 691 692 693
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

694
--------------------
695 696 697 698 699 700 701 702 703 704 705 706
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")
707 708

mkExpectedActualMsg :: Type -> Type -> SDoc
709
mkExpectedActualMsg exp_ty act_ty
710 711
  = vcat [ text "Expected type:" <+> ppr exp_ty
         , text "  Actual type:" <+> ppr act_ty ]
712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731
\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}
732 733
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
734 735 736 737 738 739 740
  = 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
741 742 743
       -- 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
744 745
       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
       ; mkErrorReport ctxt err }
746
  where
747 748 749 750 751 752 753 754 755 756
    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) }
757
      where
758
        (clas, tys) = getClassPredTys (ctPred ct)
759

760 761 762 763 764 765 766 767
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) }
768

769 770
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
771

772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811
  | 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
812 813

	-- Do not suggest adding constraints to an *inferred* type signature!
814
    get_good_orig ic = case ctLocOrigin (ic_loc ic) of 
815 816 817
                             SigSkol (InfSigCtxt {}) _ -> Nothing
                             origin                    -> Just origin

818 819 820
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
821

822 823 824 825
    inst_decl_fixes
      | all_tyvars = []
      | otherwise  = [ sep [ ptext (sLit "add an instance declaration for")
                           , pprParendType pred] ]
826

827 828 829
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
830

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

834
    -- Normal overlap error
835
    overlap_msg
836 837
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
838
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
839

840
             ,  if not (null matching_givens) then 
841
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
842
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
843 844
                else empty

845 846 847
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

848 849 850 851 852 853 854
             ,  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.
855
                  sep [ ptext (sLit "There exists a (perhaps superclass) match:") 
856
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
857 858
                else empty 

859 860 861
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
862
    		else 	-- One match
863
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
864
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
865
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
866 867 868
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
869 870 871 872
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
873 874
            matching_givens = mapCatMaybes matchable givens

875 876 877 878 879 880 881
            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
882 883 884 885 886 887 888 889
                      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
890

891 892 893
    -- Overlap error because of Safe Haskell (first 
    -- match should be the most specific match)
    safe_haskell_msg
894 895
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
896
                        <+> pprType (mkClassPred clas tys))
897
             , sep [ptext (sLit "The matching instance is:"),
898 899 900 901 902 903 904
                    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])
                    ]
             ]
905 906 907 908 909 910 911 912 913 914 915 916 917 918 919

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
920

921 922 923 924 925 926
----------------------
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
927
quickFlattenTy ty@(LitTy {})    = return ty
928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970
  -- 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}
971 972 973 974 975 976
mkAmbigMsg :: ReportErrCtxt -> [Ct] 
           -> TcM (ReportErrCtxt, Bool, SDoc)
mkAmbigMsg ctxt cts
  | isEmptyVarSet ambig_tv_set
  = return (ctxt, False, empty)
  | otherwise
977
  = do { dflags <- getDynFlags
978 979
       ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set
       ; return (ctxt', True, mk_msg dflags gbl_docs) }
980
  where
981 982 983 984 985 986 987
    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"
                 
988
    mk_msg dflags docs 
989 990 991 992 993 994 995 996 997 998 999 1000 1001
      | any isRuntimeUnkSkol ambig_tvs  -- See Note [Runtime skolems]
      =  vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
                   <+> pprQuotedList ambig_tvs
              , ptext (sLit "Use :print or :force to determine these types")]
      | otherwise
      = vcat [ text "The type variable" <> plural ambig_tvs
	          <+> pprQuotedList ambig_tvs
                  <+> is_or_are <+> text "ambiguous"
             , mk_extra_msg dflags docs ]
  
    mk_extra_msg dflags docs
      | null docs
      = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)")
1002 1003 1004
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
1005 1006 1007 1008 1009 1010 1011 1012 1013 1014
      | otherwise 
      = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:")
	     , nest 2 (vcat docs)
             , ptext (sLit "Probable fix:") <+> vcat
     	          [ ptext (sLit "give these definition(s) an explicit type signature")
     	          , if xopt Opt_MonomorphismRestriction dflags
                    then ptext (sLit "or use -XNoMonomorphismRestriction")
                    else empty ]    -- Only suggest adding "-XNoMonomorphismRestriction"
     			            -- if it is not already set!
             ]
1015

1016
getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
1017 1018
-- Get the skolem info for a type variable 
-- from the implication constraint that binds it
1019 1020
getSkolemInfo [] tv
  = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
1021 1022
    CtLoc UnkSkol noSrcSpan []

1023
getSkolemInfo (implic:implics) tv
1024
  | tv `elem` ic_skols implic = ic_loc implic
1025
  | otherwise                 = getSkolemInfo implics tv
1026

1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
-----------------------
-- findGlobals looks at the value environment and finds values whose
-- types mention any of the offending type variables.  It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.

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

findGlobals :: ReportErrCtxt
            -> TcTyVarSet
1041
            -> TcM (ReportErrCtxt, [SDoc])
1042 1043 1044 1045 1046 1047 1048

findGlobals ctxt tvs 
  = do { lcl_ty_env <- case cec_encl ctxt of 
                        []    -> getLclTypeEnv
                        (i:_) -> return (ic_env i)
       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
  where
1049 1050 1051 1052 1053 1054
    go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc)
    go tidy_env acc (thing : things)
       = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
	    ; case maybe_doc of
	        Just d  -> go tidy_env1 (d:acc) things
	        Nothing -> go tidy_env1 acc     things }
1055 1056 1057 1058 1059 1060 1061

    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty

-----------------------
find_thing :: TidyEnv -> (TcType -> Bool)
           -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
find_thing tidy_env ignore_it (ATcId { tct_id = id })
1062 1063
  = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
       ; if ignore_it tidy_ty then
1064 1065
	   return (tidy_env, Nothing)
         else do 
1066
       { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
1067 1068 1069 1070
		       , nest 2 (parens (ptext (sLit "bound at") <+>
			 	   ppr (getSrcLoc id)))]
       ; return (tidy_env', Just msg) } }

1071 1072 1073
find_thing tidy_env ignore_it (ATyVar name tv)
  = do { ty <- zonkTcTyVar tv
       ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty
1074
       ; if ignore_it tidy_ty then
1075 1076 1077
	    return (tidy_env, Nothing)
         else do
       { let -- The name tv is scoped, so we don't need to tidy it
1078
            msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff
1079 1080
                      , nest 2 bound_at]

1081
            eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
1082
		     , getOccName name == getOccName tv' = empty
1083 1084
		     | otherwise = equals <+> ppr tidy_ty
		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
1085
	    bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name)
1086 1087 1088 1089 1090
 
       ; return (tidy_env1, Just msg) } }

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

1091
warnDefaulting :: Cts -> Type -> TcM ()
1092
warnDefaulting wanteds default_ty
1093
  = do { warn_default <- woptM Opt_WarnTypeDefaults
1094
       ; env0 <- tcInitTidyEnv
1095 1096 1097
       ; let tidy_env = tidyFreeTyVars env0 $
                        tyVarsOfCts wanteds
             tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
1098
             (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1099 1100 1101
             warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                <+> quotes (ppr default_ty))
                            2 ppr_wanteds
1102 1103 1104
       ; setCtLoc loc $ warnTc warn_default warn_msg }
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1105 1106 1107
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
1108 1109
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.  
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1110

1111 1112 1113
%************************************************************************
%*									*
                 Error from the canonicaliser
1114
	 These ones are called *during* constraint simplification
1115 1116 1117 1118
%*									*
%************************************************************************

\begin{code}
1119
solverDepthErrorTcS :: Int -> [Ct] -> TcM a
1120 1121
solverDepthErrorTcS depth stack
  | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
1122
  = failWith msg
1123
  | otherwise
1124
  = setCtFlavorLoc (cc_ev top_item) $
dimitris's avatar
dimitris committed
1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135
    do { zstack <- mapM zonkCt stack
       ; env0 <- tcInitTidyEnv
       ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack
             tidy_env = tidyFreeTyVars env0 zstack_tvs
             tidy_cts = map (tidyCt tidy_env) zstack
       ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) }
  where
    top_item = head stack
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]

1136
flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a
1137
flattenForAllErrorTcS fl ty
1138
  = setCtFlavorLoc fl $ 
1139 1140 1141 1142 1143 1144
    do { env0 <- tcInitTidyEnv
       ; let (env1, ty') = tidyOpenType env0 ty 
             msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
                       , ppr ty' ]
       ; failWithTcM (env1, msg) }
\end{code}
1145 1146 1147 1148 1149 1150 1151 1152

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

\begin{code}
1153 1154 1155 1156
setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a
setCtFlavorLoc (Wanted  { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing
setCtFlavorLoc (Given   { ctev_gloc = loc }) thing = setCtLoc loc thing
1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169
\end{code}

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

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

1170
zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin)
simonpj@microsoft.com's avatar