\begin{code}
module TcErrors(
- reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
- reportUnsolvedWantedEvVars, warnDefaulting,
- unifyCtxt, typeExtraInfoMsg,
- kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
- occursCheckErrorTcS, solverDepthErrorTcS
+ reportUnsolved,
+ warnDefaulting,
+ unifyCtxt,
+
+ flattenForAllErrorTcS,
+ solverDepthErrorTcS
) where
#include "HsVersions.h"
import TcMType
import TcSMonad
import TcType
+import TypeRep
+import Type( isTyVarTy )
+import Unify ( tcMatchTys )
import Inst
import InstEnv
-
import TyCon
import Name
import NameEnv
-import Id ( idType )
-import HsExpr ( pprMatchContext )
+import Id ( idType, evVarPred )
import Var
import VarSet
import VarEnv
import Bag
import ListSetOps( equivClasses )
import Util
-import Unique
import FastString
import Outputable
import DynFlags
import StaticFlags( opt_PprStyle_Debug )
import Data.List( partition )
-import Control.Monad( unless )
+import Control.Monad( when, unless )
\end{code}
%************************************************************************
now?
\begin{code}
-reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
-reportUnsolved (unsolved_flats, unsolved_implics)
- | isEmptyBag unsolved
+reportUnsolved :: WantedConstraints -> TcM ()
+reportUnsolved wanted
+ | isEmptyWC wanted
= return ()
| otherwise
- = do { env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
- tidy_unsolved = tidyWanteds tidy_env unsolved
- err_ctxt = CEC { cec_encl = []
- , cec_extra = empty
- , cec_tidy = tidy_env }
- ; traceTc "reportUnsolved" (ppr unsolved)
- ; reportTidyWanteds err_ctxt tidy_unsolved }
- where
- unsolved = mkWantedConstraints unsolved_flats unsolved_implics
+ = do { -- Zonk to un-flatten any flatten-skols
+ ; wanted <- zonkWC wanted
-reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
-reportUnsolvedWantedEvVars wanteds
- | isEmptyBag wanteds
- = return ()
- | otherwise
- = do { env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
- tidy_unsolved = tidyWantedEvVars tidy_env wanteds
- err_ctxt = CEC { cec_encl = []
+ ; env0 <- tcInitTidyEnv
+ ; let tidy_env = tidyFreeTyVars env0 free_tvs
+ free_tvs = tyVarsOfWC wanted
+ err_ctxt = CEC { cec_encl = []
+ , cec_insol = insolubleWC wanted
, cec_extra = empty
- , cec_tidy = tidy_env }
- ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
+ , cec_tidy = tidy_env }
+ tidy_wanted = tidyWC tidy_env wanted
-reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
-reportUnsolvedDeriv unsolved loc
- | null unsolved
- = return ()
- | otherwise
- = setCtLoc loc $
- do { 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")]
-
-reportUnsolvedImplication :: Implication -> TcM ()
-reportUnsolvedImplication implic
- = do { env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfImplication implic)
- tidy_implic = tidyImplication tidy_env implic
- new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
- err_ctxt = CEC { cec_encl = [tidy_implic]
- , cec_extra = empty
- , cec_tidy = new_tidy_env }
- ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
- where
- -- Extend the tidy env with a mapping from tyvars to the
- -- names the user originally used. At the moment we do this
- -- from the type env, but it might be better to record the
- -- scoped type variable in the Implication. Urgh.
- add (ATyVar name ty) (occ_env, var_env)
- | Just tv <- tcGetTyVar_maybe ty
- , not (getUnique name `elemVarEnvByKey` var_env)
- = case tidyOccName occ_env (nameOccName name) of
- (occ_env', occ') -> (occ_env', extendVarEnv var_env tv tv')
- where
- tv' = setTyVarName tv name'
- name' = tidyNameOcc name occ'
- add _ tidy_env = tidy_env
+ ; traceTc "reportUnsolved" (ppr tidy_wanted)
+
+ ; reportTidyWanteds err_ctxt tidy_wanted }
+
+--------------------------------------------
+-- Internal functions
+--------------------------------------------
data ReportErrCtxt
= CEC { cec_encl :: [Implication] -- Enclosing implications
-- (innermost first)
- , cec_tidy :: TidyEnv
- , cec_extra :: SDoc -- Add this to each error message
+ , cec_tidy :: TidyEnv
+ , cec_extra :: SDoc -- Add this to each error message
+ , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
+ -- Main effect: don't say "Cannot deduce..."
+ -- when reporting equality errors; see misMatchOrCND
}
reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
reportTidyImplic ctxt implic
+ | BracketSkol <- ctLocOrigin (ic_loc implic)
+ , not insoluble -- For Template Haskell brackets report only
+ = return () -- definite errors. The whole thing will be re-checked
+ -- later when we plug it in, and meanwhile there may
+ -- certainly be un-satisfied constraints
+
+ | otherwise
= reportTidyWanteds ctxt' (ic_wanted implic)
where
- ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
-
+ insoluble = ic_insol implic
+ ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
+ , cec_insol = insoluble }
+
reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
-reportTidyWanteds ctxt unsolved
- = do { let (flats, implics) = splitWanteds unsolved
- (ambigs, others) = partition is_ambiguous (bagToList flats)
- ; groupErrs (reportFlat ctxt) others
+reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
+ | cec_insol ctxt -- If there are any insolubles, report only them
+ -- because they are unconditionally wrong
+ -- Moreover, if any of the insolubles are givens, stop right there
+ -- ignoring nested errors, because the code is inaccessible
+ = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
+ insol_implics = filterBag ic_insol implics
+ ; if isEmptyBag given
+ then do { mapBagM_ (reportInsoluble ctxt) other
+ ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
+ else mapBagM_ (reportInsoluble ctxt) given }
+
+ | otherwise -- No insoluble ones
+ = ASSERT( isEmptyBag insols )
+ do { let (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
; mapBagM_ (reportTidyImplic ctxt) implics
- ; ifErrsM (return ()) $
- -- Only report ambiguity if no other errors happened
- -- See Note [Avoiding spurious errors]
- reportAmbigErrs ctxt skols ambigs }
+
+ -- Only report ambiguity if no other errors (at all) happened
+ -- See Note [Avoiding spurious errors] in TcSimplify
+ ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
where
skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
+ -- Report equalities of form (a~ty) first. They are usually
+ -- skolem-equalities, and they cause confusing knock-on
+ -- effects in other errors; see test T4093b.
+ is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
+ = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+ | otherwise = False
+
-- Treat it as "ambiguous" if
-- (a) it is a class constraint
-- (b) it constrains only type variables
is_ambiguous d = isTyVarClassPred pred
&& not (tyVarsOfPred pred `subVarSet` skols)
where
- pred = wantedEvVarPred d
+ pred = evVarOfPred d
+
+reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
+reportInsoluble ctxt (EvVarX ev flav)
+ | EqPred ty1 ty2 <- evVarPred ev
+ = setCtFlavorLoc flav $
+ do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
+ ; reportEqErr ctxt2 ty1 ty2 }
+ | otherwise
+ = pprPanic "reportInsoluble" (pprEvVarWithType ev)
+ where
+ inaccessible_msg | Given loc GivenOrig <- flav
+ -- If a GivenSolved then we should not report inaccessible code
+ = hang (ptext (sLit "Inaccessible code in"))
+ 2 (ppr (ctLocOrigin loc))
+ | otherwise = empty
reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+-- The [PredType] are already tidied
reportFlat ctxt flats origin
= do { unless (null dicts) $ reportDictErrs ctxt dicts origin
- ; unless (null eqs) $ reportEqErrs ctxt eqs
+ ; unless (null eqs) $ reportEqErrs ctxt eqs origin
; unless (null ips) $ reportIPErrs ctxt ips origin
; ASSERT( null others ) return () }
where
groupErrs _ []
= return ()
groupErrs report_err (wanted : wanteds)
- = do { setCtLoc the_loc $
+ = do { setCtLoc the_loc $
report_err the_vars (ctLocOrigin the_loc)
; groupErrs report_err others }
where
- the_loc = wantedEvVarLoc wanted
+ the_loc = evVarX wanted
the_key = mk_key the_loc
- the_vars = map wantedEvVarPred (wanted:friends)
+ the_vars = map evVarOfPred (wanted:friends)
(friends, others) = partition is_friend wanteds
- is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
+ is_friend friend = mk_key (evVarX friend) `same_key` the_key
+
+ mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
+ mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
+
+ same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
+ same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
+ same_orig ScOrigin ScOrigin = True
+ same_orig DerivOrigin DerivOrigin = True
+ same_orig DefaultOrigin DefaultOrigin = True
+ same_orig _ _ = False
- mk_key :: WantedLoc -> (SrcSpan, String)
- mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
- -- It may seem crude to compare the error messages,
- -- but it makes sure that we combine just what the user sees,
- -- and it avoids need equality on InstLocs.
-- Add the "arising from..." part to a message about bunch of dicts
addArising :: CtOrigin -> SDoc -> SDoc
pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
-- Print something like
-- (Eq a) arising from a use of x at y
--- (Show a) arising froma use of p at q
--- Also return a location for the erroe message
+-- (Show a) arising from a use of p at q
+-- Also return a location for the error message
pprWithArising []
= panic "pprWithArising"
-pprWithArising [WantedEvVar ev loc]
+pprWithArising [EvVarX 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
+ first_loc = evVarX (head ev_vars)
+ ppr_one (EvVarX v loc)
+ = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
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
-
-couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
-couldNotDeduce givens wanteds
- = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
- , nest 2 $ ptext (sLit "from the context")
- <+> pprEvVarTheta givens]
+ ppr_skol skol_info = ppr skol_info
-getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
--- Just gs => Say "could not deduce ... from gs"
--- Nothing => No interesting givens, say something else
+getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
+-- One item for each enclosing implication
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
- -- In user mode, don't show the "self-dict" given
- -- which is only added to do co-inductive solving
- -- Rather an awkward hack, but there we are
- -- This is the only use of isSelfDict, so it's not in an inner loop
+ = reverse $
+ [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
+ , let givens' = get_user_givens givens
+ , not (null givens') ]
+ where
+ get_user_givens givens | opt_PprStyle_Debug = givens
+ | otherwise = filterOut isSilentEvVar givens
+ -- In user mode, don't show the "silent" givens, used for
+ -- the "self" dictionary and silent superclass arguments for dfuns
+
\end{code}
\begin{code}
reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportIPErrs ctxt ips orig
- = addErrorReport ctxt $ addArising orig msg
+ = addErrorReport ctxt msg
where
- msg | Just givens <- getUserGivens ctxt
- = couldNotDeduce givens ips
- | otherwise
- = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
+ givens = getUserGivens ctxt
+ msg | null givens
+ = addArising orig $
+ sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
, nest 2 (pprTheta ips) ]
+ | otherwise
+ = couldNotDeduce givens (ips, orig)
\end{code}
%************************************************************************
\begin{code}
-reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM ()
-reportEqErrs ctxt eqs
- = mapM_ report_one eqs
+reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+-- The [PredType] are already tidied
+reportEqErrs ctxt eqs orig
+ = do { orig' <- zonkTidyOrigin ctxt orig
+ ; mapM_ (report_one orig') eqs }
where
- report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2
- report_one pred = pprPanic "reportEqErrs" (ppr pred)
+ report_one orig (EqPred ty1 ty2)
+ = do { let extra = getWantedEqExtra orig ty1 ty2
+ ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
+ ; reportEqErr ctxt' ty1 ty2 }
+ report_one _ pred
+ = pprPanic "reportEqErrs" (ppr pred)
+
+getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
+getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
+ ty1 ty2
+ -- If the types in the error message are the same as the types we are unifying,
+ -- don't add the extra expected/actual message
+ | act `eqType` ty1 && exp `eqType` ty2 = empty
+ | exp `eqType` ty1 && act `eqType` ty2 = empty
+ | otherwise = mkExpectedActualMsg act exp
+
+getWantedEqExtra orig _ _ = pprArising orig
reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
+-- ty1 and ty2 are already tidied
reportEqErr ctxt ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
| Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
+
| otherwise -- Neither side is a type variable
-- Since the unsolved constraint is canonical,
-- it must therefore be of form (F tys ~ ty)
- = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
- where
- msg = case getUserGivens ctxt of
- Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
- Nothing -> misMatchMsg ty1 ty2
+ = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
+
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
+-- tv1 and ty2 are already tidied
reportTyVarEqErr ctxt tv1 ty2
- | not is_meta1
- , Just tv2 <- tcGetTyVar_maybe ty2
- , isMetaTyVar tv2
- = -- sk ~ alpha: swap
- reportTyVarEqErr ctxt tv2 ty1
-
- | not is_meta1
- = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
- addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+ | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would
+ -- be oriented the other way round; see TcCanonical.reOrient
+ || isSigTyVar tv1 && not (isTyVarTy ty2)
+ = addErrorReport (addExtraInfo ctxt ty1 ty2)
+ (misMatchOrCND ctxt ty1 ty2)
-- So tv is a meta tyvar, and presumably it is
-- an *untouchable* meta tyvar, else it'd have been unified
| not (k2 `isSubKind` k1) -- Kind error
= addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
+ -- Occurs check
+ | 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
+
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
-- place the equality arose to the implication site
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
+ esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
+ <+> pprQuotedList esc_skols
+ , ptext (sLit "would escape") <+>
+ if isSingleton esc_skols then ptext (sLit "its scope")
+ else ptext (sLit "their scope") ]
+ extra1 = vcat [ nest 2 $ esc_doc
, sep [ (if isSingleton esc_skols
- then ptext (sLit "This skolem is")
- else ptext (sLit "These skolems are"))
+ then ptext (sLit "This (rigid, skolem) type variable is")
+ else ptext (sLit "These (rigid, skolem) type variables are"))
<+> ptext (sLit "bound by")
- , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
+ , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
-- Nastiest case: attempt to unify an untouchable variable
, let implic_loc = ic_loc implic
given = ic_given implic
= setCtLoc (ic_loc implic) $
- do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
- extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
- , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
- , nest 2 (ptext (sLit "bound at")
- <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
- ; addErrTcM (env1, msg $$ extra) }
-
- | otherwise -- I'm not sure how this can happen!
- = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+ 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") <+> ppr (ctLocOrigin implic_loc)]
+ ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
+
+ | otherwise
+ = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
+ return ()
+ -- I don't think this should happen, and if it does I want to know
+ -- Trac #5130 happened because an actual type error was not
+ -- reported at all! So not reporting is pretty dangerous.
+ --
+ -- OLD, OUT OF DATE COMMENT
+ -- This can happen, by a recursive decomposition of frozen
+ -- occurs check constraints
+ -- Example: alpha ~ T Int alpha has frozen.
+ -- Then alpha gets unified to T beta gamma
+ -- So now we have T beta gamma ~ T Int (T beta gamma)
+ -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
+ -- The (gamma ~ T beta gamma) is the occurs check, but
+ -- the (beta ~ Int) isn't an error at all. So return ()
where
- is_meta1 = isMetaTyVar tv1
- k1 = tyVarKind tv1
- k2 = typeKind ty2
- ty1 = mkTyVarTy tv1
+ k1 = tyVarKind tv1
+ k2 = typeKind ty2
+ ty1 = mkTyVarTy tv1
mkTyFunInfoMsg :: TcType -> TcType -> SDoc
-- See Note [Non-injective type functions]
pp_inj tc | isInjectiveTyCon tc = empty
| otherwise = ptext (sLit (", and may not be injective"))
-misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
--- This version is used by TcSimplify too, which doesn't track the
--- expected/acutal thing, so we just have ty1 ty2 here
--- NB: The types are already tidied
-misMatchMsgWithExtras env ty1 ty2
- = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
+misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
+misMatchOrCND ctxt ty1 ty2
+ | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
+ -- insoluble, don't report the context
+ | null givens = misMatchMsg ty1 ty2
+ | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
where
- (env1, extra1) = typeExtraInfoMsg env ty1
- (env2, extra2) = typeExtraInfoMsg env1 ty2
+ givens = getUserGivens ctxt
+ orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
+
+couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
+couldNotDeduce givens (wanteds, orig)
+ = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
+ 2 (pprArising orig)
+ , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens
+ = case givens of
+ [] -> []
+ (g:gs) -> ppr_given (ptext (sLit "from the context")) g
+ : map (ppr_given (ptext (sLit "or from"))) gs
+ where ppr_given herald (gs,loc)
+ = hang (herald <+> pprEvVarTheta gs)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+
+addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
+-- Add on extra info about the types themselves
+-- NB: The types themselves are already tidied
+addExtraInfo ctxt ty1 ty2
+ = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
+ where
+ extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
+ extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
k1 = typeKind ty1
k2 = typeKind ty2
-typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
+typeExtraInfoMsg :: [Implication] -> Type -> SDoc
-- Shows a bit of extra info about skolem constants
-typeExtraInfoMsg env ty
+typeExtraInfoMsg implics ty
| Just tv <- tcGetTyVar_maybe ty
- , isTcTyVar tv
- , isSkolemTyVar tv || isSigTyVar tv
- , not (isUnk tv)
- , let (env1, tv1) = tidySkolemTyVar env tv
- = (env1, pprSkolTvBinding tv1)
- where
-typeExtraInfoMsg env _ty = (env, empty) -- Normal case
-
+ , isTcTyVar tv, isSkolemTyVar tv
+ , let pp_tv = quotes (ppr tv)
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
+ FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
+ RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
+ MetaTv {} -> empty
+
+ | otherwise -- Normal case
+ = empty
+
+ where
+ ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful
+ ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"),
+ sep [ppr info, ptext (sLit "at") <+> ppr loc]]
+
--------------------
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'') }
+ = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
+ ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
+ ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
mkExpectedActualMsg :: Type -> Type -> SDoc
mkExpectedActualMsg act_ty exp_ty
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 }
+ ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
+ ; unless (null non_overlaps) $
+ addErrorReport ctxt (mk_no_inst_err non_overlaps) }
where
- check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
- -- Right msg => overlap message
- -- Left inst => no instance
- check_overlap inst_envs pred@(ClassP clas tys)
- = case lookupInstEnv inst_envs clas tys of
- ([], _) -> Left pred -- No match
+ mk_no_inst_err :: [PredType] -> SDoc
+ mk_no_inst_err wanteds
+ | null givens -- Top level
+ = vcat [ addArising orig $
+ ptext (sLit "No instance") <> plural min_wanteds
+ <+> ptext (sLit "for") <+> pprTheta min_wanteds
+ , show_fixes (fixes2 ++ fixes3) ]
+
+ | otherwise
+ = vcat [ couldNotDeduce givens (min_wanteds, orig)
+ , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
+ where
+ givens = getUserGivens ctxt
+ min_wanteds = mkMinimalBySCs wanteds
+ fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
+ <+> ptext (sLit "to the context of")
+ , nest 2 $ pprErrCtxtLoc ctxt ]
+
+ fixes2 = case instance_dicts of
+ [] -> []
+ [_] -> [sep [ptext (sLit "add an instance declaration for"),
+ pprTheta instance_dicts]]
+ _ -> [sep [ptext (sLit "add instance declarations for"),
+ pprTheta instance_dicts]]
+ fixes3 = case orig of
+ DerivOrigin -> [drv_fix]
+ _ -> []
+
+ instance_dicts = filterOut isTyVarClassPred min_wanteds
+ -- Insts for which it is worth suggesting an adding an
+ -- instance declaration. Exclude tyvar dicts.
+
+ drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
+ nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
+
+ 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))]
+
+reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
+ -> PredType -> TcM (Maybe PredType)
+-- Report an overlap error if this class constraint results
+-- from an overlap (returning Nothing), otherwise return (Just pred)
+reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
+ = do { tys_flat <- mapM quickFlattenTy tys
+ -- Note [Flattening in error message generation]
+
+ ; case lookupInstEnv inst_envs clas tys_flat of
+ ([], _) -> return (Just pred) -- No match
-- The case of exactly one match and no unifiers means a
-- successful lookup. That can't happen here, because dicts
-- only end up here if they didn't match in Inst.lookupInst
([_],[])
| debugIsOn -> pprPanic "check_overlap" (ppr pred)
- res -> Right (mk_overlap_msg pred res)
- check_overlap _ _ = panic "check_overlap"
-
- mk_overlap_msg pred (matches, unifiers)
+ res -> do { addErrorReport ctxt (mk_overlap_msg res)
+ ; return Nothing } }
+ where
+ mk_overlap_msg (matches, unifiers)
= ASSERT( not (null matches) )
vcat [ addArising orig (ptext (sLit "Overlapping instances for")
- <+> pprPred pred)
+ <+> pprPredTy pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+ , if not (null overlapping_givens) then
+ sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+ else empty
+
+ , if null overlapping_givens && isSingleton matches && null unifiers then
+ -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
+ -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+ -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+ sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+ else empty
+
, if not (isSingleton matches)
then -- Two or more matches
empty
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")])]
+ if null (overlapping_givens) then
+ vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+ ptext (sLit "when compiling the other instance declarations")]
+ else empty])]
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 -- Top level
- = 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 ]
+ givens = getUserGivens ctxt
+ overlapping_givens = unifiable_givens givens
+
+ unifiable_givens [] = []
+ unifiable_givens (gg:ggs)
+ | Just ggdoc <- matchable gg
+ = ggdoc : unifiable_givens ggs
+ | otherwise
+ = unifiable_givens ggs
+
+ matchable (evvars,gloc)
+ = case ev_vars_matching of
+ [] -> Nothing
+ _ -> Just $ hang (pprTheta ev_vars_matching)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+ where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+ ev_var_matches (ClassP clas' tys')
+ | clas' == clas
+ , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+ = True
+ ev_var_matches (ClassP clas' tys') =
+ any ev_var_matches (immSuperClasses clas' tys')
+ ev_var_matches _ = False
+
+
+reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
+
+----------------------
+quickFlattenTy :: TcType -> TcM TcType
+-- See Note [Flattening in error message generation]
+quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
+quickFlattenTy ty@(TyVarTy {}) = return ty
+quickFlattenTy ty@(ForAllTy {}) = return ty -- See
+quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
+ -- Don't flatten because of the danger or removing a bound variable
+quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
+ ; fy2 <- quickFlattenTy ty2
+ ; return (AppTy fy1 fy2) }
+quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
+ ; fy2 <- quickFlattenTy ty2
+ ; return (FunTy fy1 fy2) }
+quickFlattenTy (TyConApp tc tys)
+ | not (isSynFamilyTyCon tc)
+ = do { fys <- mapM quickFlattenTy tys
+ ; return (TyConApp tc fys) }
+ | otherwise
+ = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
+ -- Ignore the arguments of the type family funtys
+ ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
+ ; flat_resttys <- mapM quickFlattenTy resttys
+ ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
+\end{code}
- fixes2 | null instance_dicts = []
- | otherwise = [sep [ptext (sLit "add an instance declaration for"),
- pprTheta instance_dicts]]
- instance_dicts = filterOut isTyVarClassPred wanteds
- -- Insts for which it is worth suggesting an adding an
- -- instance declaration. Exclude tyvar dicts.
-
- 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))]
+Note [Flattening in error message generation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (C (Maybe (F x))), where F is a type function, and we have
+instances
+ C (Maybe Int) and C (Maybe a)
+Since (F x) might turn into Int, this is an overlap situation, and
+indeed (because of flattening) the main solver will have refrained
+from solving. But by the time we get to error message generation, we've
+un-flattened the constraint. So we must *re*-flatten it before looking
+up in the instance environment, lest we only report one matching
+instance when in fact there are two.
+
+Re-flattening is pretty easy, because we don't need to keep track of
+evidence. We don't re-use the code in TcCanonical because that's in
+the TcS monad, and we are in TcM here.
+
+Note [Quick-flatten polytypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
+flattening any further. After all, there can be no instance declarations
+that match such things. And flattening under a for-all is problematic
+anyway; consider C (forall a. F a)
+\begin{code}
reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt skols ambigs
-- Divide into groups that share a common set of ambiguous tyvars
= mapM_ report (equivClasses cmp ambigs_w_tvs)
where
- ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
+ ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
| d <- ambigs ]
cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
- ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
+ ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
; return (tidy_env, mk_msg dflags docs) }
where
- mk_msg _ _ | any isRuntimeUnk inst_tvs
+ mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
= vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
(pprWithCommas ppr inst_tvs),
ptext (sLit "Use :print or :force to determine these types")]
monomorphism_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
- if dopt Opt_MonomorphismRestriction dflags
+ if xopt Opt_MonomorphismRestriction dflags
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
+getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
+getSkolemInfo [] tv
+ = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
+ UnkSkol
+getSkolemInfo (implic:implics) tv
+ | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
+ | otherwise = getSkolemInfo implics tv
-----------------------
-- findGlobals looks at the value environment and finds values whose
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
+ = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
+ ; if ignore_it tidy_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
+ { let 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
+ = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
+ ; if ignore_it tidy_ty then
return (tidy_env, Nothing)
else do
{ let -- The name tv is scoped, so we don't need to tidy it
- (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
+ eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
, getOccName tv == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
-warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
+warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
warnDefaulting wanteds default_ty
= do { warn_default <- doptM Opt_WarnTypeDefaults
+ ; env0 <- tcInitTidyEnv
+ ; let wanted_bag = listToBag wanteds
+ tidy_env = tidyFreeTyVars env0 $
+ tyVarsOfEvVarXs wanted_bag
+ tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
+ (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
+ warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
+ <+> quotes (ppr default_ty))
+ 2 ppr_wanteds
; setCtLoc loc $ warnTc warn_default warn_msg }
where
- -- Tidy them first
- 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
+ get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
+ get_wev ev = pprPanic "warnDefaulting" (ppr ev)
\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}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
--- If there's a kind error, we don't want to blindly say "kind error"
--- We might, say, be unifying a skolem 'a' with a type 'Int',
--- in which case that's the error to report. So we set things
--- up to call reportEqErr, which does the business properly
-kindErrorTcS fl ty1 ty2
- = wrapErrTcS $
- setCtFlavorLoc fl $
- do { (env0, extra) <- getEqExtra fl ty1 ty2
- ; let (env1, ty1') = tidyOpenType env0 ty1
- (env2, ty2') = tidyOpenType env1 ty2
- ctxt = CEC { cec_encl = []
- , cec_extra = extra
- , cec_tidy = env2 }
- ; reportEqErr ctxt ty1' ty2' }
-
-misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
-misMatchErrorTcS fl ty1 ty2
- = wrapErrTcS $
- setCtFlavorLoc fl $
- do { (env0, extra) <- getEqExtra fl ty1 ty2
- ; let (env1, ty1') = tidyOpenType env0 ty1
- (env2, ty2') = tidyOpenType env1 ty2
- (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2'
- ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) }
- where
- inaccessible_msg
- = case fl of
- Given loc -> hang (ptext (sLit "Inaccessible code in"))
- 2 (mk_what loc)
- _ -> 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
-
-occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
-occursCheckErrorTcS fl tv ty
- = wrapErrTcS $
- setCtFlavorLoc fl $
- do { (env0, extra2) <- getEqExtra fl (mkTyVarTy tv) ty
- ; let (env1, tv') = tidyOpenTyVar env0 tv
- (env2, ty') = tidyOpenType env1 ty
- extra1 = sep [ppr tv', char '=', ppr ty']
- ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) }
- where
- msg = text $ "Occurs check: cannot construct the infinite type:"
-
solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
solverDepthErrorTcS depth stack
| null stack -- Shouldn't happen unless you say -fcontext-stack=0
| 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) }
+ do { ev_vars <- mapM (zonkEvVar . cc_id) stack
+ ; env0 <- tcInitTidyEnv
+ ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
+ tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
+ ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
where
top_item = head stack
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
\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
-
-getEqExtra :: CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc)
-getEqExtra (Wanted loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2
-getEqExtra (Derived loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2
-getEqExtra (Given _) _ _ = do { env0 <- tcInitTidyEnv
- ; return (env0, empty) }
- -- We could print more info, but it seems to be already coming out
-
-getWantedEqExtra :: CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc)
-getWantedEqExtra (TypeEqOrigin item) ty1 ty2
- -- If the types in the error message are the same
- -- as the types we are unifying (remember to zonk the latter)
- -- don't add the extra expected/actual message
- = do { act <- zonkTcType (uo_actual item)
- ; exp <- zonkTcType (uo_expected item)
- ; env0 <- tcInitTidyEnv
- ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
- || (exp `tcEqType` ty1 && act `tcEqType` ty2)
- then
- return (env0, empty)
- else do
- { let (env1, exp') = tidyOpenType env0 exp
- (env2, act') = tidyOpenType env1 act
- ; return (env2, mkExpectedActualMsg act' exp') } }
+setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
+\end{code}
-getWantedEqExtra orig _ _
- = do { env0 <- tcInitTidyEnv
- ; return (env0, pprArising orig) }
+%************************************************************************
+%* *
+ Tidying
+%* *
+%************************************************************************
+
+\begin{code}
+zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
+zonkTidyTcType env ty = do { ty' <- zonkTcType ty
+ ; return (tidyOpenType env ty') }
+
+zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
+zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
+ = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
+ ; (_env2, exp') <- zonkTidyTcType env1 exp
+ ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
+ -- Drop the returned env on the floor; we may conceivably thereby get
+ -- inconsistent naming between uses of this function
+zonkTidyOrigin _ orig = return orig
\end{code}
projects / ghc-hetmet.git / blobdiff