compiler/typecheck/TcErrors.lhs

   1 \begin{code}
   2 module TcErrors(
   3        reportUnsolved, 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 FastString
  32 import Outputable
  33 import DynFlags
  34 import StaticFlags( opt_PprStyle_Debug )
  35 import Data.List( partition )
  36 import Control.Monad( when, unless )
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \section{Errors and contexts}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 ToDo: for these error messages, should we note the location as coming
  46 from the insts, or just whatever seems to be around in the monad just
  47 now?
  48
  49 \begin{code}
  50 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
  51 reportUnsolved (unsolved_flats, unsolved_implics)
  52   | isEmptyBag unsolved
  53   = return ()
  54   | otherwise
  55   = do { unsolved <- mapBagM zonkWanted unsolved
  56                      -- Zonk to un-flatten any flatten-skols
  57        ; env0 <- tcInitTidyEnv
  58        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
  59              tidy_unsolved = tidyWanteds tidy_env unsolved
  60              err_ctxt = CEC { cec_encl = []
  61                             , cec_extra = empty
  62                             , cec_tidy = tidy_env }
  63        ; traceTc "reportUnsolved" (ppr unsolved)
  64        ; reportTidyWanteds err_ctxt tidy_unsolved }
  65   where
  66     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
  67
  68
  69 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
  70 reportUnsolvedWantedEvVars wanteds
  71   | isEmptyBag wanteds
  72   = return ()
  73   | otherwise
  74   = do { wanteds <- mapBagM zonkWantedEvVar wanteds
  75        ; env0 <- tcInitTidyEnv
  76        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
  77              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
  78              err_ctxt = CEC { cec_encl  = []
  79                             , cec_extra = empty
  80                             , cec_tidy  = tidy_env }
  81        ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
  82
  83 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
  84 reportUnsolvedDeriv unsolved loc
  85   | null unsolved
  86   = return ()
  87   | otherwise
  88   = setCtLoc loc $
  89     do { unsolved <- zonkTcThetaType unsolved
  90        ; env0 <- tcInitTidyEnv
  91        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
  92              tidy_unsolved = map (tidyPred tidy_env) unsolved
  93              err_ctxt = CEC { cec_encl  = []
  94                             , cec_extra = alt_fix
  95                             , cec_tidy  = tidy_env }
  96        ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
  97   where
  98     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
  99                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 100
 101 --------------------------------------------
 102 --      Internal functions
 103 --------------------------------------------
 104
 105 data ReportErrCtxt
 106     = CEC { cec_encl :: [Implication]  -- Enclosing implications
 107                                        --   (innermost first)
 108           , cec_tidy :: TidyEnv
 109           , cec_extra :: SDoc          -- Add this to each error message
 110       }
 111
 112 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
 113 reportTidyImplic ctxt implic
 114   = reportTidyWanteds ctxt' (ic_wanted implic)
 115   where
 116     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
 117
 118 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 119 reportTidyWanteds ctxt unsolved
 120   = do { let (flats,  implics)    = splitWanteds unsolved
 121              (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
 122              (tv_eqs, others)     = partition is_tv_eq non_ambigs
 123
 124        ; groupErrs (reportEqErrs ctxt) tv_eqs
 125        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
 126        ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
 127
 128            -- Only report ambiguity if no other errors (at all) happened
 129            -- See Note [Avoiding spurious errors] in TcSimplify
 130        ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
 131   where
 132     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 133
 134         -- Report equalities of form (a~ty) first.  They are usually
 135         -- skolem-equalities, and they cause confusing knock-on
 136         -- effects in other errors; see test T4093b.
 137     is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
 138                = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
 139                | otherwise = False
 140
 141         -- Treat it as "ambiguous" if
 142         --   (a) it is a class constraint
 143         --   (b) it constrains only type variables
 144         --       (else we'd prefer to report it as "no instance for...")
 145         --   (c) it mentions type variables that are not skolems
 146     is_ambiguous d = isTyVarClassPred pred
 147                   && not (tyVarsOfPred pred `subVarSet` skols)
 148                   where
 149                      pred = wantedEvVarPred d
 150
 151 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 152 reportFlat ctxt flats origin
 153   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
 154        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
 155        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
 156        ; ASSERT( null others ) return () }
 157   where
 158     (dicts, non_dicts) = partition isClassPred flats
 159     (eqs, non_eqs)     = partition isEqPred    non_dicts
 160     (ips, others)      = partition isIPPred    non_eqs
 161
 162 --------------------------------------------
 163 --      Support code
 164 --------------------------------------------
 165
 166 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 167           -> [WantedEvVar]                      -- Unsolved wanteds
 168           -> TcM ()
 169 -- Group together insts with the same origin
 170 -- We want to report them together in error messages
 171
 172 groupErrs _ []
 173   = return ()
 174 groupErrs report_err (wanted : wanteds)
 175   = do  { setCtLoc the_loc $
 176           report_err the_vars (ctLocOrigin the_loc)
 177         ; groupErrs report_err others }
 178   where
 179    the_loc           = wantedEvVarLoc wanted
 180    the_key           = mk_key the_loc
 181    the_vars          = map wantedEvVarPred (wanted:friends)
 182    (friends, others) = partition is_friend wanteds
 183    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
 184
 185    mk_key :: WantedLoc -> (SrcSpan, String)
 186    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
 187         -- It may seem crude to compare the error messages,
 188         -- but it makes sure that we combine just what the user sees,
 189         -- and it avoids need equality on InstLocs.
 190
 191 -- Add the "arising from..." part to a message about bunch of dicts
 192 addArising :: CtOrigin -> SDoc -> SDoc
 193 addArising orig msg = msg $$ nest 2 (pprArising orig)
 194
 195 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 196 -- Print something like
 197 --    (Eq a) arising from a use of x at y
 198 --    (Show a) arising froma use of p at q
 199 -- Also return a location for the erroe message
 200 pprWithArising []
 201   = panic "pprWithArising"
 202 pprWithArising [WantedEvVar ev loc]
 203   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 204 pprWithArising ev_vars
 205   = (first_loc, vcat (map ppr_one ev_vars))
 206   where
 207     first_loc = wantedEvVarLoc (head ev_vars)
 208     ppr_one (WantedEvVar v loc)
 209        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 210
 211 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 212 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 213
 214 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 215 pprErrCtxtLoc ctxt
 216   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 217        []           -> ptext (sLit "the top level")     -- Should not happen
 218        (orig:origs) -> ppr_skol orig $$
 219                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 220   where
 221     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 222     ppr_skol skol_info      = pprSkolInfo skol_info
 223
 224 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 225 couldNotDeduce givens wanteds
 226   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 227         , nest 2 $ ptext (sLit "from the context")
 228                      <+> pprEvVarTheta givens]
 229
 230 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
 231 -- Just gs => Say "could not deduce ... from gs"
 232 -- Nothing => No interesting givens, say something else
 233 getUserGivens (CEC {cec_encl = ctxt})
 234   | null user_givens = Nothing
 235   | otherwise        = Just user_givens
 236   where
 237     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
 238     user_givens | opt_PprStyle_Debug = givens
 239                 | otherwise          = filterOut isSelfDict givens
 240        -- In user mode, don't show the "self-dict" given
 241        -- which is only added to do co-inductive solving
 242        -- Rather an awkward hack, but there we are
 243        -- This is the only use of isSelfDict, so it's not in an inner loop
 244 \end{code}
 245
 246
 247 %************************************************************************
 248 %*                                                                      *
 249                 Implicit parameter errors
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 \begin{code}
 254 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 255 reportIPErrs ctxt ips orig
 256   = addErrorReport ctxt $ addArising orig msg
 257   where
 258     msg | Just givens <- getUserGivens ctxt
 259         = couldNotDeduce givens ips
 260         | otherwise
 261         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 262               , nest 2 (pprTheta ips) ]
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268                 Equality errors
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 274 reportEqErrs ctxt eqs orig
 275   = mapM_ report_one eqs
 276   where
 277     env0 = cec_tidy ctxt
 278     report_one (EqPred ty1 ty2)
 279       = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
 280            ; let ctxt' = ctxt { cec_tidy = env1
 281                                , cec_extra = cec_extra ctxt $$ extra }
 282            ; reportEqErr ctxt' ty1 ty2 }
 283     report_one pred
 284       = pprPanic "reportEqErrs" (ppr pred)
 285
 286 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 287 reportEqErr ctxt ty1 ty2
 288   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 289   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 290   | otherwise   -- Neither side is a type variable
 291                 -- Since the unsolved constraint is canonical,
 292                 -- it must therefore be of form (F tys ~ ty)
 293   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
 294   where
 295     msg = case getUserGivens ctxt of
 296             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 297             Nothing     -> misMatchMsg ty1 ty2
 298
 299 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 300 reportTyVarEqErr ctxt tv1 ty2
 301   | not is_meta1
 302   , Just tv2 <- tcGetTyVar_maybe ty2
 303   , isMetaTyVar tv2
 304   = -- sk ~ alpha: swap
 305     reportTyVarEqErr ctxt tv2 ty1
 306
 307   | not is_meta1
 308   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 309     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 310
 311   -- So tv is a meta tyvar, and presumably it is
 312   -- an *untouchable* meta tyvar, else it'd have been unified
 313   | not (k2 `isSubKind` k1)      -- Kind error
 314   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 315
 316   -- Check for skolem escape
 317   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 318   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 319         implic_loc = ic_loc implic
 320   , not (null esc_skols)
 321   = setCtLoc implic_loc $       -- Override the error message location from the
 322                                 -- place the equality arose to the implication site
 323     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 324        ; let msg = misMatchMsg ty1 ty2
 325              esc_doc | isSingleton esc_skols
 326                      = ptext (sLit "because this skolem type variable would escape:")
 327                      | otherwise
 328                      = ptext (sLit "because these skolem type variables would escape:")
 329              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 330                            , sep [ (if isSingleton esc_skols
 331                                       then ptext (sLit "This skolem is")
 332                                       else ptext (sLit "These skolems are"))
 333                                    <+> ptext (sLit "bound by")
 334                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 335        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 336
 337   -- Nastiest case: attempt to unify an untouchable variable
 338   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 339   , let implic_loc = ic_loc implic
 340         given      = ic_given implic
 341   = setCtLoc (ic_loc implic) $
 342     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
 343              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
 344                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 345                           , nest 2 (ptext (sLit "bound at")
 346                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
 347        ; addErrTcM (env1, msg $$ extra) }
 348
 349   | otherwise      -- I'm not sure how this can happen!
 350   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 351   where
 352     is_meta1 = isMetaTyVar tv1
 353     k1       = tyVarKind tv1
 354     k2       = typeKind ty2
 355     ty1      = mkTyVarTy tv1
 356
 357 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 358 -- See Note [Non-injective type functions]
 359 mkTyFunInfoMsg ty1 ty2
 360   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 361   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 362   , tc1 == tc2, isSynFamilyTyCon tc1
 363   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 364     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 365   | otherwise = empty
 366   where
 367     pp_inj tc | isInjectiveTyCon tc = empty
 368               | otherwise = ptext (sLit (", and may not be injective"))
 369
 370 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
 371 -- This version is used by TcSimplify too, which doesn't track the
 372 -- expected/acutal thing, so we just have ty1 ty2 here
 373 -- NB: The types are already tidied
 374 misMatchMsgWithExtras env ty1 ty2
 375   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
 376   where
 377     (env1, extra1) = typeExtraInfoMsg env ty1
 378     (env2, extra2) = typeExtraInfoMsg env1 ty2
 379
 380 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 381 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 382                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 383
 384 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 385 kindErrorMsg ty1 ty2
 386   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 387          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 388                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 389   where
 390     k1 = typeKind ty1
 391     k2 = typeKind ty2
 392
 393 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 394 -- Shows a bit of extra info about skolem constants
 395 typeExtraInfoMsg env ty
 396   | Just tv <- tcGetTyVar_maybe ty
 397   , isTcTyVar tv
 398   , isSkolemTyVar tv || isSigTyVar tv
 399   , not (isUnkSkol tv)
 400   , let (env1, tv1) = tidySkolemTyVar env tv
 401   = (env1, pprSkolTvBinding tv1)
 402   where
 403 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 404
 405 --------------------
 406 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 407 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 408   = do  { act_ty' <- zonkTcType act_ty
 409         ; exp_ty' <- zonkTcType exp_ty
 410         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 411               (env2, act_ty'') = tidyOpenType env1     act_ty'
 412         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 413
 414 mkExpectedActualMsg :: Type -> Type -> SDoc
 415 mkExpectedActualMsg act_ty exp_ty
 416   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 417          , text "  Actual type" <> colon <+> ppr act_ty ]
 418 \end{code}
 419
 420 Note [Non-injective type functions]
 421 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 422 It's very confusing to get a message like
 423      Couldn't match expected type `Depend s'
 424             against inferred type `Depend s1'
 425 so mkTyFunInfoMsg adds:
 426        NB: `Depend' is type function, and hence may not be injective
 427
 428 Warn of loopy local equalities that were dropped.
 429
 430
 431 %************************************************************************
 432 %*                                                                      *
 433                  Type-class errors
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 \begin{code}
 438 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 439 reportDictErrs ctxt wanteds orig
 440   = do { inst_envs <- tcGetInstEnvs
 441        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
 442        ; unless (null others) $
 443          addErrorReport ctxt (mk_no_inst_err others)
 444        ; mapM_ (addErrorReport ctxt) overlaps }
 445   where
 446     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
 447         -- Right msg  => overlap message
 448         -- Left  inst => no instance
 449     check_overlap inst_envs pred@(ClassP clas tys)
 450         = case lookupInstEnv inst_envs clas tys of
 451                 ([], _) -> Left pred            -- No match
 452                 -- The case of exactly one match and no unifiers means a
 453                 -- successful lookup.  That can't happen here, because dicts
 454                 -- only end up here if they didn't match in Inst.lookupInst
 455                 ([_],[])
 456                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 457                 res -> Right (mk_overlap_msg pred res)
 458     check_overlap _ _ = panic "check_overlap"
 459
 460     mk_overlap_msg pred (matches, unifiers)
 461       = ASSERT( not (null matches) )
 462         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 463                                 <+> pprPred pred)
 464              ,  sep [ptext (sLit "Matching instances") <> colon,
 465                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 466              ,  if not (isSingleton matches)
 467                 then    -- Two or more matches
 468                      empty
 469                 else    -- One match, plus some unifiers
 470                 ASSERT( not (null unifiers) )
 471                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 472                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 473                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 474                               ptext (sLit "when compiling the other instance declarations")])]
 475       where
 476         ispecs = [ispec | (ispec, _) <- matches]
 477
 478     mk_no_inst_err :: [PredType] -> SDoc
 479     mk_no_inst_err wanteds
 480       | Just givens <- getUserGivens ctxt
 481       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 482              , show_fixes (fix1 : fixes2) ]
 483
 484       | otherwise       -- Top level
 485       = vcat [ addArising orig $
 486                ptext (sLit "No instance") <> plural wanteds
 487                     <+> ptext (sLit "for") <+> pprTheta wanteds
 488              , show_fixes fixes2 ]
 489
 490       where
 491         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 492                           <+> ptext (sLit "to the context of")
 493                    , nest 2 $ pprErrCtxtLoc ctxt ]
 494
 495         fixes2 | null instance_dicts = []
 496                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 497                                         pprTheta instance_dicts]]
 498         instance_dicts = filterOut isTyVarClassPred wanteds
 499                 -- Insts for which it is worth suggesting an adding an
 500                 -- instance declaration.  Exclude tyvar dicts.
 501
 502         show_fixes :: [SDoc] -> SDoc
 503         show_fixes []     = empty
 504         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 505                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 506
 507 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 508 reportAmbigErrs ctxt skols ambigs
 509 -- Divide into groups that share a common set of ambiguous tyvars
 510   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 511   where
 512     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 513                    | d <- ambigs ]
 514     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 515
 516     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 517     report pairs
 518        = setCtLoc loc $
 519          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 520                                    <+> pprQuotedList tvs
 521                                    <+> text "in the constraint" <> plural pairs <> colon
 522                                  , nest 2 pp_wanteds ]
 523              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 524             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 525        where
 526          (_, tvs) : _ = pairs
 527          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 528
 529 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 530 -- There's an error with these Insts; if they have free type variables
 531 -- it's probably caused by the monomorphism restriction.
 532 -- Try to identify the offending variable
 533 -- ASSUMPTION: the Insts are fully zonked
 534 mkMonomorphismMsg ctxt inst_tvs
 535   = do  { dflags <- getDOpts
 536         ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
 537         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 538         ; return (tidy_env, mk_msg dflags docs) }
 539   where
 540     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 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 xopt 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 Note [Runtime skolems]
 641 ~~~~~~~~~~~~~~~~~~~~~~
 642 We want to give a reasonably helpful error message for ambiguity
 643 arising from *runtime* skolems in the debugger.  Mostly these
 644 are created by in RtClosureInspec.zonkRTTIType.  However at a
 645 breakpoint we return Ids from the CoreExpr, whose types may have
 646 free type variables bound by some enclosing 'forall'.  These are
 647 UnkSkols, created ty TcType.zonkQuantifiedTyVar.
 648
 649 These UnkSkols should never show up as ambiguous type variables in
 650 normal typechecking, so we hackily emit the debugger-related message
 651 both for RuntimeUnkSkols and UnkSkols. Hence the two cases in
 652 TcType.isRuntimeUnkSkol. Yuk. The rest of the debugger is such
 653 a mess that I don't feel motivated to clean up this bit.
 654
 655
 656 %************************************************************************
 657 %*                                                                      *
 658                  Error from the canonicaliser
 659          These ones are called *during* constraint simplification
 660 %*                                                                      *
 661 %************************************************************************
 662
 663 \begin{code}
 664 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 665 -- If there's a kind error, we don't want to blindly say "kind error"
 666 -- We might, say, be unifying a skolem 'a' with a type 'Int',
 667 -- in which case that's the error to report.  So we set things
 668 -- up to call reportEqErr, which does the business properly
 669 kindErrorTcS fl ty1 ty2
 670   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 671     do { let ctxt = CEC { cec_encl = []
 672                         , cec_extra = extra
 673                         , cec_tidy = env0 }
 674        ; reportEqErr ctxt ty1 ty2
 675        ; failM
 676        }
 677
 678 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 679 misMatchErrorTcS fl ty1 ty2
 680   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 681     do { let (env1, msg)  = misMatchMsgWithExtras env0 ty1 ty2
 682        ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
 683   where
 684     inaccessible_msg
 685       = case fl of
 686           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 687                           2 (mk_what loc)
 688           _         -> empty
 689     mk_what loc
 690       = case ctLocOrigin loc of
 691           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 692                                    <+> quotes (ppr dc) <> comma
 693                                , ptext (sLit "in") <+> pprMatchContext mc ]
 694           other_skol -> pprSkolInfo other_skol
 695
 696 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 697 occursCheckErrorTcS fl tv ty
 698   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
 699     do  { let extra1 = sep [ppr ty1, char '=', ppr ty2]
 700         ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
 701   where
 702     msg = text $ "Occurs check: cannot construct the infinite type:"
 703
 704 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 705 solverDepthErrorTcS depth stack
 706   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 707   = wrapErrTcS $ failWith msg
 708   | otherwise
 709   = wrapErrTcS $
 710     setCtFlavorLoc (cc_flavor top_item) $
 711     do { env0 <- tcInitTidyEnv
 712        ; let ev_vars  = map cc_id stack
 713              env1     = tidyFreeTyVars env0 free_tvs
 714              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 715              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 716        ; failWithTcM (env1, hang msg 2 extra) }
 717   where
 718     top_item = head stack
 719     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 720                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 721
 722 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 723 flattenForAllErrorTcS fl ty _bad_eqs
 724   = wrapErrTcS        $
 725     setCtFlavorLoc fl $
 726     do { env0 <- tcInitTidyEnv
 727        ; let (env1, ty') = tidyOpenType env0 ty
 728              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 729                        , ppr ty' ]
 730        ; failWithTcM (env1, msg) }
 731 \end{code}
 732
 733 %************************************************************************
 734 %*                                                                      *
 735                  Setting the context
 736 %*                                                                      *
 737 %************************************************************************
 738
 739 \begin{code}
 740 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 741 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 742 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
 743 setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 744
 745 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
 746              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
 747              -> TcS a
 748 wrapEqErrTcS fl ty1 ty2 thing_inside
 749   = do { ty_binds_var <- getTcSTyBinds
 750        ; wrapErrTcS $ setCtFlavorLoc fl $
 751     do {   -- Apply the current substitition
 752            -- and zonk to get rid of flatten-skolems
 753        ; ty_binds_map <- readTcRef ty_binds_var
 754        ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
 755        ; env0 <- tcInitTidyEnv
 756        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
 757        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
 758        ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
 759                                                      (ctLocOrigin loc) ty1 ty2
 760                                 ; thing_inside env3 ty1 ty2 extra }
 761        ; case fl of
 762            Wanted  loc   -> do_wanted loc
 763            Derived loc _ -> do_wanted loc
 764            Given {}      -> thing_inside env2 ty1 ty2 empty
 765                                  -- We could print more info, but it
 766                                  -- seems to be coming out already
 767        } }
 768   where
 769
 770 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 771                  -> TcM (TidyEnv, SDoc)
 772 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 773   -- If the types in the error message are the same
 774   -- as the types we are unifying (remember to zonk the latter)
 775   -- don't add the extra expected/actual message
 776   --
 777   -- The complication is that the types in the TypeEqOrigin must
 778   --   (a) be zonked
 779   --   (b) have any TcS-monad pending equalities applied to them
 780   --            (hence the passed-in substitution)
 781   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 782        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 783        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 784          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 785          then
 786             return (env0, empty)
 787          else
 788             return (env2, mkExpectedActualMsg act exp) }
 789
 790 getWantedEqExtra _ env0 orig _ _
 791   = return (env0, pprArising orig)
 792
 793 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 794 -- In general, becore printing a type, we want to
 795 --   a) Zonk it.  Even during constraint simplification this is
 796 --      is important, to un-flatten the flatten skolems in a type
 797 --   b) Substitute any solved unification variables.  This is
 798 --      only important *during* solving, becuase after solving
 799 --      the substitution is expressed in the mutable type variables
 800 --      But during solving there may be constraint (F xi ~ ty)
 801 --      where the substitution has not been applied to the RHS
 802 zonkSubstTidy env subst ty
 803   = do { ty' <- zonkTcTypeAndSubst subst ty
 804        ; return (tidyOpenType env ty') }
 805 \end{code}