compiler/typecheck/TcErrors.lhs

   1 \begin{code}
   2 module TcErrors(
   3        reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
   4        reportUnsolvedWantedEvVars, warnDefaulting,
   5        unifyCtxt, typeExtraInfoMsg,
   6        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
   7        occursCheckErrorTcS, solverDepthErrorTcS
   8   ) where
   9
  10 #include "HsVersions.h"
  11
  12 import TcRnMonad
  13 import TcMType
  14 import TcSMonad
  15 import TcType
  16 import Inst
  17 import InstEnv
  18
  19 import TyCon
  20 import Name
  21 import NameEnv
  22 import Id       ( idType )
  23 import HsExpr   ( pprMatchContext )
  24 import Var
  25 import VarSet
  26 import VarEnv
  27 import SrcLoc
  28 import Bag
  29 import ListSetOps( equivClasses )
  30 import Util
  31 import Unique
  32 import FastString
  33 import Outputable
  34 import DynFlags
  35 import StaticFlags( opt_PprStyle_Debug )
  36 import Data.List( partition )
  37 import Control.Monad( unless )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \section{Errors and contexts}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 ToDo: for these error messages, should we note the location as coming
  47 from the insts, or just whatever seems to be around in the monad just
  48 now?
  49
  50 \begin{code}
  51 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
  52 reportUnsolved (unsolved_flats, unsolved_implics)
  53   | isEmptyBag unsolved
  54   = return ()
  55   | otherwise
  56   = do { env0 <- tcInitTidyEnv
  57        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
  58              tidy_unsolved = tidyWanteds tidy_env unsolved
  59              err_ctxt = CEC { cec_encl = []
  60                             , cec_extra = empty
  61                             , cec_tidy = tidy_env }
  62        ; traceTc "reportUnsolved" (ppr unsolved)
  63        ; reportTidyWanteds err_ctxt tidy_unsolved }
  64   where
  65     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
  66
  67 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
  68 reportUnsolvedWantedEvVars wanteds
  69   | isEmptyBag wanteds
  70   = return ()
  71   | otherwise
  72   = do { env0 <- tcInitTidyEnv
  73        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
  74              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
  75              err_ctxt = CEC { cec_encl  = []
  76                             , cec_extra = empty
  77                             , cec_tidy  = tidy_env }
  78        ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
  79
  80 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
  81 reportUnsolvedDeriv unsolved loc
  82   | null unsolved
  83   = return ()
  84   | otherwise
  85   = setCtLoc loc $
  86     do { env0 <- tcInitTidyEnv
  87        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
  88              tidy_unsolved = map (tidyPred tidy_env) unsolved
  89              err_ctxt = CEC { cec_encl  = []
  90                             , cec_extra = alt_fix
  91                             , cec_tidy  = tidy_env }
  92        ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
  93   where
  94     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
  95                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
  96
  97 reportUnsolvedImplication :: Implication -> TcM ()
  98 reportUnsolvedImplication implic
  99   = do { env0 <- tcInitTidyEnv
 100        ; let tidy_env    = tidyFreeTyVars env0 (tyVarsOfImplication implic)
 101              tidy_implic = tidyImplication tidy_env implic
 102              new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
 103              err_ctxt = CEC { cec_encl = [tidy_implic]
 104                             , cec_extra = empty
 105                             , cec_tidy = new_tidy_env }
 106        ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
 107   where
 108     -- Extend the tidy env with a mapping from tyvars to the
 109     -- names the user originally used.  At the moment we do this
 110     -- from the type env, but it might be better to record the
 111     -- scoped type variable in the Implication.  Urgh.
 112     add (ATyVar name ty) (occ_env, var_env)
 113        | Just tv <- tcGetTyVar_maybe ty
 114        , not (getUnique name `elemVarEnvByKey` var_env)
 115        = case tidyOccName occ_env (nameOccName name) of
 116             (occ_env', occ') ->  (occ_env', extendVarEnv var_env tv tv')
 117                 where
 118                   tv'   = setTyVarName tv name'
 119                   name' = tidyNameOcc name occ'
 120     add _ tidy_env = tidy_env
 121
 122 data ReportErrCtxt
 123     = CEC { cec_encl :: [Implication]  -- Enclosing implications
 124                                        --   (innermost first)
 125           , cec_tidy :: TidyEnv
 126           , cec_extra :: SDoc          -- Add this to each error message
 127       }
 128
 129 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
 130 reportTidyImplic ctxt implic
 131   = reportTidyWanteds ctxt' (ic_wanted implic)
 132   where
 133     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
 134
 135 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 136 reportTidyWanteds ctxt unsolved
 137   = do { let (flats, implics) = splitWanteds unsolved
 138              (ambigs, others) = partition is_ambiguous (bagToList flats)
 139        ; groupErrs (reportFlat ctxt) others
 140        ; mapBagM_ (reportTidyImplic ctxt) implics
 141        ; ifErrsM (return ()) $
 142            -- Only report ambiguity if no other errors happened
 143            -- See Note [Avoiding spurious errors]
 144          reportAmbigErrs ctxt skols ambigs }
 145   where
 146     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 147
 148         -- Treat it as "ambiguous" if
 149         --   (a) it is a class constraint
 150         --   (b) it constrains only type variables
 151         --       (else we'd prefer to report it as "no instance for...")
 152         --   (c) it mentions type variables that are not skolems
 153     is_ambiguous d = isTyVarClassPred pred
 154                   && not (tyVarsOfPred pred `subVarSet` skols)
 155                   where
 156                      pred = wantedEvVarPred d
 157
 158 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 159 reportFlat ctxt flats origin
 160   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
 161        ; unless (null eqs)   $ reportEqErrs   ctxt eqs
 162        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
 163        ; ASSERT( null others ) return () }
 164   where
 165     (dicts, non_dicts) = partition isClassPred flats
 166     (eqs, non_eqs)     = partition isEqPred    non_dicts
 167     (ips, others)      = partition isIPPred    non_eqs
 168
 169 --------------------------------------------
 170 --      Support code
 171 --------------------------------------------
 172
 173 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 174           -> [WantedEvVar]                      -- Unsolved wanteds
 175           -> TcM ()
 176 -- Group together insts with the same origin
 177 -- We want to report them together in error messages
 178
 179 groupErrs _ []
 180   = return ()
 181 groupErrs report_err (wanted : wanteds)
 182   = do  { setCtLoc the_loc $
 183           report_err the_vars (ctLocOrigin the_loc)
 184         ; groupErrs report_err others }
 185   where
 186    the_loc           = wantedEvVarLoc wanted
 187    the_key           = mk_key the_loc
 188    the_vars          = map wantedEvVarPred (wanted:friends)
 189    (friends, others) = partition is_friend wanteds
 190    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
 191
 192    mk_key :: WantedLoc -> (SrcSpan, String)
 193    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
 194         -- It may seem crude to compare the error messages,
 195         -- but it makes sure that we combine just what the user sees,
 196         -- and it avoids need equality on InstLocs.
 197
 198 -- Add the "arising from..." part to a message about bunch of dicts
 199 addArising :: CtOrigin -> SDoc -> SDoc
 200 addArising orig msg = msg $$ nest 2 (pprArising orig)
 201
 202 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 203 -- Print something like
 204 --    (Eq a) arising from a use of x at y
 205 --    (Show a) arising froma use of p at q
 206 -- Also return a location for the erroe message
 207 pprWithArising []
 208   = panic "pprWithArising"
 209 pprWithArising [WantedEvVar ev loc]
 210   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 211 pprWithArising ev_vars
 212   = (first_loc, vcat (map ppr_one ev_vars))
 213   where
 214     first_loc = wantedEvVarLoc (head ev_vars)
 215     ppr_one (WantedEvVar v loc)
 216        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 217
 218 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 219 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 220
 221 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 222 pprErrCtxtLoc ctxt
 223   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 224        []           -> ptext (sLit "the top level")     -- Should not happen
 225        (orig:origs) -> ppr_skol orig $$
 226                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 227   where
 228     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 229     ppr_skol skol_info      = pprSkolInfo skol_info
 230
 231 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 232 couldNotDeduce givens wanteds
 233   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 234         , nest 2 $ ptext (sLit "from the context")
 235                      <+> pprEvVarTheta givens]
 236
 237 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
 238 -- Just gs => Say "could not deduce ... from gs"
 239 -- Nothing => No interesting givens, say something else
 240 getUserGivens (CEC {cec_encl = ctxt})
 241   | null user_givens = Nothing
 242   | otherwise        = Just user_givens
 243   where
 244     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
 245     user_givens | opt_PprStyle_Debug = givens
 246                 | otherwise          = filterOut isSelfDict givens
 247        -- In user mode, don't show the "self-dict" given
 248        -- which is only added to do co-inductive solving
 249        -- Rather an awkward hack, but there we are
 250        -- This is the only use of isSelfDict, so it's not in an inner loop
 251 \end{code}
 252
 253
 254 %************************************************************************
 255 %*                                                                      *
 256                 Implicit parameter errors
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 \begin{code}
 261 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 262 reportIPErrs ctxt ips orig
 263   = addErrorReport ctxt $ addArising orig msg
 264   where
 265     msg | Just givens <- getUserGivens ctxt
 266         = couldNotDeduce givens ips
 267         | otherwise
 268         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 269               , nest 2 (pprTheta ips) ]
 270 \end{code}
 271
 272
 273 %************************************************************************
 274 %*                                                                      *
 275                 Equality errors
 276 %*                                                                      *
 277 %************************************************************************
 278
 279 \begin{code}
 280 reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM ()
 281 reportEqErrs ctxt eqs
 282   = mapM_ report_one eqs
 283   where
 284     report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2
 285     report_one pred             = pprPanic "reportEqErrs" (ppr pred)
 286
 287 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 288 reportEqErr ctxt ty1 ty2
 289   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 290   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 291   | otherwise   -- Neither side is a type variable
 292                 -- Since the unsolved constraint is canonical,
 293                 -- it must therefore be of form (F tys ~ ty)
 294   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
 295   where
 296     msg = case getUserGivens ctxt of
 297             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 298             Nothing     -> misMatchMsg ty1 ty2
 299
 300 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 301 reportTyVarEqErr ctxt tv1 ty2
 302   | not is_meta1
 303   , Just tv2 <- tcGetTyVar_maybe ty2
 304   , isMetaTyVar tv2
 305   = -- sk ~ alpha: swap
 306     reportTyVarEqErr ctxt tv2 ty1
 307
 308   | not is_meta1
 309   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 310     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 311
 312   -- So tv is a meta tyvar, and presumably it is
 313   -- an *untouchable* meta tyvar, else it'd have been unified
 314   | not (k2 `isSubKind` k1)      -- Kind error
 315   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 316
 317   -- Check for skolem escape
 318   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 319   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 320         implic_loc = ic_loc implic
 321   , not (null esc_skols)
 322   = setCtLoc implic_loc $       -- Override the error message location from the
 323                                 -- place the equality arose to the implication site
 324     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 325        ; let msg = misMatchMsg ty1 ty2
 326              esc_doc | isSingleton esc_skols
 327                      = ptext (sLit "because this skolem type variable would escape:")
 328                      | otherwise
 329                      = ptext (sLit "because these skolem type variables would escape:")
 330              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 331                            , sep [ (if isSingleton esc_skols
 332                                       then ptext (sLit "This skolem is")
 333                                       else ptext (sLit "These skolems are"))
 334                                    <+> ptext (sLit "bound by")
 335                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 336        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 337
 338   -- Nastiest case: attempt to unify an untouchable variable
 339   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 340   , let implic_loc = ic_loc implic
 341         given      = ic_given implic
 342   = setCtLoc (ic_loc implic) $
 343     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
 344              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
 345                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 346                           , nest 2 (ptext (sLit "bound at")
 347                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
 348        ; addErrTcM (env1, msg $$ extra) }
 349
 350   | otherwise      -- I'm not sure how this can happen!
 351   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 352   where
 353     is_meta1 = isMetaTyVar tv1
 354     k1       = tyVarKind tv1
 355     k2       = typeKind ty2
 356     ty1      = mkTyVarTy tv1
 357
 358 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 359 -- See Note [Non-injective type functions]
 360 mkTyFunInfoMsg ty1 ty2
 361   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 362   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 363   , tc1 == tc2, isSynFamilyTyCon tc1
 364   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 365     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 366   | otherwise = empty
 367   where
 368     pp_inj tc | isInjectiveTyCon tc = empty
 369               | otherwise = ptext (sLit (", and may not be injective"))
 370
 371 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
 372 -- This version is used by TcSimplify too, which doesn't track the
 373 -- expected/acutal thing, so we just have ty1 ty2 here
 374 -- NB: The types are already tidied
 375 misMatchMsgWithExtras env ty1 ty2
 376   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
 377   where
 378     (env1, extra1) = typeExtraInfoMsg env ty1
 379     (env2, extra2) = typeExtraInfoMsg env1 ty2
 380
 381 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 382 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 383                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 384
 385 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 386 kindErrorMsg ty1 ty2
 387   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 388          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 389                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 390   where
 391     k1 = typeKind ty1
 392     k2 = typeKind ty2
 393
 394 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 395 -- Shows a bit of extra info about skolem constants
 396 typeExtraInfoMsg env ty
 397   | Just tv <- tcGetTyVar_maybe ty
 398   , isTcTyVar tv
 399   , isSkolemTyVar tv || isSigTyVar tv
 400   , not (isUnk tv)
 401   , let (env1, tv1) = tidySkolemTyVar env tv
 402   = (env1, pprSkolTvBinding tv1)
 403   where
 404 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 405
 406 --------------------
 407 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 408 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 409   = do  { act_ty' <- zonkTcType act_ty
 410         ; exp_ty' <- zonkTcType exp_ty
 411         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 412               (env2, act_ty'') = tidyOpenType env1     act_ty'
 413         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 414
 415 mkExpectedActualMsg :: Type -> Type -> SDoc
 416 mkExpectedActualMsg act_ty exp_ty
 417   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 418          , text "  Actual type" <> colon <+> ppr act_ty ]
 419 \end{code}
 420
 421 Note [Non-injective type functions]
 422 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 423 It's very confusing to get a message like
 424      Couldn't match expected type `Depend s'
 425             against inferred type `Depend s1'
 426 so mkTyFunInfoMsg adds:
 427        NB: `Depend' is type function, and hence may not be injective
 428
 429 Warn of loopy local equalities that were dropped.
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434                  Type-class errors
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 440 reportDictErrs ctxt wanteds orig
 441   = do { inst_envs <- tcGetInstEnvs
 442        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
 443        ; unless (null others) $
 444          addErrorReport ctxt (mk_no_inst_err others)
 445        ; mapM_ (addErrorReport ctxt) overlaps }
 446   where
 447     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
 448         -- Right msg  => overlap message
 449         -- Left  inst => no instance
 450     check_overlap inst_envs pred@(ClassP clas tys)
 451         = case lookupInstEnv inst_envs clas tys of
 452                 ([], _) -> Left pred            -- No match
 453                 -- The case of exactly one match and no unifiers means a
 454                 -- successful lookup.  That can't happen here, because dicts
 455                 -- only end up here if they didn't match in Inst.lookupInst
 456                 ([_],[])
 457                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 458                 res -> Right (mk_overlap_msg pred res)
 459     check_overlap _ _ = panic "check_overlap"
 460
 461     mk_overlap_msg pred (matches, unifiers)
 462       = ASSERT( not (null matches) )
 463         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 464                                 <+> pprPred pred)
 465              ,  sep [ptext (sLit "Matching instances") <> colon,
 466                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 467              ,  if not (isSingleton matches)
 468                 then    -- Two or more matches
 469                      empty
 470                 else    -- One match, plus some unifiers
 471                 ASSERT( not (null unifiers) )
 472                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 473                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 474                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 475                               ptext (sLit "when compiling the other instance declarations")])]
 476       where
 477         ispecs = [ispec | (ispec, _) <- matches]
 478
 479     mk_no_inst_err :: [PredType] -> SDoc
 480     mk_no_inst_err wanteds
 481       | Just givens <- getUserGivens ctxt
 482       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 483              , show_fixes (fix1 : fixes2) ]
 484
 485       | otherwise       -- Top level
 486       = vcat [ addArising orig $
 487                ptext (sLit "No instance") <> plural wanteds
 488                     <+> ptext (sLit "for") <+> pprTheta wanteds
 489              , show_fixes fixes2 ]
 490
 491       where
 492         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 493                           <+> ptext (sLit "to the context of")
 494                    , nest 2 $ pprErrCtxtLoc ctxt ]
 495
 496         fixes2 | null instance_dicts = []
 497                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 498                                         pprTheta instance_dicts]]
 499         instance_dicts = filterOut isTyVarClassPred wanteds
 500                 -- Insts for which it is worth suggesting an adding an
 501                 -- instance declaration.  Exclude tyvar dicts.
 502
 503         show_fixes :: [SDoc] -> SDoc
 504         show_fixes []     = empty
 505         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 506                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 507
 508 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 509 reportAmbigErrs ctxt skols ambigs
 510 -- Divide into groups that share a common set of ambiguous tyvars
 511   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 512   where
 513     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 514                    | d <- ambigs ]
 515     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 516
 517     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 518     report pairs
 519        = setCtLoc loc $
 520          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 521                                    <+> pprQuotedList tvs
 522                                    <+> text "in the constraint" <> plural pairs <> colon
 523                                  , nest 2 pp_wanteds ]
 524              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 525             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 526        where
 527          (_, tvs) : _ = pairs
 528          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 529
 530 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 531 -- There's an error with these Insts; if they have free type variables
 532 -- it's probably caused by the monomorphism restriction.
 533 -- Try to identify the offending variable
 534 -- ASSUMPTION: the Insts are fully zonked
 535 mkMonomorphismMsg ctxt inst_tvs
 536   = do  { dflags <- getDOpts
 537         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 538         ; return (tidy_env, mk_msg dflags docs) }
 539   where
 540     mk_msg _ _ | any isRuntimeUnk inst_tvs
 541         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 542                    (pprWithCommas ppr inst_tvs),
 543                 ptext (sLit "Use :print or :force to determine these types")]
 544     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 545                         -- This happens in things like
 546                         --      f x = show (read "foo")
 547                         -- where monomorphism doesn't play any role
 548     mk_msg dflags docs
 549         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 550                 nest 2 (vcat docs),
 551                 monomorphism_fix dflags]
 552
 553 monomorphism_fix :: DynFlags -> SDoc
 554 monomorphism_fix dflags
 555   = ptext (sLit "Probable fix:") <+> vcat
 556         [ptext (sLit "give these definition(s) an explicit type signature"),
 557          if dopt Opt_MonomorphismRestriction dflags
 558            then ptext (sLit "or use -XNoMonomorphismRestriction")
 559            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 560                         -- if it is not already set!
 561
 562
 563 -----------------------
 564 -- findGlobals looks at the value environment and finds values whose
 565 -- types mention any of the offending type variables.  It has to be
 566 -- careful to zonk the Id's type first, so it has to be in the monad.
 567 -- We must be careful to pass it a zonked type variable, too.
 568
 569 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 570 mkEnvSigMsg what env_sigs
 571  | null env_sigs = empty
 572  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 573                     , nest 2 (vcat env_sigs) ]
 574
 575 findGlobals :: ReportErrCtxt
 576             -> TcTyVarSet
 577             -> TcM (TidyEnv, [SDoc])
 578
 579 findGlobals ctxt tvs
 580   = do { lcl_ty_env <- case cec_encl ctxt of
 581                         []    -> getLclTypeEnv
 582                         (i:_) -> return (ic_env i)
 583        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 584   where
 585     go tidy_env acc [] = return (tidy_env, acc)
 586     go tidy_env acc (thing : things) = do
 587         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 588         case maybe_doc of
 589           Just d  -> go tidy_env1 (d:acc) things
 590           Nothing -> go tidy_env1 acc     things
 591
 592     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 593
 594 -----------------------
 595 find_thing :: TidyEnv -> (TcType -> Bool)
 596            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 597 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 598   = do { id_ty <- zonkTcType  (idType id)
 599        ; if ignore_it id_ty then
 600            return (tidy_env, Nothing)
 601          else do
 602        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 603              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 604                        , nest 2 (parens (ptext (sLit "bound at") <+>
 605                                    ppr (getSrcLoc id)))]
 606        ; return (tidy_env', Just msg) } }
 607
 608 find_thing tidy_env ignore_it (ATyVar tv ty)
 609   = do { tv_ty <- zonkTcType ty
 610        ; if ignore_it tv_ty then
 611             return (tidy_env, Nothing)
 612          else do
 613        { let -- The name tv is scoped, so we don't need to tidy it
 614             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 615             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 616                       , nest 2 bound_at]
 617
 618             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 619                      , getOccName tv == getOccName tv' = empty
 620                      | otherwise = equals <+> ppr tidy_ty
 621                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 622             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 623
 624        ; return (tidy_env1, Just msg) } }
 625
 626 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 627
 628 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 629 warnDefaulting wanteds default_ty
 630   = do { warn_default <- doptM Opt_WarnTypeDefaults
 631        ; setCtLoc loc $ warnTc warn_default warn_msg }
 632   where
 633         -- Tidy them first
 634     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 635                                 quotes (ppr default_ty),
 636                       nest 2 ppr_wanteds ]
 637     (loc, ppr_wanteds) = pprWithArising wanteds
 638 \end{code}
 639
 640 %************************************************************************
 641 %*                                                                      *
 642                  Error from the canonicaliser
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 \begin{code}
 647 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
 648 -- If there's a kind error, we don't want to blindly say "kind error"
 649 -- We might, say, be unifying a skolem 'a' with a type 'Int',
 650 -- in which case that's the error to report.  So we set things
 651 -- up to call reportEqErr, which does the business properly
 652 kindErrorTcS fl ty1 ty2
 653   = wrapErrTcS        $
 654     setCtFlavorLoc fl $
 655     do { env0 <- tcInitTidyEnv
 656        ; let (env1, ty1') = tidyOpenType env0 ty1
 657              (env2, ty2') = tidyOpenType env1 ty2
 658              ctxt = CEC { cec_encl = []
 659                         , cec_extra = empty
 660                         , cec_tidy = env2 }
 661        ; reportEqErr ctxt ty1' ty2' }
 662
 663 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 664 misMatchErrorTcS fl ty1 ty2
 665   = wrapErrTcS            $
 666     setCtFlavorLocNoEq fl $  -- Don't add the "When matching t1 with t2"
 667                              -- part, because it duplciates what we say now
 668     do { env0 <- tcInitTidyEnv
 669        ; let (env1, ty1') = tidyOpenType env0 ty1
 670              (env2, ty2') = tidyOpenType env1 ty2
 671              (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
 672        ; failWithTcM (env3, inaccessible_msg $$ msg) }
 673   where
 674     inaccessible_msg
 675       = case fl of
 676           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 677                           2 (mk_what loc)
 678           _         -> empty
 679     mk_what loc
 680       = case ctLocOrigin loc of
 681           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 682                                    <+> quotes (ppr dc) <> comma
 683                                , ptext (sLit "in") <+> pprMatchContext mc ]
 684           other_skol -> pprSkolInfo other_skol
 685
 686 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 687 occursCheckErrorTcS fl tv ty
 688   = wrapErrTcS           $
 689     setCtFlavorLoc fl $
 690     do  { env0          <- tcInitTidyEnv
 691         ; let (env1, tv') = tidyOpenTyVar env0 tv
 692               (env2, ty') = tidyOpenType env1 ty
 693               extra = sep [ppr tv', char '=', ppr ty']
 694         ; failWithTcM (env2, hang msg 2 extra) }
 695   where
 696     msg = text $ "Occurs check: cannot construct the infinite type:"
 697
 698 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 699 solverDepthErrorTcS depth stack
 700   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 701   = wrapErrTcS $ failWith msg
 702   | otherwise
 703   = wrapErrTcS $
 704     setCtFlavorLoc (cc_flavor top_item) $
 705     do { env0 <- tcInitTidyEnv
 706        ; let ev_vars  = map cc_id stack
 707              env1     = tidyFreeTyVars env0 free_tvs
 708              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 709              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 710        ; failWithTcM (env1, hang msg 2 extra) }
 711   where
 712     top_item = head stack
 713     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 714                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 715
 716 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 717 flattenForAllErrorTcS fl ty _bad_eqs
 718   = wrapErrTcS        $
 719     setCtFlavorLoc fl $
 720     do { env0 <- tcInitTidyEnv
 721        ; let (env1, ty') = tidyOpenType env0 ty
 722              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 723                        , ppr ty' ]
 724        ; failWithTcM (env1, msg) }
 725 \end{code}
 726
 727 %************************************************************************
 728 %*                                                                      *
 729                  Setting the context
 730 %*                                                                      *
 731 %************************************************************************
 732
 733 \begin{code}
 734 setCtFlavorLocNoEq :: CtFlavor -> TcM a -> TcM a
 735 setCtFlavorLocNoEq (Wanted  loc) thing = setCtLoc loc thing
 736 setCtFlavorLocNoEq (Derived loc) thing = setCtLoc loc thing
 737 setCtFlavorLocNoEq (Given   loc) thing = setCtLoc loc thing
 738
 739 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 740 setCtFlavorLoc (Wanted  loc) thing = setWantedLoc loc thing
 741 setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing
 742 setCtFlavorLoc (Given   loc) thing = setGivenLoc  loc thing
 743
 744 setWantedLoc :: WantedLoc -> TcM a -> TcM a
 745 setWantedLoc loc thing_inside
 746   = setCtLoc loc $
 747     add_origin (ctLocOrigin loc) $
 748     thing_inside
 749   where
 750     add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item)
 751     add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig)
 752
 753 setGivenLoc :: GivenLoc -> TcM a -> TcM a
 754 setGivenLoc loc thing_inside
 755   = setCtLoc loc $
 756     add_origin (ctLocOrigin loc) $
 757     thing_inside
 758   where
 759     add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol)
 760 \end{code}