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   origin
 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] -> CtOrigin -> TcM ()
 281 reportEqErrs ctxt eqs orig
 282   = mapM_ report_one eqs
 283   where
 284     env0 = cec_tidy ctxt
 285     report_one (EqPred ty1 ty2)
 286       = getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 $ \ env1 extra ->
 287         let ctxt' = ctxt { cec_tidy = env1
 288                          , cec_extra = cec_extra ctxt $$ extra }
 289         in reportEqErr ctxt' ty1 ty2
 290     report_one pred
 291       = pprPanic "reportEqErrs" (ppr pred)
 292
 293 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 294 reportEqErr ctxt ty1 ty2
 295   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 296   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 297   | otherwise   -- Neither side is a type variable
 298                 -- Since the unsolved constraint is canonical,
 299                 -- it must therefore be of form (F tys ~ ty)
 300   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
 301   where
 302     msg = case getUserGivens ctxt of
 303             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 304             Nothing     -> misMatchMsg ty1 ty2
 305
 306 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 307 reportTyVarEqErr ctxt tv1 ty2
 308   | not is_meta1
 309   , Just tv2 <- tcGetTyVar_maybe ty2
 310   , isMetaTyVar tv2
 311   = -- sk ~ alpha: swap
 312     reportTyVarEqErr ctxt tv2 ty1
 313
 314   | not is_meta1
 315   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 316     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 317
 318   -- So tv is a meta tyvar, and presumably it is
 319   -- an *untouchable* meta tyvar, else it'd have been unified
 320   | not (k2 `isSubKind` k1)      -- Kind error
 321   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 322
 323   -- Check for skolem escape
 324   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 325   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 326         implic_loc = ic_loc implic
 327   , not (null esc_skols)
 328   = setCtLoc implic_loc $       -- Override the error message location from the
 329                                 -- place the equality arose to the implication site
 330     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 331        ; let msg = misMatchMsg ty1 ty2
 332              esc_doc | isSingleton esc_skols
 333                      = ptext (sLit "because this skolem type variable would escape:")
 334                      | otherwise
 335                      = ptext (sLit "because these skolem type variables would escape:")
 336              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 337                            , sep [ (if isSingleton esc_skols
 338                                       then ptext (sLit "This skolem is")
 339                                       else ptext (sLit "These skolems are"))
 340                                    <+> ptext (sLit "bound by")
 341                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 342        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 343
 344   -- Nastiest case: attempt to unify an untouchable variable
 345   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 346   , let implic_loc = ic_loc implic
 347         given      = ic_given implic
 348   = setCtLoc (ic_loc implic) $
 349     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
 350              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
 351                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 352                           , nest 2 (ptext (sLit "bound at")
 353                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
 354        ; addErrTcM (env1, msg $$ extra) }
 355
 356   | otherwise      -- I'm not sure how this can happen!
 357   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 358   where
 359     is_meta1 = isMetaTyVar tv1
 360     k1       = tyVarKind tv1
 361     k2       = typeKind ty2
 362     ty1      = mkTyVarTy tv1
 363
 364 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 365 -- See Note [Non-injective type functions]
 366 mkTyFunInfoMsg ty1 ty2
 367   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 368   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 369   , tc1 == tc2, isSynFamilyTyCon tc1
 370   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 371     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 372   | otherwise = empty
 373   where
 374     pp_inj tc | isInjectiveTyCon tc = empty
 375               | otherwise = ptext (sLit (", and may not be injective"))
 376
 377 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
 378 -- This version is used by TcSimplify too, which doesn't track the
 379 -- expected/acutal thing, so we just have ty1 ty2 here
 380 -- NB: The types are already tidied
 381 misMatchMsgWithExtras env ty1 ty2
 382   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
 383   where
 384     (env1, extra1) = typeExtraInfoMsg env ty1
 385     (env2, extra2) = typeExtraInfoMsg env1 ty2
 386
 387 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 388 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 389                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 390
 391 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 392 kindErrorMsg ty1 ty2
 393   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 394          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 395                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 396   where
 397     k1 = typeKind ty1
 398     k2 = typeKind ty2
 399
 400 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 401 -- Shows a bit of extra info about skolem constants
 402 typeExtraInfoMsg env ty
 403   | Just tv <- tcGetTyVar_maybe ty
 404   , isTcTyVar tv
 405   , isSkolemTyVar tv || isSigTyVar tv
 406   , not (isUnk tv)
 407   , let (env1, tv1) = tidySkolemTyVar env tv
 408   = (env1, pprSkolTvBinding tv1)
 409   where
 410 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 411
 412 --------------------
 413 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 414 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 415   = do  { act_ty' <- zonkTcType act_ty
 416         ; exp_ty' <- zonkTcType exp_ty
 417         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 418               (env2, act_ty'') = tidyOpenType env1     act_ty'
 419         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 420
 421 mkExpectedActualMsg :: Type -> Type -> SDoc
 422 mkExpectedActualMsg act_ty exp_ty
 423   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 424          , text "  Actual type" <> colon <+> ppr act_ty ]
 425 \end{code}
 426
 427 Note [Non-injective type functions]
 428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 429 It's very confusing to get a message like
 430      Couldn't match expected type `Depend s'
 431             against inferred type `Depend s1'
 432 so mkTyFunInfoMsg adds:
 433        NB: `Depend' is type function, and hence may not be injective
 434
 435 Warn of loopy local equalities that were dropped.
 436
 437
 438 %************************************************************************
 439 %*                                                                      *
 440                  Type-class errors
 441 %*                                                                      *
 442 %************************************************************************
 443
 444 \begin{code}
 445 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 446 reportDictErrs ctxt wanteds orig
 447   = do { inst_envs <- tcGetInstEnvs
 448        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
 449        ; unless (null others) $
 450          addErrorReport ctxt (mk_no_inst_err others)
 451        ; mapM_ (addErrorReport ctxt) overlaps }
 452   where
 453     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
 454         -- Right msg  => overlap message
 455         -- Left  inst => no instance
 456     check_overlap inst_envs pred@(ClassP clas tys)
 457         = case lookupInstEnv inst_envs clas tys of
 458                 ([], _) -> Left pred            -- No match
 459                 -- The case of exactly one match and no unifiers means a
 460                 -- successful lookup.  That can't happen here, because dicts
 461                 -- only end up here if they didn't match in Inst.lookupInst
 462                 ([_],[])
 463                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 464                 res -> Right (mk_overlap_msg pred res)
 465     check_overlap _ _ = panic "check_overlap"
 466
 467     mk_overlap_msg pred (matches, unifiers)
 468       = ASSERT( not (null matches) )
 469         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 470                                 <+> pprPred pred)
 471              ,  sep [ptext (sLit "Matching instances") <> colon,
 472                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 473              ,  if not (isSingleton matches)
 474                 then    -- Two or more matches
 475                      empty
 476                 else    -- One match, plus some unifiers
 477                 ASSERT( not (null unifiers) )
 478                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 479                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 480                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 481                               ptext (sLit "when compiling the other instance declarations")])]
 482       where
 483         ispecs = [ispec | (ispec, _) <- matches]
 484
 485     mk_no_inst_err :: [PredType] -> SDoc
 486     mk_no_inst_err wanteds
 487       | Just givens <- getUserGivens ctxt
 488       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 489              , show_fixes (fix1 : fixes2) ]
 490
 491       | otherwise       -- Top level
 492       = vcat [ addArising orig $
 493                ptext (sLit "No instance") <> plural wanteds
 494                     <+> ptext (sLit "for") <+> pprTheta wanteds
 495              , show_fixes fixes2 ]
 496
 497       where
 498         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 499                           <+> ptext (sLit "to the context of")
 500                    , nest 2 $ pprErrCtxtLoc ctxt ]
 501
 502         fixes2 | null instance_dicts = []
 503                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 504                                         pprTheta instance_dicts]]
 505         instance_dicts = filterOut isTyVarClassPred wanteds
 506                 -- Insts for which it is worth suggesting an adding an
 507                 -- instance declaration.  Exclude tyvar dicts.
 508
 509         show_fixes :: [SDoc] -> SDoc
 510         show_fixes []     = empty
 511         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 512                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 513
 514 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 515 reportAmbigErrs ctxt skols ambigs
 516 -- Divide into groups that share a common set of ambiguous tyvars
 517   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 518   where
 519     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 520                    | d <- ambigs ]
 521     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 522
 523     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 524     report pairs
 525        = setCtLoc loc $
 526          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 527                                    <+> pprQuotedList tvs
 528                                    <+> text "in the constraint" <> plural pairs <> colon
 529                                  , nest 2 pp_wanteds ]
 530              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 531             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 532        where
 533          (_, tvs) : _ = pairs
 534          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 535
 536 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 537 -- There's an error with these Insts; if they have free type variables
 538 -- it's probably caused by the monomorphism restriction.
 539 -- Try to identify the offending variable
 540 -- ASSUMPTION: the Insts are fully zonked
 541 mkMonomorphismMsg ctxt inst_tvs
 542   = do  { dflags <- getDOpts
 543         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 544         ; return (tidy_env, mk_msg dflags docs) }
 545   where
 546     mk_msg _ _ | any isRuntimeUnk inst_tvs
 547         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 548                    (pprWithCommas ppr inst_tvs),
 549                 ptext (sLit "Use :print or :force to determine these types")]
 550     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 551                         -- This happens in things like
 552                         --      f x = show (read "foo")
 553                         -- where monomorphism doesn't play any role
 554     mk_msg dflags docs
 555         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 556                 nest 2 (vcat docs),
 557                 monomorphism_fix dflags]
 558
 559 monomorphism_fix :: DynFlags -> SDoc
 560 monomorphism_fix dflags
 561   = ptext (sLit "Probable fix:") <+> vcat
 562         [ptext (sLit "give these definition(s) an explicit type signature"),
 563          if xopt Opt_MonomorphismRestriction dflags
 564            then ptext (sLit "or use -XNoMonomorphismRestriction")
 565            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 566                         -- if it is not already set!
 567
 568
 569 -----------------------
 570 -- findGlobals looks at the value environment and finds values whose
 571 -- types mention any of the offending type variables.  It has to be
 572 -- careful to zonk the Id's type first, so it has to be in the monad.
 573 -- We must be careful to pass it a zonked type variable, too.
 574
 575 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 576 mkEnvSigMsg what env_sigs
 577  | null env_sigs = empty
 578  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 579                     , nest 2 (vcat env_sigs) ]
 580
 581 findGlobals :: ReportErrCtxt
 582             -> TcTyVarSet
 583             -> TcM (TidyEnv, [SDoc])
 584
 585 findGlobals ctxt tvs
 586   = do { lcl_ty_env <- case cec_encl ctxt of
 587                         []    -> getLclTypeEnv
 588                         (i:_) -> return (ic_env i)
 589        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 590   where
 591     go tidy_env acc [] = return (tidy_env, acc)
 592     go tidy_env acc (thing : things) = do
 593         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 594         case maybe_doc of
 595           Just d  -> go tidy_env1 (d:acc) things
 596           Nothing -> go tidy_env1 acc     things
 597
 598     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 599
 600 -----------------------
 601 find_thing :: TidyEnv -> (TcType -> Bool)
 602            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 603 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 604   = do { id_ty <- zonkTcType  (idType id)
 605        ; if ignore_it id_ty then
 606            return (tidy_env, Nothing)
 607          else do
 608        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 609              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 610                        , nest 2 (parens (ptext (sLit "bound at") <+>
 611                                    ppr (getSrcLoc id)))]
 612        ; return (tidy_env', Just msg) } }
 613
 614 find_thing tidy_env ignore_it (ATyVar tv ty)
 615   = do { tv_ty <- zonkTcType ty
 616        ; if ignore_it tv_ty then
 617             return (tidy_env, Nothing)
 618          else do
 619        { let -- The name tv is scoped, so we don't need to tidy it
 620             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 621             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 622                       , nest 2 bound_at]
 623
 624             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 625                      , getOccName tv == getOccName tv' = empty
 626                      | otherwise = equals <+> ppr tidy_ty
 627                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 628             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 629
 630        ; return (tidy_env1, Just msg) } }
 631
 632 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 633
 634 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 635 warnDefaulting wanteds default_ty
 636   = do { warn_default <- doptM Opt_WarnTypeDefaults
 637        ; setCtLoc loc $ warnTc warn_default warn_msg }
 638   where
 639         -- Tidy them first
 640     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 641                                 quotes (ppr default_ty),
 642                       nest 2 ppr_wanteds ]
 643     (loc, ppr_wanteds) = pprWithArising wanteds
 644 \end{code}
 645
 646 %************************************************************************
 647 %*                                                                      *
 648                  Error from the canonicaliser
 649 %*                                                                      *
 650 %************************************************************************
 651
 652 \begin{code}
 653 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
 654 -- If there's a kind error, we don't want to blindly say "kind error"
 655 -- We might, say, be unifying a skolem 'a' with a type 'Int',
 656 -- in which case that's the error to report.  So we set things
 657 -- up to call reportEqErr, which does the business properly
 658 kindErrorTcS fl ty1 ty2
 659   = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra ->
 660     do { let (env1, ty1') = tidyOpenType env0 ty1
 661              (env2, ty2') = tidyOpenType env1 ty2
 662              ctxt = CEC { cec_encl = []
 663                         , cec_extra = extra
 664                         , cec_tidy = env2 }
 665        ; reportEqErr ctxt ty1' ty2' }
 666
 667 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 668 misMatchErrorTcS fl ty1 ty2
 669   = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra ->
 670     do { let (env1, ty1') = tidyOpenType env0 ty1
 671              (env2, ty2') = tidyOpenType env1 ty2
 672              (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
 673        ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) }
 674   where
 675     inaccessible_msg
 676       = case fl of
 677           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 678                           2 (mk_what loc)
 679           _         -> empty
 680     mk_what loc
 681       = case ctLocOrigin loc of
 682           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 683                                    <+> quotes (ppr dc) <> comma
 684                                , ptext (sLit "in") <+> pprMatchContext mc ]
 685           other_skol -> pprSkolInfo other_skol
 686
 687 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 688 occursCheckErrorTcS fl tv ty
 689   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 extra2 ->
 690     do  { let (env1, tv') = tidyOpenTyVar env0 tv
 691               (env2, ty') = tidyOpenType env1 ty
 692               extra1 = sep [ppr tv', char '=', ppr ty']
 693         ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) }
 694   where
 695     msg = text $ "Occurs check: cannot construct the infinite type:"
 696
 697 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 698 solverDepthErrorTcS depth stack
 699   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 700   = wrapErrTcS $ failWith msg
 701   | otherwise
 702   = wrapErrTcS $
 703     setCtFlavorLoc (cc_flavor top_item) $
 704     do { env0 <- tcInitTidyEnv
 705        ; let ev_vars  = map cc_id stack
 706              env1     = tidyFreeTyVars env0 free_tvs
 707              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 708              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 709        ; failWithTcM (env1, hang msg 2 extra) }
 710   where
 711     top_item = head stack
 712     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 713                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 714
 715 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 716 flattenForAllErrorTcS fl ty _bad_eqs
 717   = wrapErrTcS        $
 718     setCtFlavorLoc fl $
 719     do { env0 <- tcInitTidyEnv
 720        ; let (env1, ty') = tidyOpenType env0 ty
 721              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 722                        , ppr ty' ]
 723        ; failWithTcM (env1, msg) }
 724 \end{code}
 725
 726 %************************************************************************
 727 %*                                                                      *
 728                  Setting the context
 729 %*                                                                      *
 730 %************************************************************************
 731
 732 \begin{code}
 733 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 734 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
 735 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 736 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 737
 738 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
 739              -> (TidyEnv -> SDoc -> TcM a)
 740              -> TcS a
 741 wrapEqErrTcS fl ty1 ty2 thing_inside
 742   = do { ty_binds_var <- getTcSTyBinds
 743        ; wrapErrTcS $ setCtFlavorLoc fl $
 744     do { env0 <- tcInitTidyEnv
 745        ; ty_binds_bag <- readTcRef ty_binds_var
 746        ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
 747        ; case fl of
 748            Wanted  loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
 749            Derived loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
 750            Given {}    -> thing_inside env0 empty  -- We could print more info, but it
 751                                                    -- seems to be coming out already
 752        } }
 753
 754 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 755                  -> (TidyEnv -> SDoc -> TcM a)
 756                  -> TcM a
 757 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2 thing_inside
 758   -- If the types in the error message are the same
 759   -- as the types we are unifying (remember to zonk the latter)
 760   -- don't add the extra expected/actual message
 761   --
 762   -- The complication is that the types in the TypeEqOrigin must
 763   --   (a) be zonked
 764   --   (b) have any TcS-monad pending equalities applied to them
 765   --            (hence the passed-in substitution)
 766   = do { act0 <- zonkTcType (uo_actual item)
 767        ; exp0 <- zonkTcType (uo_expected item)
 768        ; let act1 = substTy subst act0
 769              exp1 = substTy subst exp0
 770              (env1, exp2) = tidyOpenType env0 exp1
 771              (env2, act2) = tidyOpenType env1 act1
 772        ; if (act1 `tcEqType` ty1 && exp1 `tcEqType` ty2)
 773          || (exp1 `tcEqType` ty1 && act1 `tcEqType` ty2)
 774          then
 775             thing_inside env0 empty
 776          else
 777             thing_inside env2 (mkExpectedActualMsg act2 exp2) }
 778
 779 getWantedEqExtra _ env0 orig _ _ thing_inside
 780   = thing_inside env0 (pprArising orig)
 781 \end{code}