compiler/typecheck/TcErrors.lhs

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