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 (isUnk 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         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 537         ; return (tidy_env, mk_msg dflags docs) }
 538   where
 539     mk_msg _ _ | any isRuntimeUnk inst_tvs
 540         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 541                    (pprWithCommas ppr inst_tvs),
 542                 ptext (sLit "Use :print or :force to determine these types")]
 543     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 544                         -- This happens in things like
 545                         --      f x = show (read "foo")
 546                         -- where monomorphism doesn't play any role
 547     mk_msg dflags docs
 548         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 549                 nest 2 (vcat docs),
 550                 monomorphism_fix dflags]
 551
 552 monomorphism_fix :: DynFlags -> SDoc
 553 monomorphism_fix dflags
 554   = ptext (sLit "Probable fix:") <+> vcat
 555         [ptext (sLit "give these definition(s) an explicit type signature"),
 556          if xopt Opt_MonomorphismRestriction dflags
 557            then ptext (sLit "or use -XNoMonomorphismRestriction")
 558            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 559                         -- if it is not already set!
 560
 561
 562 -----------------------
 563 -- findGlobals looks at the value environment and finds values whose
 564 -- types mention any of the offending type variables.  It has to be
 565 -- careful to zonk the Id's type first, so it has to be in the monad.
 566 -- We must be careful to pass it a zonked type variable, too.
 567
 568 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 569 mkEnvSigMsg what env_sigs
 570  | null env_sigs = empty
 571  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 572                     , nest 2 (vcat env_sigs) ]
 573
 574 findGlobals :: ReportErrCtxt
 575             -> TcTyVarSet
 576             -> TcM (TidyEnv, [SDoc])
 577
 578 findGlobals ctxt tvs
 579   = do { lcl_ty_env <- case cec_encl ctxt of
 580                         []    -> getLclTypeEnv
 581                         (i:_) -> return (ic_env i)
 582        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 583   where
 584     go tidy_env acc [] = return (tidy_env, acc)
 585     go tidy_env acc (thing : things) = do
 586         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 587         case maybe_doc of
 588           Just d  -> go tidy_env1 (d:acc) things
 589           Nothing -> go tidy_env1 acc     things
 590
 591     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 592
 593 -----------------------
 594 find_thing :: TidyEnv -> (TcType -> Bool)
 595            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 596 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 597   = do { id_ty <- zonkTcType  (idType id)
 598        ; if ignore_it id_ty then
 599            return (tidy_env, Nothing)
 600          else do
 601        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 602              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 603                        , nest 2 (parens (ptext (sLit "bound at") <+>
 604                                    ppr (getSrcLoc id)))]
 605        ; return (tidy_env', Just msg) } }
 606
 607 find_thing tidy_env ignore_it (ATyVar tv ty)
 608   = do { tv_ty <- zonkTcType ty
 609        ; if ignore_it tv_ty then
 610             return (tidy_env, Nothing)
 611          else do
 612        { let -- The name tv is scoped, so we don't need to tidy it
 613             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 614             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 615                       , nest 2 bound_at]
 616
 617             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 618                      , getOccName tv == getOccName tv' = empty
 619                      | otherwise = equals <+> ppr tidy_ty
 620                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 621             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 622
 623        ; return (tidy_env1, Just msg) } }
 624
 625 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 626
 627 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 628 warnDefaulting wanteds default_ty
 629   = do { warn_default <- doptM Opt_WarnTypeDefaults
 630        ; setCtLoc loc $ warnTc warn_default warn_msg }
 631   where
 632         -- Tidy them first
 633     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 634                                 quotes (ppr default_ty),
 635                       nest 2 ppr_wanteds ]
 636     (loc, ppr_wanteds) = pprWithArising wanteds
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641                  Error from the canonicaliser
 642          These ones are called *during* constraint simplification
 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   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 654     do { let ctxt = CEC { cec_encl = []
 655                         , cec_extra = extra
 656                         , cec_tidy = env0 }
 657        ; reportEqErr ctxt ty1 ty2 }
 658
 659 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 660 misMatchErrorTcS fl ty1 ty2
 661   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 662     do { let (env1, msg)  = misMatchMsgWithExtras env0 ty1 ty2
 663        ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
 664   where
 665     inaccessible_msg
 666       = case fl of
 667           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 668                           2 (mk_what loc)
 669           _         -> empty
 670     mk_what loc
 671       = case ctLocOrigin loc of
 672           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 673                                    <+> quotes (ppr dc) <> comma
 674                                , ptext (sLit "in") <+> pprMatchContext mc ]
 675           other_skol -> pprSkolInfo other_skol
 676
 677 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 678 occursCheckErrorTcS fl tv ty
 679   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
 680     do  { let extra1 = sep [ppr ty1, char '=', ppr ty2]
 681         ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
 682   where
 683     msg = text $ "Occurs check: cannot construct the infinite type:"
 684
 685 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 686 solverDepthErrorTcS depth stack
 687   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 688   = wrapErrTcS $ failWith msg
 689   | otherwise
 690   = wrapErrTcS $
 691     setCtFlavorLoc (cc_flavor top_item) $
 692     do { env0 <- tcInitTidyEnv
 693        ; let ev_vars  = map cc_id stack
 694              env1     = tidyFreeTyVars env0 free_tvs
 695              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 696              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 697        ; failWithTcM (env1, hang msg 2 extra) }
 698   where
 699     top_item = head stack
 700     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 701                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 702
 703 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 704 flattenForAllErrorTcS fl ty _bad_eqs
 705   = wrapErrTcS        $
 706     setCtFlavorLoc fl $
 707     do { env0 <- tcInitTidyEnv
 708        ; let (env1, ty') = tidyOpenType env0 ty
 709              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 710                        , ppr ty' ]
 711        ; failWithTcM (env1, msg) }
 712 \end{code}
 713
 714 %************************************************************************
 715 %*                                                                      *
 716                  Setting the context
 717 %*                                                                      *
 718 %************************************************************************
 719
 720 \begin{code}
 721 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 722 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
 723 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 724 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 725
 726 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
 727              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
 728              -> TcS a
 729 wrapEqErrTcS fl ty1 ty2 thing_inside
 730   = do { ty_binds_var <- getTcSTyBinds
 731        ; wrapErrTcS $ setCtFlavorLoc fl $
 732     do {   -- Apply the current substitition
 733            -- and zonk to get rid of flatten-skolems
 734        ; ty_binds_map <- readTcRef ty_binds_var
 735        ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
 736        ; env0 <- tcInitTidyEnv
 737        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
 738        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
 739        ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
 740                                                      (ctLocOrigin loc) ty1 ty2
 741                                 ; thing_inside env3 ty1 ty2 extra }
 742        ; case fl of
 743            Wanted  loc -> do_wanted loc
 744            Derived loc -> do_wanted loc
 745            Given {}    -> thing_inside env2 ty1 ty2 empty
 746                                  -- We could print more info, but it
 747                                  -- seems to be coming out already
 748        } }
 749   where
 750
 751 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 752                  -> TcM (TidyEnv, SDoc)
 753 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 754   -- If the types in the error message are the same
 755   -- as the types we are unifying (remember to zonk the latter)
 756   -- don't add the extra expected/actual message
 757   --
 758   -- The complication is that the types in the TypeEqOrigin must
 759   --   (a) be zonked
 760   --   (b) have any TcS-monad pending equalities applied to them
 761   --            (hence the passed-in substitution)
 762   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 763        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 764        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 765          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 766          then
 767             return (env0, empty)
 768          else
 769             return (env2, mkExpectedActualMsg act exp) }
 770
 771 getWantedEqExtra _ env0 orig _ _
 772   = return (env0, pprArising orig)
 773
 774 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 775 -- In general, becore printing a type, we want to
 776 --   a) Zonk it.  Even during constraint simplification this is
 777 --      is important, to un-flatten the flatten skolems in a type
 778 --   b) Substitute any solved unification variables.  This is
 779 --      only important *during* solving, becuase after solving
 780 --      the substitution is expressed in the mutable type variables
 781 --      But during solving there may be constraint (F xi ~ ty)
 782 --      where the substitution has not been applied to the RHS
 783 zonkSubstTidy env subst ty
 784   = do { ty' <- zonkTcTypeAndSubst subst ty
 785        ; return (tidyOpenType env ty') }
 786 \end{code}