compiler/typecheck/TcErrors.lhs

   1 \begin{code}
   2 module TcErrors(
   3        reportUnsolved,
   4        warnDefaulting,
   5        unifyCtxt,
   6
   7        flattenForAllErrorTcS,
   8        solverDepthErrorTcS
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import TcRnMonad
  14 import TcMType
  15 import TcSMonad
  16 import TcType
  17 import TypeRep
  18 import Type( isTyVarTy )
  19 import Unify ( tcMatchTys )
  20
  21 import Inst
  22 import InstEnv
  23
  24 import TyCon
  25 import Name
  26 import NameEnv
  27 import Id       ( idType )
  28 import Var
  29 import VarSet
  30 import VarEnv
  31 import SrcLoc
  32 import Bag
  33 import ListSetOps( equivClasses )
  34 import Util
  35 import FastString
  36 import Outputable
  37 import DynFlags
  38 import StaticFlags( opt_PprStyle_Debug )
  39 import Data.List( partition )
  40 import Control.Monad( when, unless )
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \section{Errors and contexts}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 ToDo: for these error messages, should we note the location as coming
  50 from the insts, or just whatever seems to be around in the monad just
  51 now?
  52
  53 \begin{code}
  54 reportUnsolved :: WantedConstraints -> TcM ()
  55 reportUnsolved wanted
  56   | isEmptyWC wanted
  57   = return ()
  58   | otherwise
  59   = do {   -- Zonk to un-flatten any flatten-skols
  60        ; wanted  <- zonkWC wanted
  61
  62        ; env0 <- tcInitTidyEnv
  63        ; let tidy_env = tidyFreeTyVars env0 free_tvs
  64              free_tvs = tyVarsOfWC wanted
  65              err_ctxt = CEC { cec_encl  = []
  66                             , cec_insol = insolubleWC wanted
  67                             , cec_extra = empty
  68                             , cec_tidy  = tidy_env }
  69              tidy_wanted = tidyWC tidy_env wanted
  70
  71        ; traceTc "reportUnsolved" (ppr tidy_wanted)
  72
  73        ; reportTidyWanteds err_ctxt tidy_wanted }
  74
  75 --------------------------------------------
  76 --      Internal functions
  77 --------------------------------------------
  78
  79 data ReportErrCtxt
  80     = CEC { cec_encl :: [Implication]  -- Enclosing implications
  81                                        --   (innermost first)
  82           , cec_tidy  :: TidyEnv
  83           , cec_extra :: SDoc       -- Add this to each error message
  84           , cec_insol :: Bool       -- True <=> we are reporting insoluble errors only
  85                                     --      Main effect: don't say "Cannot deduce..."
  86                                     --      when reporting equality errors; see misMatchOrCND
  87       }
  88
  89 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
  90 reportTidyImplic ctxt implic
  91   | BracketSkol <- ctLocOrigin (ic_loc implic)
  92   , not insoluble  -- For Template Haskell brackets report only
  93   = return ()      -- definite errors. The whole thing will be re-checked
  94                    -- later when we plug it in, and meanwhile there may
  95                    -- certainly be un-satisfied constraints
  96
  97   | otherwise
  98   = reportTidyWanteds ctxt' (ic_wanted implic)
  99   where
 100     insoluble = ic_insol implic
 101     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
 102                  , cec_insol = insoluble }
 103
 104 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 105 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
 106   | cec_insol ctxt     -- If there are any insolubles, report only them
 107                        -- because they are unconditionally wrong
 108                        -- Moreover, if any of the insolubles are givens, stop right there
 109                        -- ignoring nested errors, because the code is inaccessible
 110   = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
 111              insol_implics  = filterBag ic_insol implics
 112        ; if isEmptyBag given
 113          then do { mapBagM_ (reportInsoluble ctxt) other
 114                  ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
 115          else mapBagM_ (reportInsoluble ctxt) given }
 116
 117   | otherwise          -- No insoluble ones
 118   = ASSERT( isEmptyBag insols )
 119     do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
 120              (tv_eqs, others)     = partition is_tv_eq non_ambigs
 121
 122        ; groupErrs (reportEqErrs ctxt) tv_eqs
 123        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
 124        ; mapBagM_ (reportTidyImplic ctxt) implics
 125
 126            -- Only report ambiguity if no other errors (at all) happened
 127            -- See Note [Avoiding spurious errors] in TcSimplify
 128        ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
 129   where
 130     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 131
 132         -- Report equalities of form (a~ty) first.  They are usually
 133         -- skolem-equalities, and they cause confusing knock-on
 134         -- effects in other errors; see test T4093b.
 135     is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
 136                = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
 137                | otherwise = False
 138
 139         -- Treat it as "ambiguous" if
 140         --   (a) it is a class constraint
 141         --   (b) it constrains only type variables
 142         --       (else we'd prefer to report it as "no instance for...")
 143         --   (c) it mentions type variables that are not skolems
 144     is_ambiguous d = isTyVarClassPred pred
 145                   && not (tyVarsOfPred pred `subVarSet` skols)
 146                   where
 147                      pred = evVarOfPred d
 148
 149 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
 150 reportInsoluble ctxt (EvVarX ev flav)
 151   | EqPred ty1 ty2 <- evVarPred ev
 152   = setCtFlavorLoc flav $
 153     do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
 154        ; reportEqErr ctxt2 ty1 ty2 }
 155   | otherwise
 156   = pprPanic "reportInsoluble" (pprEvVarWithType ev)
 157   where
 158     inaccessible_msg | Given loc GivenOrig <- flav
 159                        -- If a GivenSolved then we should not report inaccessible code
 160                      = hang (ptext (sLit "Inaccessible code in"))
 161                           2 (ppr (ctLocOrigin loc))
 162                      | otherwise = empty
 163
 164 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 165 -- The [PredType] are already tidied
 166 reportFlat ctxt flats origin
 167   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
 168        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
 169        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
 170        ; ASSERT( null others ) return () }
 171   where
 172     (dicts, non_dicts) = partition isClassPred flats
 173     (eqs, non_eqs)     = partition isEqPred    non_dicts
 174     (ips, others)      = partition isIPPred    non_eqs
 175
 176 --------------------------------------------
 177 --      Support code
 178 --------------------------------------------
 179
 180 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 181           -> [WantedEvVar]                      -- Unsolved wanteds
 182           -> TcM ()
 183 -- Group together insts with the same origin
 184 -- We want to report them together in error messages
 185
 186 groupErrs _ []
 187   = return ()
 188 groupErrs report_err (wanted : wanteds)
 189   = do  { setCtLoc the_loc $
 190           report_err the_vars (ctLocOrigin the_loc)
 191         ; groupErrs report_err others }
 192   where
 193    the_loc           = evVarX wanted
 194    the_key           = mk_key the_loc
 195    the_vars          = map evVarOfPred (wanted:friends)
 196    (friends, others) = partition is_friend wanteds
 197    is_friend friend  = mk_key (evVarX friend) `same_key` the_key
 198
 199    mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
 200    mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
 201
 202    same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
 203    same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
 204    same_orig ScOrigin          ScOrigin          = True
 205    same_orig DerivOrigin       DerivOrigin       = True
 206    same_orig DefaultOrigin     DefaultOrigin     = True
 207    same_orig _ _ = False
 208
 209
 210 -- Add the "arising from..." part to a message about bunch of dicts
 211 addArising :: CtOrigin -> SDoc -> SDoc
 212 addArising orig msg = msg $$ nest 2 (pprArising orig)
 213
 214 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 215 -- Print something like
 216 --    (Eq a) arising from a use of x at y
 217 --    (Show a) arising from a use of p at q
 218 -- Also return a location for the error message
 219 pprWithArising []
 220   = panic "pprWithArising"
 221 pprWithArising [EvVarX ev loc]
 222   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 223 pprWithArising ev_vars
 224   = (first_loc, vcat (map ppr_one ev_vars))
 225   where
 226     first_loc = evVarX (head ev_vars)
 227     ppr_one (EvVarX v loc)
 228        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 229
 230 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 231 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 232
 233 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 234 pprErrCtxtLoc ctxt
 235   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 236        []           -> ptext (sLit "the top level")     -- Should not happen
 237        (orig:origs) -> ppr_skol orig $$
 238                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 239   where
 240     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 241     ppr_skol skol_info      = ppr skol_info
 242
 243 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
 244 -- One item for each enclosing implication
 245 getUserGivens (CEC {cec_encl = ctxt})
 246   = reverse $
 247     [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
 248                      , let givens' = get_user_givens givens
 249                      , not (null givens') ]
 250   where
 251     get_user_givens givens | opt_PprStyle_Debug = givens
 252                            | otherwise          = filterOut isSilentEvVar givens
 253        -- In user mode, don't show the "silent" givens, used for
 254        -- the "self" dictionary and silent superclass arguments for dfuns
 255
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261                 Implicit parameter errors
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 \begin{code}
 266 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 267 reportIPErrs ctxt ips orig
 268   = addErrorReport ctxt msg
 269   where
 270     givens = getUserGivens ctxt
 271     msg | null givens
 272         = addArising orig $
 273           sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 274               , nest 2 (pprTheta ips) ]
 275         | otherwise
 276         = couldNotDeduce givens (ips, orig)
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282                 Equality errors
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 288 -- The [PredType] are already tidied
 289 reportEqErrs ctxt eqs orig
 290   = do { orig' <- zonkTidyOrigin ctxt orig
 291        ; mapM_ (report_one orig') eqs }
 292   where
 293     report_one orig (EqPred ty1 ty2)
 294       = do { let extra = getWantedEqExtra orig ty1 ty2
 295                  ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
 296            ; reportEqErr ctxt' ty1 ty2 }
 297     report_one _ pred
 298       = pprPanic "reportEqErrs" (ppr pred)
 299
 300 getWantedEqExtra ::  CtOrigin -> TcType -> TcType -> SDoc
 301 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
 302                  ty1 ty2
 303   -- If the types in the error message are the same as the types we are unifying,
 304   -- don't add the extra expected/actual message
 305   | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
 306   | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
 307   | otherwise                                = mkExpectedActualMsg act exp
 308
 309 getWantedEqExtra orig _ _ = pprArising orig
 310
 311 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 312 -- ty1 and ty2 are already tidied
 313 reportEqErr ctxt ty1 ty2
 314   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 315   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 316
 317   | otherwise   -- Neither side is a type variable
 318                 -- Since the unsolved constraint is canonical,
 319                 -- it must therefore be of form (F tys ~ ty)
 320   = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
 321
 322
 323 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 324 -- tv1 and ty2 are already tidied
 325 reportTyVarEqErr ctxt tv1 ty2
 326   |  isSkolemTyVar tv1    -- ty2 won't be a meta-tyvar, or else the thing would
 327                           -- be oriented the other way round; see TcCanonical.reOrient
 328   || isSigTyVar tv1 && not (isTyVarTy ty2)
 329   = addErrorReport (addExtraInfo ctxt ty1 ty2)
 330                    (misMatchOrCND ctxt ty1 ty2)
 331
 332   -- So tv is a meta tyvar, and presumably it is
 333   -- an *untouchable* meta tyvar, else it'd have been unified
 334   | not (k2 `isSubKind` k1)      -- Kind error
 335   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 336
 337   -- Occurs check
 338   | tv1 `elemVarSet` tyVarsOfType ty2
 339   = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
 340                            (sep [ppr ty1, char '=', ppr ty2])
 341     in addErrorReport ctxt occCheckMsg
 342
 343   -- Check for skolem escape
 344   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 345   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 346         implic_loc = ic_loc implic
 347   , not (null esc_skols)
 348   = setCtLoc implic_loc $       -- Override the error message location from the
 349                                 -- place the equality arose to the implication site
 350     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 351        ; let msg = misMatchMsg ty1 ty2
 352              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
 353                              <+> pprQuotedList esc_skols
 354                            , ptext (sLit "would escape") <+>
 355                              if isSingleton esc_skols then ptext (sLit "its scope")
 356                                                       else ptext (sLit "their scope") ]
 357              extra1 = vcat [ nest 2 $ esc_doc
 358                            , sep [ (if isSingleton esc_skols
 359                                     then ptext (sLit "This (rigid, skolem) type variable is")
 360                                     else ptext (sLit "These (rigid, skolem) type variables are"))
 361                                    <+> ptext (sLit "bound by")
 362                                  , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
 363        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 364
 365   -- Nastiest case: attempt to unify an untouchable variable
 366   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 367   , let implic_loc = ic_loc implic
 368         given      = ic_given implic
 369   = setCtLoc (ic_loc implic) $
 370     do { let msg = misMatchMsg ty1 ty2
 371              extra = quotes (ppr tv1)
 372                  <+> sep [ ptext (sLit "is untouchable")
 373                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 374                          , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
 375        ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
 376
 377   | otherwise
 378   = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
 379     return ()
 380         -- I don't think this should happen, and if it does I want to know
 381         -- Trac #5130 happened because an actual type error was not
 382         -- reported at all!  So not reporting is pretty dangerous.
 383         --
 384         -- OLD, OUT OF DATE COMMENT
 385         -- This can happen, by a recursive decomposition of frozen
 386         -- occurs check constraints
 387         -- Example: alpha ~ T Int alpha has frozen.
 388         --          Then alpha gets unified to T beta gamma
 389         -- So now we have  T beta gamma ~ T Int (T beta gamma)
 390         -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
 391         -- The (gamma ~ T beta gamma) is the occurs check, but
 392         -- the (beta ~ Int) isn't an error at all.  So return ()
 393   where
 394     k1  = tyVarKind tv1
 395     k2  = typeKind ty2
 396     ty1 = mkTyVarTy tv1
 397
 398 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 399 -- See Note [Non-injective type functions]
 400 mkTyFunInfoMsg ty1 ty2
 401   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 402   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 403   , tc1 == tc2, isSynFamilyTyCon tc1
 404   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 405     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 406   | otherwise = empty
 407   where
 408     pp_inj tc | isInjectiveTyCon tc = empty
 409               | otherwise = ptext (sLit (", and may not be injective"))
 410
 411 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
 412 misMatchOrCND ctxt ty1 ty2
 413   | cec_insol ctxt = misMatchMsg ty1 ty2    -- If the equality is unconditionally
 414                                             -- insoluble, don't report the context
 415   | null givens    = misMatchMsg ty1 ty2
 416   | otherwise      = couldNotDeduce givens ([EqPred ty1 ty2], orig)
 417   where
 418     givens = getUserGivens ctxt
 419     orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)
 420
 421 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
 422 couldNotDeduce givens (wanteds, orig)
 423   = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
 424               2 (pprArising orig)
 425          , vcat (pp_givens givens)]
 426
 427 pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
 428 pp_givens givens
 429    = case givens of
 430          []     -> []
 431          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
 432                  : map (ppr_given (ptext (sLit "or from"))) gs
 433     where ppr_given herald (gs,loc)
 434            = hang (herald <+> pprEvVarTheta gs)
 435                 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
 436                        , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
 437
 438 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 439 -- Add on extra info about the types themselves
 440 -- NB: The types themselves are already tidied
 441 addExtraInfo ctxt ty1 ty2
 442   = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
 443   where
 444     extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
 445     extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
 446
 447 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 448 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 449                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 450
 451 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 452 kindErrorMsg ty1 ty2
 453   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 454          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 455                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 456   where
 457     k1 = typeKind ty1
 458     k2 = typeKind ty2
 459
 460 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
 461 -- Shows a bit of extra info about skolem constants
 462 typeExtraInfoMsg implics ty
 463   | Just tv <- tcGetTyVar_maybe ty
 464   , isTcTyVar tv, isSkolemTyVar tv
 465   , let pp_tv = quotes (ppr tv)
 466  = case tcTyVarDetails tv of
 467     SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
 468     FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
 469     RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
 470     MetaTv {}     -> empty
 471
 472  | otherwise             -- Normal case
 473  = empty
 474
 475  where
 476    ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
 477    ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
 478                                sep [ppr info, ptext (sLit "at") <+> ppr loc]]
 479
 480 --------------------
 481 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 482 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 483   = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
 484         ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
 485         ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
 486
 487 mkExpectedActualMsg :: Type -> Type -> SDoc
 488 mkExpectedActualMsg act_ty exp_ty
 489   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 490          , text "  Actual type" <> colon <+> ppr act_ty ]
 491 \end{code}
 492
 493 Note [Non-injective type functions]
 494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 495 It's very confusing to get a message like
 496      Couldn't match expected type `Depend s'
 497             against inferred type `Depend s1'
 498 so mkTyFunInfoMsg adds:
 499        NB: `Depend' is type function, and hence may not be injective
 500
 501 Warn of loopy local equalities that were dropped.
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506                  Type-class errors
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 512 reportDictErrs ctxt wanteds orig
 513   = do { inst_envs <- tcGetInstEnvs
 514        ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
 515        ; unless (null non_overlaps) $
 516          addErrorReport ctxt (mk_no_inst_err non_overlaps) }
 517   where
 518     mk_no_inst_err :: [PredType] -> SDoc
 519     mk_no_inst_err wanteds
 520       | null givens     -- Top level
 521       = vcat [ addArising orig $
 522                ptext (sLit "No instance") <> plural min_wanteds
 523                     <+> ptext (sLit "for") <+> pprTheta min_wanteds
 524              , show_fixes (fixes2 ++ fixes3) ]
 525
 526       | otherwise
 527       = vcat [ couldNotDeduce givens (min_wanteds, orig)
 528              , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
 529       where
 530         givens = getUserGivens ctxt
 531         min_wanteds = mkMinimalBySCs wanteds
 532         fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
 533                           <+> ptext (sLit "to the context of")
 534                    , nest 2 $ pprErrCtxtLoc ctxt ]
 535
 536         fixes2 = case instance_dicts of
 537                    []  -> []
 538                    [_] -> [sep [ptext (sLit "add an instance declaration for"),
 539                                 pprTheta instance_dicts]]
 540                    _   -> [sep [ptext (sLit "add instance declarations for"),
 541                                 pprTheta instance_dicts]]
 542         fixes3 = case orig of
 543                    DerivOrigin -> [drv_fix]
 544                    _           -> []
 545
 546         instance_dicts = filterOut isTyVarClassPred min_wanteds
 547                 -- Insts for which it is worth suggesting an adding an
 548                 -- instance declaration.  Exclude tyvar dicts.
 549
 550         drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
 551                         nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 552
 553         show_fixes :: [SDoc] -> SDoc
 554         show_fixes []     = empty
 555         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 556                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 557
 558 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
 559               -> PredType -> TcM (Maybe PredType)
 560 -- Report an overlap error if this class constraint results
 561 -- from an overlap (returning Nothing), otherwise return (Just pred)
 562 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 563   = do { tys_flat <- mapM quickFlattenTy tys
 564            -- Note [Flattening in error message generation]
 565
 566        ; case lookupInstEnv inst_envs clas tys_flat of
 567                 ([], _) -> return (Just pred)               -- No match
 568                 -- The case of exactly one match and no unifiers means a
 569                 -- successful lookup.  That can't happen here, because dicts
 570                 -- only end up here if they didn't match in Inst.lookupInst
 571                 ([_],[])
 572                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 573                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
 574                                    ; return Nothing } }
 575   where
 576     mk_overlap_msg (matches, unifiers)
 577       = ASSERT( not (null matches) )
 578         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 579                                 <+> pprPred pred)
 580              ,  sep [ptext (sLit "Matching instances") <> colon,
 581                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 582
 583              ,  if not (null overlapping_givens) then
 584                   sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
 585                 else empty
 586
 587              ,  if null overlapping_givens && isSingleton matches && null unifiers then
 588                 -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
 589                 -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
 590                 -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
 591                   sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
 592                 else empty
 593
 594              ,  if not (isSingleton matches)
 595                 then    -- Two or more matches
 596                      empty
 597                 else    -- One match, plus some unifiers
 598                 ASSERT( not (null unifiers) )
 599                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 600                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 601                               if null (overlapping_givens) then
 602                                    vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 603                                           ptext (sLit "when compiling the other instance declarations")]
 604                               else empty])]
 605       where
 606         ispecs = [ispec | (ispec, _) <- matches]
 607
 608         givens = getUserGivens ctxt
 609         overlapping_givens = unifiable_givens givens
 610
 611         unifiable_givens [] = []
 612         unifiable_givens (gg:ggs)
 613           | Just ggdoc <- matchable gg
 614           = ggdoc : unifiable_givens ggs
 615           | otherwise
 616           = unifiable_givens ggs
 617
 618         matchable (evvars,gloc)
 619           = case ev_vars_matching of
 620                  [] -> Nothing
 621                  _  -> Just $ hang (pprTheta ev_vars_matching)
 622                                 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
 623                                        , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
 624             where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
 625                   ev_var_matches (ClassP clas' tys')
 626                     | clas' == clas
 627                     , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
 628                     = True
 629                   ev_var_matches (ClassP clas' tys') =
 630                     any ev_var_matches (immSuperClasses clas' tys')
 631                   ev_var_matches _ = False
 632
 633
 634 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 635
 636 ----------------------
 637 quickFlattenTy :: TcType -> TcM TcType
 638 -- See Note [Flattening in error message generation]
 639 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
 640 quickFlattenTy ty@(TyVarTy {})  = return ty
 641 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
 642 quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
 643   -- Don't flatten because of the danger or removing a bound variable
 644 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 645                                     ; fy2 <- quickFlattenTy ty2
 646                                     ; return (AppTy fy1 fy2) }
 647 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 648                                     ; fy2 <- quickFlattenTy ty2
 649                                     ; return (FunTy fy1 fy2) }
 650 quickFlattenTy (TyConApp tc tys)
 651     | not (isSynFamilyTyCon tc)
 652     = do { fys <- mapM quickFlattenTy tys
 653          ; return (TyConApp tc fys) }
 654     | otherwise
 655     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
 656                 -- Ignore the arguments of the type family funtys
 657          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
 658          ; flat_resttys <- mapM quickFlattenTy resttys
 659          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 660 \end{code}
 661
 662 Note [Flattening in error message generation]
 663 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 664 Consider (C (Maybe (F x))), where F is a type function, and we have
 665 instances
 666                 C (Maybe Int) and C (Maybe a)
 667 Since (F x) might turn into Int, this is an overlap situation, and
 668 indeed (because of flattening) the main solver will have refrained
 669 from solving.  But by the time we get to error message generation, we've
 670 un-flattened the constraint.  So we must *re*-flatten it before looking
 671 up in the instance environment, lest we only report one matching
 672 instance when in fact there are two.
 673
 674 Re-flattening is pretty easy, because we don't need to keep track of
 675 evidence.  We don't re-use the code in TcCanonical because that's in
 676 the TcS monad, and we are in TcM here.
 677
 678 Note [Quick-flatten polytypes]
 679 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 680 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
 681 flattening any further.  After all, there can be no instance declarations
 682 that match such things.  And flattening under a for-all is problematic
 683 anyway; consider C (forall a. F a)
 684
 685 \begin{code}
 686 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 687 reportAmbigErrs ctxt skols ambigs
 688 -- Divide into groups that share a common set of ambiguous tyvars
 689   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 690   where
 691     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
 692                    | d <- ambigs ]
 693     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 694
 695     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 696     report pairs
 697        = setCtLoc loc $
 698          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 699                                    <+> pprQuotedList tvs
 700                                    <+> text "in the constraint" <> plural pairs <> colon
 701                                  , nest 2 pp_wanteds ]
 702              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 703             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 704        where
 705          (_, tvs) : _ = pairs
 706          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 707
 708 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 709 -- There's an error with these Insts; if they have free type variables
 710 -- it's probably caused by the monomorphism restriction.
 711 -- Try to identify the offending variable
 712 -- ASSUMPTION: the Insts are fully zonked
 713 mkMonomorphismMsg ctxt inst_tvs
 714   = do  { dflags <- getDOpts
 715         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 716         ; return (tidy_env, mk_msg dflags docs) }
 717   where
 718     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 719         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 720                    (pprWithCommas ppr inst_tvs),
 721                 ptext (sLit "Use :print or :force to determine these types")]
 722     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 723                         -- This happens in things like
 724                         --      f x = show (read "foo")
 725                         -- where monomorphism doesn't play any role
 726     mk_msg dflags docs
 727         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 728                 nest 2 (vcat docs),
 729                 monomorphism_fix dflags]
 730
 731 monomorphism_fix :: DynFlags -> SDoc
 732 monomorphism_fix dflags
 733   = ptext (sLit "Probable fix:") <+> vcat
 734         [ptext (sLit "give these definition(s) an explicit type signature"),
 735          if xopt Opt_MonomorphismRestriction dflags
 736            then ptext (sLit "or use -XNoMonomorphismRestriction")
 737            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 738                         -- if it is not already set!
 739
 740 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
 741 getSkolemInfo [] tv
 742   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
 743     UnkSkol
 744 getSkolemInfo (implic:implics) tv
 745   | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
 746   | otherwise                       = getSkolemInfo implics tv
 747
 748 -----------------------
 749 -- findGlobals looks at the value environment and finds values whose
 750 -- types mention any of the offending type variables.  It has to be
 751 -- careful to zonk the Id's type first, so it has to be in the monad.
 752 -- We must be careful to pass it a zonked type variable, too.
 753
 754 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 755 mkEnvSigMsg what env_sigs
 756  | null env_sigs = empty
 757  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 758                     , nest 2 (vcat env_sigs) ]
 759
 760 findGlobals :: ReportErrCtxt
 761             -> TcTyVarSet
 762             -> TcM (TidyEnv, [SDoc])
 763
 764 findGlobals ctxt tvs
 765   = do { lcl_ty_env <- case cec_encl ctxt of
 766                         []    -> getLclTypeEnv
 767                         (i:_) -> return (ic_env i)
 768        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 769   where
 770     go tidy_env acc [] = return (tidy_env, acc)
 771     go tidy_env acc (thing : things) = do
 772         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 773         case maybe_doc of
 774           Just d  -> go tidy_env1 (d:acc) things
 775           Nothing -> go tidy_env1 acc     things
 776
 777     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 778
 779 -----------------------
 780 find_thing :: TidyEnv -> (TcType -> Bool)
 781            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 782 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 783   = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
 784        ; if ignore_it tidy_ty then
 785            return (tidy_env, Nothing)
 786          else do
 787        { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 788                        , nest 2 (parens (ptext (sLit "bound at") <+>
 789                                    ppr (getSrcLoc id)))]
 790        ; return (tidy_env', Just msg) } }
 791
 792 find_thing tidy_env ignore_it (ATyVar tv ty)
 793   = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
 794        ; if ignore_it tidy_ty then
 795             return (tidy_env, Nothing)
 796          else do
 797        { let -- The name tv is scoped, so we don't need to tidy it
 798             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 799                       , nest 2 bound_at]
 800
 801             eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
 802                      , getOccName tv == getOccName tv' = empty
 803                      | otherwise = equals <+> ppr tidy_ty
 804                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 805             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 806
 807        ; return (tidy_env1, Just msg) } }
 808
 809 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 810
 811 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
 812 warnDefaulting wanteds default_ty
 813   = do { warn_default <- doptM Opt_WarnTypeDefaults
 814        ; env0 <- tcInitTidyEnv
 815        ; let wanted_bag = listToBag wanteds
 816              tidy_env = tidyFreeTyVars env0 $
 817                         tyVarsOfEvVarXs wanted_bag
 818              tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
 819              (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
 820              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
 821                                 <+> quotes (ppr default_ty))
 822                             2 ppr_wanteds
 823        ; setCtLoc loc $ warnTc warn_default warn_msg }
 824   where
 825     get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc    -- Yuk
 826     get_wev ev = pprPanic "warnDefaulting" (ppr ev)
 827 \end{code}
 828
 829 Note [Runtime skolems]
 830 ~~~~~~~~~~~~~~~~~~~~~~
 831 We want to give a reasonably helpful error message for ambiguity
 832 arising from *runtime* skolems in the debugger.  These
 833 are created by in RtClosureInspect.zonkRTTIType.
 834
 835 %************************************************************************
 836 %*                                                                      *
 837                  Error from the canonicaliser
 838          These ones are called *during* constraint simplification
 839 %*                                                                      *
 840 %************************************************************************
 841
 842 \begin{code}
 843 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 844 solverDepthErrorTcS depth stack
 845   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 846   = wrapErrTcS $ failWith msg
 847   | otherwise
 848   = wrapErrTcS $
 849     setCtFlavorLoc (cc_flavor top_item) $
 850     do { ev_vars <- mapM (zonkEvVar . cc_id) stack
 851        ; env0 <- tcInitTidyEnv
 852        ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
 853              tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
 854        ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
 855   where
 856     top_item = head stack
 857     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 858                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 859
 860 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 861 flattenForAllErrorTcS fl ty _bad_eqs
 862   = wrapErrTcS        $
 863     setCtFlavorLoc fl $
 864     do { env0 <- tcInitTidyEnv
 865        ; let (env1, ty') = tidyOpenType env0 ty
 866              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 867                        , ppr ty' ]
 868        ; failWithTcM (env1, msg) }
 869 \end{code}
 870
 871 %************************************************************************
 872 %*                                                                      *
 873                  Setting the context
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 879 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 880 setCtFlavorLoc (Derived loc)   thing = setCtLoc loc thing
 881 setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
 882 \end{code}
 883
 884 %************************************************************************
 885 %*                                                                      *
 886                  Tidying
 887 %*                                                                      *
 888 %************************************************************************
 889
 890 \begin{code}
 891 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
 892 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
 893                            ; return (tidyOpenType env ty') }
 894
 895 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
 896 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
 897   = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
 898        ; (_env2, exp') <- zonkTidyTcType env1            exp
 899        ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
 900        -- Drop the returned env on the floor; we may conceivably thereby get
 901        -- inconsistent naming between uses of this function
 902 zonkTidyOrigin _ orig = return orig
 903 \end{code}