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
......
This diff is collapsed.
......@@ -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