import DynFlags
import StaticFlags( opt_PprStyle_Debug )
import Data.List( partition )
-import Control.Monad( unless )
+import Control.Monad( when, unless )
\end{code}
%************************************************************************
reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportTidyWanteds ctxt unsolved
- = do { let (flats, implics) = splitWanteds unsolved
- (ambigs, others) = partition is_ambiguous (bagToList flats)
- ; 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 }
+ = 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
+ ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
+
+ -- 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 <- wantedEvVarPred c
+ = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+ | otherwise = False
+
-- Treat it as "ambiguous" if
-- (a) it is a class constraint
-- (b) it constrains only type variables
pred = wantedEvVarPred d
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 origin
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]
-
getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
-- Just gs => Say "could not deduce ... from gs"
-- Nothing => No interesting givens, say something else
\begin{code}
reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+-- The [PredType] are already tidied
reportEqErrs ctxt eqs orig
= mapM_ report_one eqs
where
= pprPanic "reportEqErrs" (ppr pred)
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
| not is_meta1
= -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
- addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+ addErrTcM (addExtraInfo (misMatchOrCND ctxt ty1 ty2)
+ (cec_tidy ctxt) ty1 ty2)
-- So tv is a meta tyvar, and presumably it is
-- an *untouchable* meta tyvar, else it'd have been unified
, let implic_loc = ic_loc implic
given = ic_given implic
= setCtLoc (ic_loc implic) $
- do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
+ do { let (env1, msg) = addExtraInfo (misMatchMsg ty1 ty2) (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")
; addErrTcM (env1, msg $$ extra) }
| otherwise -- I'm not sure how this can happen!
- = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+ = addErrTcM (addExtraInfo (misMatchMsg ty1 ty2) (cec_tidy ctxt) ty1 ty2)
where
is_meta1 = isMetaTyVar tv1
k1 = tyVarKind tv1
pp_inj tc | isInjectiveTyCon tc = empty
| otherwise = ptext (sLit (", and may not be injective"))
-misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
+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 :: SDoc -> 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) ])
+addExtraInfo msg env ty1 ty2
+ = (env2, msg $$ nest 2 (extra1 $$ extra2))
where
(env1, extra1) = typeExtraInfoMsg env ty1
(env2, extra2) = typeExtraInfoMsg env1 ty2
| Just tv <- tcGetTyVar_maybe ty
, isTcTyVar tv
, isSkolemTyVar tv || isSigTyVar tv
- , not (isUnk tv)
+ , not (isUnkSkol tv)
, let (env1, tv1) = tidySkolemTyVar env tv
= (env1, pprSkolTvBinding tv1)
where
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
- ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
+ ; 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 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")]
(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
%************************************************************************
\begin{code}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
-- 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
do { let ctxt = CEC { cec_encl = []
, cec_extra = extra
, cec_tidy = env0 }
- ; reportEqErr ctxt ty1 ty2 }
+ ; reportEqErr ctxt ty1 ty2
+ ; failM
+ }
misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
misMatchErrorTcS fl ty1 ty2
= wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
- do { let (env1, msg) = misMatchMsgWithExtras env0 ty1 ty2
- ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
+ do { let msg = inaccessible_msg $$ misMatchMsg ty1 ty2
+ (env1, msg1) = addExtraInfo msg env0 ty1 ty2
+ ; failWithTcM (env1, msg1 $$ extra) }
where
inaccessible_msg
= case fl of
\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
+setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
wrapEqErrTcS :: CtFlavor -> TcType -> TcType
-> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
(ctLocOrigin loc) ty1 ty2
; thing_inside env3 ty1 ty2 extra }
; case fl of
- Wanted loc -> do_wanted loc
- Derived loc -> do_wanted loc
- Given {} -> thing_inside env2 ty1 ty2 empty
- -- We could print more info, but it
+ Wanted loc -> do_wanted loc
+ Derived loc _ -> do_wanted loc
+ Given {} -> thing_inside env2 ty1 ty2 empty
+ -- We could print more info, but it
-- seems to be coming out already
} }
where
projects / ghc-hetmet.git / blobdiff