Commit af2e0d24 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor type errors a bit

Improves kind error messages in paticular
parent 463e8908
......@@ -527,7 +527,8 @@ canEqLeafOriented :: CtFlavor -> CoVar
-- First argument is not OtherCls
canEqLeafOriented fl cv cls1@(FunCls fn tys) s2
| not (kindAppResult (tyConKind fn) tys `eqKind` typeKind s2 )
= kindErrorTcS fl (unClassify cls1) s2
= do { kindErrorTcS fl (unClassify cls1) s2
; return emptyCCan }
| otherwise
= ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
do { (xis1,ccs1) <- flattenMany fl tys -- flatten type function arguments
......@@ -544,7 +545,8 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys) s2
canEqLeafOriented fl cv (VarCls tv) s2
| not (k1 `eqKind` k2 || (isMetaTyVar tv && k2 `isSubKind` k1))
-- Establish the kind invariant for CTyEqCan
= kindErrorTcS fl (mkTyVarTy tv) s2
= do { kindErrorTcS fl (mkTyVarTy tv) s2
; return emptyCCan }
| otherwise
= do { (xi2,ccs2) <- flatten fl s2 -- flatten RHS
......
\begin{code}
module TcErrors(
reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg,
reportUnsolvedWantedEvVars, warnDefaulting,
unifyCtxt, typeExtraInfoMsg,
kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
occursCheckErrorTcS, solverDepthErrorTcS
) where
......@@ -81,13 +82,14 @@ reportUnsolvedDeriv unsolved loc
| null unsolved
= return ()
| otherwise
= do { env0 <- tcInitTidyEnv
= 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 loc }
; 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")]
......@@ -153,11 +155,11 @@ reportTidyWanteds ctxt unsolved
where
pred = wantedEvVarPred d
reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
reportFlat ctxt flats loc
= do { unless (null dicts) $ reportDictErrs ctxt dicts loc
; unless (null eqs) $ reportEqErrs ctxt eqs loc
; unless (null ips) $ reportIPErrs ctxt ips loc
reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportFlat ctxt flats origin
= do { unless (null dicts) $ reportDictErrs ctxt dicts origin
; unless (null eqs) $ reportEqErrs ctxt eqs
; unless (null ips) $ reportIPErrs ctxt ips origin
; ASSERT( null others ) return () }
where
(dicts, non_dicts) = partition isClassPred flats
......@@ -168,8 +170,8 @@ reportFlat ctxt flats loc
-- Support code
--------------------------------------------
groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
-> [WantedEvVar] -- Unsolved wanteds
groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
-> [WantedEvVar] -- Unsolved wanteds
-> TcM ()
-- Group together insts with the same origin
-- We want to report them together in error messages
......@@ -177,7 +179,8 @@ groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
groupErrs _ []
= return ()
groupErrs report_err (wanted : wanteds)
= do { setCtLoc the_loc $ report_err the_vars the_loc
= do { setCtLoc the_loc $
report_err the_vars (ctLocOrigin the_loc)
; groupErrs report_err others }
where
the_loc = wantedEvVarLoc wanted
......@@ -193,8 +196,8 @@ groupErrs report_err (wanted : wanteds)
-- and it avoids need equality on InstLocs.
-- Add the "arising from..." part to a message about bunch of dicts
addArising :: WantedLoc -> SDoc -> SDoc
addArising loc msg = msg $$ nest 2 (pprArising loc)
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig msg = msg $$ nest 2 (pprArising orig)
pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
-- Print something like
......@@ -204,7 +207,7 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
pprWithArising []
= panic "pprWithArising"
pprWithArising [WantedEvVar ev loc]
= (loc, pprEvVarTheta [ev] <+> pprArising loc)
= (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
pprWithArising ev_vars
= (first_loc, vcat (map ppr_one ev_vars))
where
......@@ -255,9 +258,9 @@ getUserGivens (CEC {cec_encl = ctxt})
%************************************************************************
\begin{code}
reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
reportIPErrs ctxt ips loc
= addErrorReport ctxt $ addArising loc msg
reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportIPErrs ctxt ips orig
= addErrorReport ctxt $ addArising orig msg
where
msg | Just givens <- getUserGivens ctxt
= couldNotDeduce givens ips
......@@ -274,32 +277,33 @@ reportIPErrs ctxt ips loc
%************************************************************************
\begin{code}
reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs
reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM ()
reportEqErrs ctxt eqs
= mapM_ report_one eqs
where
report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2
report_one pred = pprPanic "reportEqErrs" (ppr pred)
reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM ()
reportEqErr ctxt loc pred@(EqPred ty1 ty2)
| Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2
| Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1
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 -- 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 [pred]
Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
Nothing -> misMatchMsg ty1 ty2
reportEqErr _ _ _ = panic "reportEqErr" -- Must be equality pred
reportTyVarEqErr :: ReportErrCtxt -> WantedLoc
-> TcTyVar -> TcType -> TcM ()
reportTyVarEqErr ctxt loc tv1 ty2
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
reportTyVarEqErr ctxt tv1 ty2
| not is_meta1
, Just tv2 <- tcGetTyVar_maybe ty2
, isMetaTyVar tv2
= -- sk ~ alpha: swap
reportTyVarEqErr ctxt loc tv2 ty1
reportTyVarEqErr ctxt tv2 ty1
| not is_meta1
= -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
......@@ -398,6 +402,20 @@ typeExtraInfoMsg env ty
= (env1, pprSkolTvBinding tv1)
where
typeExtraInfoMsg env _ty = (env, empty) -- Normal case
--------------------
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 [Non-injective type functions]
......@@ -418,8 +436,8 @@ Warn of loopy local equalities that were dropped.
%************************************************************************
\begin{code}
reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
reportDictErrs ctxt wanteds loc
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) $
......@@ -442,7 +460,7 @@ reportDictErrs ctxt wanteds loc
mk_overlap_msg pred (matches, unifiers)
= ASSERT( not (null matches) )
vcat [ addArising loc (ptext (sLit "Overlapping instances for")
vcat [ addArising orig (ptext (sLit "Overlapping instances for")
<+> pprPred pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
......@@ -461,11 +479,11 @@ reportDictErrs ctxt wanteds loc
mk_no_inst_err :: [PredType] -> SDoc
mk_no_inst_err wanteds
| Just givens <- getUserGivens ctxt
= vcat [ addArising loc $ couldNotDeduce givens wanteds
= vcat [ addArising orig $ couldNotDeduce givens wanteds
, show_fixes (fix1 : fixes2) ]
| otherwise -- Top level
= vcat [ addArising loc $
= vcat [ addArising orig $
ptext (sLit "No instance") <> plural wanteds
<+> ptext (sLit "for") <+> pprTheta wanteds
, show_fixes fixes2 ]
......@@ -626,19 +644,27 @@ warnDefaulting wanteds default_ty
%************************************************************************
\begin{code}
kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
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 <- tcInitTidyEnv
; let (env1, ty1') = tidyOpenType env0 ty1
(env2, ty2') = tidyOpenType env1 ty2
; failWithTcM (env2, kindErrorMsg ty1' ty2') }
ctxt = CEC { cec_encl = []
, cec_extra = empty
, cec_tidy = env2 }
; reportEqErr ctxt ty1' ty2' }
misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
misMatchErrorTcS fl ty1 ty2
= wrapErrTcS $
setCtFlavorLoc fl $
= wrapErrTcS $
setCtFlavorLocNoEq fl $ -- Don't add the "When matching t1 with t2"
-- part, because it duplciates what we say now
do { env0 <- tcInitTidyEnv
; let (env1, ty1') = tidyOpenType env0 ty1
(env2, ty2') = tidyOpenType env1 ty2
......@@ -669,11 +695,6 @@ occursCheckErrorTcS fl tv ty
where
msg = text $ "Occurs check: cannot construct the infinite type:"
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
solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
solverDepthErrorTcS depth stack
| null stack -- Shouldn't happen unless you say -fcontext-stack=0
......@@ -694,7 +715,7 @@ solverDepthErrorTcS depth stack
flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
flattenForAllErrorTcS fl ty _bad_eqs
= wrapErrTcS $
= wrapErrTcS $
setCtFlavorLoc fl $
do { env0 <- tcInitTidyEnv
; let (env1, ty') = tidyOpenType env0 ty
......@@ -702,3 +723,38 @@ flattenForAllErrorTcS fl ty _bad_eqs
, ppr ty' ]
; failWithTcM (env1, msg) }
\end{code}
%************************************************************************
%* *
Setting the context
%* *
%************************************************************************
\begin{code}
setCtFlavorLocNoEq :: CtFlavor -> TcM a -> TcM a
setCtFlavorLocNoEq (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLocNoEq (Derived loc) thing = setCtLoc loc thing
setCtFlavorLocNoEq (Given loc) thing = setCtLoc loc thing
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
setCtFlavorLoc (Wanted loc) thing = setWantedLoc loc thing
setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing
setCtFlavorLoc (Given loc) thing = setGivenLoc loc thing
setWantedLoc :: WantedLoc -> TcM a -> TcM a
setWantedLoc loc thing_inside
= setCtLoc loc $
add_origin (ctLocOrigin loc) $
thing_inside
where
add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item)
add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig)
setGivenLoc :: GivenLoc -> TcM a -> TcM a
setGivenLoc loc thing_inside
= setCtLoc loc $
add_origin (ctLocOrigin loc) $
thing_inside
where
add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol)
\end{code}
......@@ -848,13 +848,12 @@ ctLocOrigin (CtLoc o _ _) = o
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
pprArising :: CtLoc CtOrigin -> SDoc
pprArising loc = case ctLocOrigin loc of
TypeEqOrigin -> empty
_ -> text "arising from" <+> ppr (ctLocOrigin loc)
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {}) = empty
pprArising orig = text "arising from" <+> ppr orig
pprArisingAt :: CtLoc CtOrigin -> SDoc
pprArisingAt loc = sep [pprArising loc, text "at" <+> ppr (ctLocSpan loc)]
pprArisingAt (CtLoc o s _) = sep [pprArising o, text "at" <+> ppr s]
-------------------------------------------
-- CtOrigin gives the origin of *wanted* constraints
......@@ -864,7 +863,7 @@ data CtOrigin
| SpecPragOrigin Name -- Specialisation pragma for identifier
| TypeEqOrigin
| TypeEqOrigin EqOrigin
| IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter
......@@ -919,7 +918,7 @@ pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
pprO DefaultOrigin = ptext (sLit "a 'default' declaration")
pprO DoOrigin = ptext (sLit "a do statement")
pprO ProcOrigin = ptext (sLit "a proc expression")
pprO TypeEqOrigin = ptext (sLit "an equality")
pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq
pprO AnnOrigin = ptext (sLit "an annotation")
instance Outputable EqOrigin where
......
......@@ -787,7 +787,8 @@ defaultTyVar untch the_tv
, not (the_tv `elemVarSet` untch)
, not (k `eqKind` default_k)
= do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
; let loc = CtLoc TypeEqOrigin (getSrcSpan the_tv) [] -- Yuk
; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
-- 'DefaultOrigin' is strictly the declaration, but it's convenient
wanted_eq = CTyEqCan { cc_id = ev
, cc_flavor = Wanted loc
, cc_tyvar = the_tv
......
......@@ -14,9 +14,6 @@ module TcUnify (
-- Various unifications
unifyType, unifyTypeList, unifyTheta, unifyKind,
-- Occurs check error
typeExtraInfoMsg, emitMisMatchErr,
--------------------------------
-- Holes
tcInfer,
......@@ -31,7 +28,7 @@ module TcUnify (
import HsSyn
import TypeRep
import TcErrors ( typeExtraInfoMsg )
import TcErrors ( typeExtraInfoMsg, unifyCtxt )
import TcMType
import TcEnv
import TcIface
......@@ -526,13 +523,15 @@ uType, uType_np, uType_defer
--------------
-- It is always safe to defer unification to the main constraint solver
-- See Note [Deferred unification]
uType_defer origin ty1 ty2
uType_defer (item : origin) ty1 ty2
= do { co_var <- newWantedCoVar ty1 ty2
; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin])
; loc <- getCtLoc TypeEqOrigin
; loc <- getCtLoc (TypeEqOrigin item)
; wrapEqCtxt origin $
emitConstraint (WcEvVar (WantedEvVar co_var loc))
; return $ ACo $ mkTyVarTy co_var }
uType_defer [] _ _
= panic "uType_defer"
--------------
-- Push a new item on the origin stack (the most common case)
......@@ -970,33 +969,25 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a
-- and, if there is more than one item, the "Expected/inferred" part
-- comes from the outermost item
wrapEqCtxt [] thing_inside = thing_inside
wrapEqCtxt [_] thing_inside = thing_inside
wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside
---------------
failWithMisMatch :: [EqOrigin] -> TcM a
-- Generate the message when two types fail to match,
-- going to some trouble to make it helpful.
-- The argument order is: actual type, expected type
failWithMisMatch []
= panic "failWithMisMatch"
failWithMisMatch origin@(item:_)
-- We take the failing types from the top of the origin stack
-- rather than reporting the particular ones we are looking
-- at right now
failWithMisMatch (item:origin)
= wrapEqCtxt origin $
emitMisMatchErr (uo_actual item) (uo_expected item)
mkExpectedActualMsg :: Type -> Type -> SDoc
mkExpectedActualMsg act_ty exp_ty
= nest 2 (vcat [ text "Expected type" <> colon <+> ppr exp_ty,
text " Actual type" <> colon <+> ppr act_ty ])
emitMisMatchErr :: TcType -> TcType -> TcM a
emitMisMatchErr ty_act ty_exp
= do { ty_act <- zonkTcType ty_act
; ty_exp <- zonkTcType ty_exp
do { ty_act <- zonkTcType (uo_actual item)
; ty_exp <- zonkTcType (uo_expected item)
; env0 <- tcInitTidyEnv
; let (env1, pp_exp) = tidyOpenType env0 ty_exp
(env2, pp_act) = tidyOpenType env1 ty_act
; failWithTcM (misMatchMsg env2 pp_act pp_exp) }
failWithMisMatch []
= panic "failWithMisMatch"
misMatchMsg :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
misMatchMsg env ty_act ty_exp
......@@ -1006,15 +997,6 @@ misMatchMsg env ty_act ty_exp
where
(env1, extra1) = typeExtraInfoMsg env ty_exp
(env2, extra2) = typeExtraInfoMsg env1 ty_act
--------------------
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'') }
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment