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 -- The [PredType] are already tidied
 153 reportFlat ctxt flats origin
 154   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
 155        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
 156        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
 157        ; ASSERT( null others ) return () }
 158   where
 159     (dicts, non_dicts) = partition isClassPred flats
 160     (eqs, non_eqs)     = partition isEqPred    non_dicts
 161     (ips, others)      = partition isIPPred    non_eqs
 162
 163 --------------------------------------------
 164 --      Support code
 165 --------------------------------------------
 166
 167 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 168           -> [WantedEvVar]                      -- Unsolved wanteds
 169           -> TcM ()
 170 -- Group together insts with the same origin
 171 -- We want to report them together in error messages
 172
 173 groupErrs _ []
 174   = return ()
 175 groupErrs report_err (wanted : wanteds)
 176   = do  { setCtLoc the_loc $
 177           report_err the_vars (ctLocOrigin the_loc)
 178         ; groupErrs report_err others }
 179   where
 180    the_loc           = wantedEvVarLoc wanted
 181    the_key           = mk_key the_loc
 182    the_vars          = map wantedEvVarPred (wanted:friends)
 183    (friends, others) = partition is_friend wanteds
 184    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
 185
 186    mk_key :: WantedLoc -> (SrcSpan, String)
 187    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
 188         -- It may seem crude to compare the error messages,
 189         -- but it makes sure that we combine just what the user sees,
 190         -- and it avoids need equality on InstLocs.
 191
 192 -- Add the "arising from..." part to a message about bunch of dicts
 193 addArising :: CtOrigin -> SDoc -> SDoc
 194 addArising orig msg = msg $$ nest 2 (pprArising orig)
 195
 196 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 197 -- Print something like
 198 --    (Eq a) arising from a use of x at y
 199 --    (Show a) arising froma use of p at q
 200 -- Also return a location for the erroe message
 201 pprWithArising []
 202   = panic "pprWithArising"
 203 pprWithArising [WantedEvVar ev loc]
 204   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 205 pprWithArising ev_vars
 206   = (first_loc, vcat (map ppr_one ev_vars))
 207   where
 208     first_loc = wantedEvVarLoc (head ev_vars)
 209     ppr_one (WantedEvVar v loc)
 210        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 211
 212 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 213 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 214
 215 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 216 pprErrCtxtLoc ctxt
 217   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 218        []           -> ptext (sLit "the top level")     -- Should not happen
 219        (orig:origs) -> ppr_skol orig $$
 220                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 221   where
 222     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 223     ppr_skol skol_info      = pprSkolInfo skol_info
 224
 225 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
 226 -- Just gs => Say "could not deduce ... from gs"
 227 -- Nothing => No interesting givens, say something else
 228 getUserGivens (CEC {cec_encl = ctxt})
 229   | null user_givens = Nothing
 230   | otherwise        = Just user_givens
 231   where
 232     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
 233     user_givens | opt_PprStyle_Debug = givens
 234                 | otherwise          = filterOut isSelfDict givens
 235        -- In user mode, don't show the "self-dict" given
 236        -- which is only added to do co-inductive solving
 237        -- Rather an awkward hack, but there we are
 238        -- This is the only use of isSelfDict, so it's not in an inner loop
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244                 Implicit parameter errors
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 \begin{code}
 249 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 250 reportIPErrs ctxt ips orig
 251   = addErrorReport ctxt $ addArising orig msg
 252   where
 253     msg | Just givens <- getUserGivens ctxt
 254         = couldNotDeduce givens ips
 255         | otherwise
 256         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 257               , nest 2 (pprTheta ips) ]
 258 \end{code}
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263                 Equality errors
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 269 -- The [PredType] are already tidied
 270 reportEqErrs ctxt eqs orig
 271   = mapM_ report_one eqs
 272   where
 273     env0 = cec_tidy ctxt
 274     report_one (EqPred ty1 ty2)
 275       = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
 276            ; let ctxt' = ctxt { cec_tidy = env1
 277                                , cec_extra = cec_extra ctxt $$ extra }
 278            ; reportEqErr ctxt' ty1 ty2 }
 279     report_one pred
 280       = pprPanic "reportEqErrs" (ppr pred)
 281
 282 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 283 -- ty1 and ty2 are already tidied
 284 reportEqErr ctxt ty1 ty2
 285   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 286   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 287   | otherwise   -- Neither side is a type variable
 288                 -- Since the unsolved constraint is canonical,
 289                 -- it must therefore be of form (F tys ~ ty)
 290   = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
 291
 292 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 293 -- tv1 and ty2 are already tidied
 294 reportTyVarEqErr ctxt tv1 ty2
 295   | not is_meta1
 296   , Just tv2 <- tcGetTyVar_maybe ty2
 297   , isMetaTyVar tv2
 298   = -- sk ~ alpha: swap
 299     reportTyVarEqErr ctxt tv2 ty1
 300
 301   | not is_meta1
 302   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 303     addErrTcM (addExtraInfo (misMatchOrCND ctxt ty1 ty2)
 304                             (cec_tidy ctxt) ty1 ty2)
 305
 306   -- So tv is a meta tyvar, and presumably it is
 307   -- an *untouchable* meta tyvar, else it'd have been unified
 308   | not (k2 `isSubKind` k1)      -- Kind error
 309   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 310
 311   -- Check for skolem escape
 312   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 313   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 314         implic_loc = ic_loc implic
 315   , not (null esc_skols)
 316   = setCtLoc implic_loc $       -- Override the error message location from the
 317                                 -- place the equality arose to the implication site
 318     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 319        ; let msg = misMatchMsg ty1 ty2
 320              esc_doc | isSingleton esc_skols
 321                      = ptext (sLit "because this skolem type variable would escape:")
 322                      | otherwise
 323                      = ptext (sLit "because these skolem type variables would escape:")
 324              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 325                            , sep [ (if isSingleton esc_skols
 326                                       then ptext (sLit "This skolem is")
 327                                       else ptext (sLit "These skolems are"))
 328                                    <+> ptext (sLit "bound by")
 329                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 330        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 331
 332   -- Nastiest case: attempt to unify an untouchable variable
 333   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 334   , let implic_loc = ic_loc implic
 335         given      = ic_given implic
 336   = setCtLoc (ic_loc implic) $
 337     do { let (env1, msg) = addExtraInfo (misMatchMsg ty1 ty2) (cec_tidy ctxt) ty1 ty2
 338              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
 339                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 340                           , nest 2 (ptext (sLit "bound at")
 341                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
 342        ; addErrTcM (env1, msg $$ extra) }
 343
 344   | otherwise      -- I'm not sure how this can happen!
 345   = addErrTcM (addExtraInfo (misMatchMsg ty1 ty2) (cec_tidy ctxt) ty1 ty2)
 346   where
 347     is_meta1 = isMetaTyVar tv1
 348     k1       = tyVarKind tv1
 349     k2       = typeKind ty2
 350     ty1      = mkTyVarTy tv1
 351
 352 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 353 -- See Note [Non-injective type functions]
 354 mkTyFunInfoMsg ty1 ty2
 355   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 356   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 357   , tc1 == tc2, isSynFamilyTyCon tc1
 358   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 359     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 360   | otherwise = empty
 361   where
 362     pp_inj tc | isInjectiveTyCon tc = empty
 363               | otherwise = ptext (sLit (", and may not be injective"))
 364
 365 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
 366 misMatchOrCND ctxt ty1 ty2
 367   = case getUserGivens ctxt of
 368       Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 369       Nothing     -> misMatchMsg ty1 ty2
 370
 371 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 372 couldNotDeduce givens wanteds
 373   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 374         , nest 2 $ ptext (sLit "from the context")
 375                      <+> pprEvVarTheta givens]
 376
 377 addExtraInfo :: SDoc -> 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 addExtraInfo msg env ty1 ty2
 382   = (env2, msg $$ 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 (isUnkSkol 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         ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
 544         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 545         ; return (tidy_env, mk_msg dflags docs) }
 546   where
 547     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 548         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 549                    (pprWithCommas ppr inst_tvs),
 550                 ptext (sLit "Use :print or :force to determine these types")]
 551     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 552                         -- This happens in things like
 553                         --      f x = show (read "foo")
 554                         -- where monomorphism doesn't play any role
 555     mk_msg dflags docs
 556         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 557                 nest 2 (vcat docs),
 558                 monomorphism_fix dflags]
 559
 560 monomorphism_fix :: DynFlags -> SDoc
 561 monomorphism_fix dflags
 562   = ptext (sLit "Probable fix:") <+> vcat
 563         [ptext (sLit "give these definition(s) an explicit type signature"),
 564          if xopt Opt_MonomorphismRestriction dflags
 565            then ptext (sLit "or use -XNoMonomorphismRestriction")
 566            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 567                         -- if it is not already set!
 568
 569
 570 -----------------------
 571 -- findGlobals looks at the value environment and finds values whose
 572 -- types mention any of the offending type variables.  It has to be
 573 -- careful to zonk the Id's type first, so it has to be in the monad.
 574 -- We must be careful to pass it a zonked type variable, too.
 575
 576 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 577 mkEnvSigMsg what env_sigs
 578  | null env_sigs = empty
 579  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 580                     , nest 2 (vcat env_sigs) ]
 581
 582 findGlobals :: ReportErrCtxt
 583             -> TcTyVarSet
 584             -> TcM (TidyEnv, [SDoc])
 585
 586 findGlobals ctxt tvs
 587   = do { lcl_ty_env <- case cec_encl ctxt of
 588                         []    -> getLclTypeEnv
 589                         (i:_) -> return (ic_env i)
 590        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 591   where
 592     go tidy_env acc [] = return (tidy_env, acc)
 593     go tidy_env acc (thing : things) = do
 594         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 595         case maybe_doc of
 596           Just d  -> go tidy_env1 (d:acc) things
 597           Nothing -> go tidy_env1 acc     things
 598
 599     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 600
 601 -----------------------
 602 find_thing :: TidyEnv -> (TcType -> Bool)
 603            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 604 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 605   = do { id_ty <- zonkTcType  (idType id)
 606        ; if ignore_it id_ty then
 607            return (tidy_env, Nothing)
 608          else do
 609        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 610              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 611                        , nest 2 (parens (ptext (sLit "bound at") <+>
 612                                    ppr (getSrcLoc id)))]
 613        ; return (tidy_env', Just msg) } }
 614
 615 find_thing tidy_env ignore_it (ATyVar tv ty)
 616   = do { tv_ty <- zonkTcType ty
 617        ; if ignore_it tv_ty then
 618             return (tidy_env, Nothing)
 619          else do
 620        { let -- The name tv is scoped, so we don't need to tidy it
 621             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 622             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 623                       , nest 2 bound_at]
 624
 625             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 626                      , getOccName tv == getOccName tv' = empty
 627                      | otherwise = equals <+> ppr tidy_ty
 628                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 629             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 630
 631        ; return (tidy_env1, Just msg) } }
 632
 633 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 634
 635 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 636 warnDefaulting wanteds default_ty
 637   = do { warn_default <- doptM Opt_WarnTypeDefaults
 638        ; setCtLoc loc $ warnTc warn_default warn_msg }
 639   where
 640         -- Tidy them first
 641     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 642                                 quotes (ppr default_ty),
 643                       nest 2 ppr_wanteds ]
 644     (loc, ppr_wanteds) = pprWithArising wanteds
 645 \end{code}
 646
 647 Note [Runtime skolems]
 648 ~~~~~~~~~~~~~~~~~~~~~~
 649 We want to give a reasonably helpful error message for ambiguity
 650 arising from *runtime* skolems in the debugger.  These
 651 are created by in RtClosureInspect.zonkRTTIType.
 652
 653
 654 %************************************************************************
 655 %*                                                                      *
 656                  Error from the canonicaliser
 657          These ones are called *during* constraint simplification
 658 %*                                                                      *
 659 %************************************************************************
 660
 661 \begin{code}
 662 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 663 -- If there's a kind error, we don't want to blindly say "kind error"
 664 -- We might, say, be unifying a skolem 'a' with a type 'Int',
 665 -- in which case that's the error to report.  So we set things
 666 -- up to call reportEqErr, which does the business properly
 667 kindErrorTcS fl ty1 ty2
 668   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 669     do { let ctxt = CEC { cec_encl = []
 670                         , cec_extra = extra
 671                         , cec_tidy = env0 }
 672        ; reportEqErr ctxt ty1 ty2
 673        ; failM
 674        }
 675
 676 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 677 misMatchErrorTcS fl ty1 ty2
 678   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 679     do { let msg = inaccessible_msg $$ misMatchMsg ty1 ty2
 680              (env1, msg1) = addExtraInfo msg env0 ty1 ty2
 681        ; failWithTcM (env1, msg1 $$ extra) }
 682   where
 683     inaccessible_msg
 684       = case fl of
 685           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 686                           2 (mk_what loc)
 687           _         -> empty
 688     mk_what loc
 689       = case ctLocOrigin loc of
 690           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 691                                    <+> quotes (ppr dc) <> comma
 692                                , ptext (sLit "in") <+> pprMatchContext mc ]
 693           other_skol -> pprSkolInfo other_skol
 694
 695 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 696 occursCheckErrorTcS fl tv ty
 697   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
 698     do  { let extra1 = sep [ppr ty1, char '=', ppr ty2]
 699         ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
 700   where
 701     msg = text $ "Occurs check: cannot construct the infinite type:"
 702
 703 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 704 solverDepthErrorTcS depth stack
 705   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 706   = wrapErrTcS $ failWith msg
 707   | otherwise
 708   = wrapErrTcS $
 709     setCtFlavorLoc (cc_flavor top_item) $
 710     do { env0 <- tcInitTidyEnv
 711        ; let ev_vars  = map cc_id stack
 712              env1     = tidyFreeTyVars env0 free_tvs
 713              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 714              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 715        ; failWithTcM (env1, hang msg 2 extra) }
 716   where
 717     top_item = head stack
 718     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 719                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 720
 721 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 722 flattenForAllErrorTcS fl ty _bad_eqs
 723   = wrapErrTcS        $
 724     setCtFlavorLoc fl $
 725     do { env0 <- tcInitTidyEnv
 726        ; let (env1, ty') = tidyOpenType env0 ty
 727              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 728                        , ppr ty' ]
 729        ; failWithTcM (env1, msg) }
 730 \end{code}
 731
 732 %************************************************************************
 733 %*                                                                      *
 734                  Setting the context
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 \begin{code}
 739 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 740 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 741 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
 742 setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 743
 744 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
 745              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
 746              -> TcS a
 747 wrapEqErrTcS fl ty1 ty2 thing_inside
 748   = do { ty_binds_var <- getTcSTyBinds
 749        ; wrapErrTcS $ setCtFlavorLoc fl $
 750     do {   -- Apply the current substitition
 751            -- and zonk to get rid of flatten-skolems
 752        ; ty_binds_map <- readTcRef ty_binds_var
 753        ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
 754        ; env0 <- tcInitTidyEnv
 755        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
 756        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
 757        ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
 758                                                      (ctLocOrigin loc) ty1 ty2
 759                                 ; thing_inside env3 ty1 ty2 extra }
 760        ; case fl of
 761            Wanted  loc   -> do_wanted loc
 762            Derived loc _ -> do_wanted loc
 763            Given {}      -> thing_inside env2 ty1 ty2 empty
 764                                  -- We could print more info, but it
 765                                  -- seems to be coming out already
 766        } }
 767   where
 768
 769 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 770                  -> TcM (TidyEnv, SDoc)
 771 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 772   -- If the types in the error message are the same
 773   -- as the types we are unifying (remember to zonk the latter)
 774   -- don't add the extra expected/actual message
 775   --
 776   -- The complication is that the types in the TypeEqOrigin must
 777   --   (a) be zonked
 778   --   (b) have any TcS-monad pending equalities applied to them
 779   --            (hence the passed-in substitution)
 780   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 781        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 782        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 783          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 784          then
 785             return (env0, empty)
 786          else
 787             return (env2, mkExpectedActualMsg act exp) }
 788
 789 getWantedEqExtra _ env0 orig _ _
 790   = return (env0, pprArising orig)
 791
 792 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 793 -- In general, becore printing a type, we want to
 794 --   a) Zonk it.  Even during constraint simplification this is
 795 --      is important, to un-flatten the flatten skolems in a type
 796 --   b) Substitute any solved unification variables.  This is
 797 --      only important *during* solving, becuase after solving
 798 --      the substitution is expressed in the mutable type variables
 799 --      But during solving there may be constraint (F xi ~ ty)
 800 --      where the substitution has not been applied to the RHS
 801 zonkSubstTidy env subst ty
 802   = do { ty' <- zonkTcTypeAndSubst subst ty
 803        ; return (tidyOpenType env ty') }
 804 \end{code}