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