\begin{code}
module TcErrors(
reportUnsolved, reportUnsolvedDeriv,
reportUnsolvedWantedEvVars, warnDefaulting,
unifyCtxt, typeExtraInfoMsg,
flattenForAllErrorTcS,
solverDepthErrorTcS
) where
#include "HsVersions.h"
import TcRnMonad
import TcMType
import TcSMonad
import TcType
import TypeRep
import Inst
import InstEnv
import TyCon
import Name
import NameEnv
import Id ( idType )
import HsExpr ( pprMatchContext )
import Var
import VarSet
import VarEnv
import SrcLoc
import Bag
import ListSetOps( equivClasses )
import Util
import FastString
import Outputable
import DynFlags
import StaticFlags( opt_PprStyle_Debug )
import Data.List( partition )
import Control.Monad( when, unless )
\end{code}
%************************************************************************
%* *
\section{Errors and contexts}
%* *
%************************************************************************
ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?
\begin{code}
reportUnsolved :: (Bag WantedEvVar, Bag Implication) -> Bag FrozenError -> TcM ()
reportUnsolved (unsolved_flats, unsolved_implics) frozen_errors
| isEmptyBag unsolved && isEmptyBag frozen_errors
= return ()
| otherwise
= do { frozen_errors_zonked <- mapBagM zonk_frozen frozen_errors
; let frozen_tvs = tyVarsOfFrozen frozen_errors_zonked
; unsolved <- mapBagM zonkWanted unsolved
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 $
tyVarsOfWanteds unsolved `unionVarSet` frozen_tvs
tidy_unsolved = tidyWanteds tidy_env unsolved
err_ctxt = CEC { cec_encl = []
, cec_extra = empty
, cec_tidy = tidy_env
}
; traceTc "reportUnsolved" (vcat [
text "Unsolved constraints =" <+> ppr unsolved,
text "Frozen errors =" <+> ppr frozen_errors_zonked ])
; let tidy_frozen_errors_zonked = tidyFrozen tidy_env frozen_errors_zonked
; reportTidyFrozens tidy_env tidy_frozen_errors_zonked
; reportTidyWanteds err_ctxt tidy_unsolved }
where
unsolved = Bag.mapBag WcEvVar unsolved_flats `unionBags`
Bag.mapBag WcImplic unsolved_implics
zonk_frozen (FrozenError frknd fl ty1 ty2)
= do { ty1z <- zonkTcType ty1
; ty2z <- zonkTcType ty2
; return (FrozenError frknd fl ty1z ty2z) }
tyVarsOfFrozen fr
= unionVarSets $ bagToList (mapBag tvs_of_frozen fr)
tvs_of_frozen (FrozenError _ _ ty1 ty2) = tyVarsOfTypes [ty1,ty2]
tidyFrozen env fr = mapBag (tidy_frozen env) fr
tidy_frozen env (FrozenError frknd fl ty1 ty2)
= FrozenError frknd fl (tidyType env ty1) (tidyType env ty2)
reportTidyFrozens :: TidyEnv -> Bag FrozenError -> TcM ()
reportTidyFrozens tidy_env fr = mapBagM_ (reportTidyFrozen tidy_env) fr
reportTidyFrozen :: TidyEnv -> FrozenError -> TcM ()
reportTidyFrozen tidy_env err@(FrozenError _ fl _ty1 _ty2)
= do { let dec_errs = decompFrozenError err
init_err_ctxt = CEC { cec_encl = []
, cec_extra = empty
, cec_tidy = tidy_env }
; mapM_ (report_dec_err init_err_ctxt) dec_errs }
where
report_dec_err err_ctxt (ty1,ty2)
= do { (tidy_env2,extra2)
<- if isGiven fl
then return (cec_tidy err_ctxt, inaccessible_msg)
else getWantedEqExtra emptyTvSubst (cec_tidy err_ctxt) loc_orig ty1 ty2
; let err_ctxt2 = err_ctxt { cec_tidy = tidy_env2
, cec_extra = cec_extra err_ctxt $$ extra2 }
; setCtFlavorLoc fl $
reportEqErr err_ctxt2 ty1 ty2
}
loc_orig | Wanted loc <- fl = ctLocOrigin loc
| Derived loc _ <- fl = ctLocOrigin loc
| otherwise = pprPanic "loc_orig" empty
inaccessible_msg
| Given loc <- fl
= hang (ptext (sLit "Inaccessible code in")) 2 (mk_what loc)
| otherwise = pprPanic "inaccessible_msg" empty
mk_what loc
= case ctLocOrigin loc of
PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
<+> quotes (ppr dc) <> comma
, ptext (sLit "in") <+> pprMatchContext mc ]
other_skol -> pprSkolInfo other_skol
decompFrozenError :: FrozenError -> [(TcType,TcType)]
decompFrozenError (FrozenError errk _fl ty1 ty2)
| OccCheckError <- errk
= dec_occ_check ty1 ty2
| otherwise
= [(ty1,ty2)]
where dec_occ_check :: TcType -> TcType -> [(TcType,TcType)]
dec_occ_check ty1 ty2
| tcEqType ty1 ty2 = []
dec_occ_check ty1@(TyVarTy {}) ty2 = [(ty1,ty2)]
dec_occ_check (FunTy s1 t1) (FunTy s2 t2)
= let errs1 = dec_occ_check s1 s2
errs2 = dec_occ_check t1 t2
in errs1 ++ errs2
dec_occ_check ty1@(TyConApp fn1 tys1) ty2@(TyConApp fn2 tys2)
| fn1 == fn2 && length tys1 == length tys2
, not (isSynFamilyTyCon fn1)
= concatMap (\(t1,t2) -> dec_occ_check t1 t2) (zip tys1 tys2)
| otherwise
= [(ty1,ty2)]
dec_occ_check ty1 ty2
| Just (s1,t1) <- tcSplitAppTy_maybe ty1
, Just (s2,t2) <- tcSplitAppTy_maybe ty2
= let errs1 = dec_occ_check s1 s2
errs2 = dec_occ_check t1 t2
in errs1 ++ errs2
dec_occ_check ty1 ty2 = [(ty1,ty2)]
reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
reportUnsolvedWantedEvVars wanteds
| isEmptyBag wanteds
= return ()
| otherwise
= do { wanteds <- mapBagM zonkWantedEvVar wanteds
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
tidy_unsolved = tidyWantedEvVars tidy_env wanteds
err_ctxt = CEC { cec_encl = []
, cec_extra = empty
, cec_tidy = tidy_env }
; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
reportUnsolvedDeriv unsolved loc
| null unsolved
= return ()
| otherwise
= setCtLoc loc $
do { unsolved <- zonkTcThetaType unsolved
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
tidy_unsolved = map (tidyPred tidy_env) unsolved
err_ctxt = CEC { cec_encl = []
, cec_extra = alt_fix
, cec_tidy = tidy_env }
; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
where
alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
data ReportErrCtxt
= CEC { cec_encl :: [Implication]
, cec_tidy :: TidyEnv
, cec_extra :: SDoc
}
reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
reportTidyImplic ctxt implic
= reportTidyWanteds ctxt' (ic_wanted implic)
where
ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportTidyWanteds ctxt unsolved
= do { let (flats, implics) = splitWanteds unsolved
(ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
(tv_eqs, others) = partition is_tv_eq non_ambigs
; groupErrs (reportEqErrs ctxt) tv_eqs
; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
; traceTc "rtw" (vcat [
text "unsolved =" <+> ppr unsolved,
text "tveqs =" <+> ppr tv_eqs,
text "others =" <+> ppr others,
text "ambigs =" <+> ppr ambigs ,
text "implics =" <+> ppr implics])
; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
where
skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
= tcIsTyVarTy ty1 || tcIsTyVarTy ty2
| otherwise = False
is_ambiguous d = isTyVarClassPred pred
&& not (tyVarsOfPred pred `subVarSet` skols)
where
pred = wantedEvVarPred d
reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportFlat ctxt flats origin
= do { unless (null dicts) $ reportDictErrs ctxt dicts origin
; unless (null eqs) $ reportEqErrs ctxt eqs origin
; unless (null ips) $ reportIPErrs ctxt ips origin
; ASSERT( null others ) return () }
where
(dicts, non_dicts) = partition isClassPred flats
(eqs, non_eqs) = partition isEqPred non_dicts
(ips, others) = partition isIPPred non_eqs
groupErrs :: ([PredType] -> CtOrigin -> TcM ())
-> [WantedEvVar]
-> TcM ()
groupErrs _ []
= return ()
groupErrs report_err (wanted : wanteds)
= do { setCtLoc the_loc $
report_err the_vars (ctLocOrigin the_loc)
; groupErrs report_err others }
where
the_loc = wantedEvVarLoc wanted
the_key = mk_key the_loc
the_vars = map wantedEvVarPred (wanted:friends)
(friends, others) = partition is_friend wanteds
is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
mk_key :: WantedLoc -> (SrcSpan, String)
mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig msg = msg $$ nest 2 (pprArising orig)
pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
pprWithArising []
= panic "pprWithArising"
pprWithArising [WantedEvVar ev loc]
= (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
pprWithArising ev_vars
= (first_loc, vcat (map ppr_one ev_vars))
where
first_loc = wantedEvVarLoc (head ev_vars)
ppr_one (WantedEvVar v loc)
= parens (pprPred (evVarPred v)) <+> pprArisingAt loc
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
pprErrCtxtLoc :: ReportErrCtxt -> SDoc
pprErrCtxtLoc ctxt
= case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
[] -> ptext (sLit "the top level")
(orig:origs) -> ppr_skol orig $$
vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
where
ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
ppr_skol skol_info = pprSkolInfo skol_info
getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
getUserGivens (CEC {cec_encl = ctxt})
| null user_givens = Nothing
| otherwise = Just user_givens
where
givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
user_givens | opt_PprStyle_Debug = givens
| otherwise = filterOut isSelfDict givens
\end{code}
%************************************************************************
%* *
Implicit parameter errors
%* *
%************************************************************************
\begin{code}
reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportIPErrs ctxt ips orig
= addErrorReport ctxt $ addArising orig msg
where
msg | Just givens <- getUserGivens ctxt
= couldNotDeduce givens ips
| otherwise
= sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
, nest 2 (pprTheta ips) ]
\end{code}
%************************************************************************
%* *
Equality errors
%* *
%************************************************************************
\begin{code}
reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportEqErrs ctxt eqs orig
= mapM_ report_one eqs
where
env0 = cec_tidy ctxt
report_one (EqPred ty1 ty2)
= do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
; let ctxt' = ctxt { cec_tidy = env1
, cec_extra = extra $$ cec_extra ctxt }
; reportEqErr ctxt' ty1 ty2 }
report_one pred
= pprPanic "reportEqErrs" (ppr pred)
reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
reportEqErr ctxt ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
| Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
| otherwise
= addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
reportTyVarEqErr ctxt tv1 ty2
| not is_meta1
, Just tv2 <- tcGetTyVar_maybe ty2
, isMetaTyVar tv2
=
reportTyVarEqErr ctxt tv2 ty1
| not is_meta1
=
addErrorReport (addExtraInfo ctxt ty1 ty2)
(misMatchOrCND ctxt ty1 ty2)
| not (k2 `isSubKind` k1)
= addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
| tv1 `elemVarSet` tyVarsOfType ty2
= let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
(sep [ppr ty1, char '=', ppr ty2])
in addErrorReport ctxt occCheckMsg
| (implic:_) <- cec_encl ctxt
, let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
implic_loc = ic_loc implic
, not (null esc_skols)
= setCtLoc implic_loc $
do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
; let msg = misMatchMsg ty1 ty2
esc_doc | isSingleton esc_skols
= ptext (sLit "because this skolem type variable would escape:")
| otherwise
= ptext (sLit "because these skolem type variables would escape:")
extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
, sep [ (if isSingleton esc_skols
then ptext (sLit "This skolem is")
else ptext (sLit "These skolems are"))
<+> ptext (sLit "bound by")
, nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
| (implic:_) <- cec_encl ctxt
, let implic_loc = ic_loc implic
given = ic_given implic
= setCtLoc (ic_loc implic) $
do { let msg = misMatchMsg ty1 ty2
extra = quotes (ppr tv1)
<+> sep [ ptext (sLit "is untouchable")
, ptext (sLit "inside the constraints") <+> pprEvVarTheta given
, ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
| otherwise
= return ()
where
is_meta1 = isMetaTyVar tv1
k1 = tyVarKind tv1
k2 = typeKind ty2
ty1 = mkTyVarTy tv1
mkTyFunInfoMsg :: TcType -> TcType -> SDoc
mkTyFunInfoMsg ty1 ty2
| Just (tc1,_) <- tcSplitTyConApp_maybe ty1
, Just (tc2,_) <- tcSplitTyConApp_maybe ty2
, tc1 == tc2, isSynFamilyTyCon tc1
= ptext (sLit "NB:") <+> quotes (ppr tc1)
<+> ptext (sLit "is a type function") <> (pp_inj tc1)
| otherwise = empty
where
pp_inj tc | isInjectiveTyCon tc = empty
| otherwise = ptext (sLit (", and may not be injective"))
misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
misMatchOrCND ctxt ty1 ty2
= case getUserGivens ctxt of
Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
Nothing -> misMatchMsg ty1 ty2
couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
couldNotDeduce givens wanteds
= sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
, nest 2 $ ptext (sLit "from the context")
<+> pprEvVarTheta givens]
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
addExtraInfo ctxt ty1 ty2
= ctxt { cec_tidy = env2
, cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
where
(env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
(env2, extra2) = typeExtraInfoMsg env1 ty2
misMatchMsg :: TcType -> TcType -> SDoc
misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
, nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
kindErrorMsg :: TcType -> TcType -> SDoc
kindErrorMsg ty1 ty2
= vcat [ ptext (sLit "Kind incompatibility when matching types:")
, nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
, ppr ty2 <+> dcolon <+> ppr k2 ]) ]
where
k1 = typeKind ty1
k2 = typeKind ty2
typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
typeExtraInfoMsg env ty
| Just tv <- tcGetTyVar_maybe ty
, isTcTyVar tv
, isSkolemTyVar tv || isSigTyVar tv
, not (isUnkSkol tv)
, let (env1, tv1) = tidySkolemTyVar env tv
= (env1, pprSkolTvBinding tv1)
where
typeExtraInfoMsg env _ty = (env, empty)
unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
= do { act_ty' <- zonkTcType act_ty
; exp_ty' <- zonkTcType exp_ty
; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
(env2, act_ty'') = tidyOpenType env1 act_ty'
; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
mkExpectedActualMsg :: Type -> Type -> SDoc
mkExpectedActualMsg act_ty exp_ty
= vcat [ text "Expected type" <> colon <+> ppr exp_ty
, text " Actual type" <> colon <+> ppr act_ty ]
\end{code}
Note [Noninjective type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very confusing to get a message like
Couldn't match expected type `Depend s'
against inferred type `Depend s1'
so mkTyFunInfoMsg adds:
NB: `Depend' is type function, and hence may not be injective
Warn of loopy local equalities that were dropped.
%************************************************************************
%* *
Typeclass errors
%* *
%************************************************************************
\begin{code}
reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportDictErrs ctxt wanteds orig
= do { inst_envs <- tcGetInstEnvs
; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
; unless (null others) $
addErrorReport ctxt (mk_no_inst_err others)
; mapM_ (addErrorReport ctxt) overlaps }
where
check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
check_overlap inst_envs pred@(ClassP clas tys)
= case lookupInstEnv inst_envs clas tys of
([], _) -> Left pred
([_],[])
| debugIsOn -> pprPanic "check_overlap" (ppr pred)
res -> Right (mk_overlap_msg pred res)
check_overlap _ _ = panic "check_overlap"
mk_overlap_msg pred (matches, unifiers)
= ASSERT( not (null matches) )
vcat [ addArising orig (ptext (sLit "Overlapping instances for")
<+> pprPred pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
, if not (isSingleton matches)
then
empty
else
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
ptext (sLit "when compiling the other instance declarations")])]
where
ispecs = [ispec | (ispec, _) <- matches]
mk_no_inst_err :: [PredType] -> SDoc
mk_no_inst_err wanteds
| Just givens <- getUserGivens ctxt
= vcat [ addArising orig $ couldNotDeduce givens wanteds
, show_fixes (fix1 : fixes2) ]
| otherwise
= vcat [ addArising orig $
ptext (sLit "No instance") <> plural wanteds
<+> ptext (sLit "for") <+> pprTheta wanteds
, show_fixes fixes2 ]
where
fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
<+> ptext (sLit "to the context of")
, nest 2 $ pprErrCtxtLoc ctxt ]
fixes2 | null instance_dicts = []
| otherwise = [sep [ptext (sLit "add an instance declaration for"),
pprTheta instance_dicts]]
instance_dicts = filterOut isTyVarClassPred wanteds
show_fixes :: [SDoc] -> SDoc
show_fixes [] = empty
show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt skols ambigs
= mapM_ report (equivClasses cmp ambigs_w_tvs)
where
ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
| d <- ambigs ]
cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
report pairs
= setCtLoc loc $
do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
<+> pprQuotedList tvs
<+> text "in the constraint" <> plural pairs <> colon
, nest 2 pp_wanteds ]
; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
; addErrTcM (tidy_env, main_msg $$ mono_msg) }
where
(_, tvs) : _ = pairs
(loc, pp_wanteds) = pprWithArising (map fst pairs)
mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
; return (tidy_env, mk_msg dflags docs) }
where
mk_msg _ _ | any isRuntimeUnkSkol inst_tvs
= vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
(pprWithCommas ppr inst_tvs),
ptext (sLit "Use :print or :force to determine these types")]
mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
mk_msg dflags docs
= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
nest 2 (vcat docs),
monomorphism_fix dflags]
monomorphism_fix :: DynFlags -> SDoc
monomorphism_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
if xopt Opt_MonomorphismRestriction dflags
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty]
mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
mkEnvSigMsg what env_sigs
| null env_sigs = empty
| otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
, nest 2 (vcat env_sigs) ]
findGlobals :: ReportErrCtxt
-> TcTyVarSet
-> TcM (TidyEnv, [SDoc])
findGlobals ctxt tvs
= do { lcl_ty_env <- case cec_encl ctxt of
[] -> getLclTypeEnv
(i:_) -> return (ic_env i)
; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
where
go tidy_env acc [] = return (tidy_env, acc)
go tidy_env acc (thing : things) = do
(tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
case maybe_doc of
Just d -> go tidy_env1 (d:acc) things
Nothing -> go tidy_env1 acc things
ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
find_thing :: TidyEnv -> (TcType -> Bool)
-> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
find_thing tidy_env ignore_it (ATcId { tct_id = id })
= do { id_ty <- zonkTcType (idType id)
; if ignore_it id_ty then
return (tidy_env, Nothing)
else do
{ let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
, nest 2 (parens (ptext (sLit "bound at") <+>
ppr (getSrcLoc id)))]
; return (tidy_env', Just msg) } }
find_thing tidy_env ignore_it (ATyVar tv ty)
= do { tv_ty <- zonkTcType ty
; if ignore_it tv_ty then
return (tidy_env, Nothing)
else do
{ let
(tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
, nest 2 bound_at]
eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
, getOccName tv == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
; return (tidy_env1, Just msg) } }
find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
warnDefaulting wanteds default_ty
= do { warn_default <- doptM Opt_WarnTypeDefaults
; setCtLoc loc $ warnTc warn_default warn_msg }
where
warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
quotes (ppr default_ty),
nest 2 ppr_wanteds ]
(loc, ppr_wanteds) = pprWithArising wanteds
\end{code}
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
arising from *runtime* skolems in the debugger. These
are created by in RtClosureInspect.zonkRTTIType.
%************************************************************************
%* *
Error from the canonicaliser
These ones are called *during* constraint simplification
%* *
%************************************************************************
\begin{code}
solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
solverDepthErrorTcS depth stack
| null stack
= wrapErrTcS $ failWith msg
| otherwise
= wrapErrTcS $
setCtFlavorLoc (cc_flavor top_item) $
do { env0 <- tcInitTidyEnv
; let ev_vars = map cc_id stack
env1 = tidyFreeTyVars env0 free_tvs
free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
extra = pprEvVars (map (tidyEvVar env1) ev_vars)
; failWithTcM (env1, hang msg 2 extra) }
where
top_item = head stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
flattenForAllErrorTcS fl ty _bad_eqs
= wrapErrTcS $
setCtFlavorLoc fl $
do { env0 <- tcInitTidyEnv
; let (env1, ty') = tidyOpenType env0 ty
msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
, ppr ty' ]
; failWithTcM (env1, msg) }
\end{code}
%************************************************************************
%* *
Setting the context
%* *
%************************************************************************
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
-> TcM (TidyEnv, SDoc)
getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
= do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
|| (exp `tcEqType` ty1 && act `tcEqType` ty2)
then
return (env0, empty)
else
return (env2, mkExpectedActualMsg act exp) }
getWantedEqExtra _ env0 orig _ _
= return (env0, pprArising orig)
zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
zonkSubstTidy env subst ty
= do { ty' <- zonkTcTypeAndSubst subst ty
; return (tidyOpenType env ty') }
\end{code}