compiler/typecheck/TcErrors.lhs

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