Commit 98643c2d authored by simonpj's avatar simonpj
Browse files

[project @ 2003-10-13 14:54:37 by simonpj]

Type error cosmetics
parent 7e7c11b2
......@@ -227,19 +227,7 @@ pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
| otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
pprHsForAll tvs cxt
-- This printer is used for both interface files and
-- printing user types in error messages; and alas the
-- two use slightly different syntax. Ah well.
= getPprStyle $ \ sty ->
if userStyle sty then
ptext SLIT("forall") <+> interppSP tvs <> dot <+>
-- **! ToDo: want to hide uvars from user, but not enough info
-- in a HsTyVarBndr name (see PprType). KSW 2000-10.
pprHsContext cxt
else -- Used in interfaces
ptext SLIT("__forall") <+> interppSP tvs <+>
ppr_hs_context cxt <+> ptext SLIT("=>")
pprHsForAll tvs cxt = ptext SLIT("forall") <+> interppSP tvs <+> pprHsContext cxt
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext [] = empty
......@@ -268,16 +256,20 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
pprHsType ty = ppr_mono_ty pREC_TOP (de_paren ty)
pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty)
pprParendHsType ty = ppr_mono_ty pREC_CON ty
-- Remove outermost HsParTy parens before printing a type
de_paren (HsParTy ty) = de_paren ty
de_paren ty = ty
-- Before printing a type
-- (a) Remove outermost HsParTy parens
-- (b) Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
prepare sty (HsParTy ty) = prepare sty ty
prepare sty (HsForAllTy _ cxt ty) | userStyle sty = (HsForAllTy Nothing cxt ty)
prepare sty ty = ty
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
= maybeParen ctxt_prec pREC_FUN $
sep [pp_header, pprHsType ty]
sep [pp_header, ppr_mono_ty pREC_TOP ty]
where
pp_header = case maybe_tvs of
Just tvs -> pprHsForAll tvs ctxt
......
......@@ -256,7 +256,7 @@ pprIfaceType :: Int -> IfaceType -> SDoc
-- Simple cases
pprIfaceType ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
pprIfaceType ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st)
pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st)
-- Function types
pprIfaceType ctxt_prec (IfaceFunTy ty1 ty2)
......
......@@ -34,7 +34,7 @@ import TcEnv ( tcExtendTyVarEnv, tcExtendTyVarKindEnv,
)
import TcMType ( newKindVar, tcInstType, newMutTyVar,
zonkTcType, zonkTcKindToKind,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyKind, unifyFunKind, unifyTypeKind )
import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..),
......@@ -152,7 +152,7 @@ the TyCon being defined.
tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type
-- Do kind checking, and hoist for-alls to the top
tcHsSigType ctxt hs_ty
= addErrCtxt (checkHsTypeCtxt ctxt hs_ty) $
= addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
do { kinded_ty <- kcTypeType hs_ty
; ty <- tcHsKindedType kinded_ty
; checkValidType ctxt ty
......@@ -164,11 +164,6 @@ tcHsPred pred
= do { (kinded_pred,_) <- kc_pred pred -- kc_pred rather than kcHsPred
-- to avoid the partial application check
; dsHsPred kinded_pred }
checkHsTypeCtxt ctxt hs_ty
= vcat [ptext SLIT("In the type signature:") <+> ppr hs_ty,
ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
\end{code}
These functions are used during knot-tying in
......@@ -642,12 +637,19 @@ tcAddScopedTyVars sig_tys thing_inside
-- Zonk the mutable kinds and bring the tyvars into scope
-- Rather like tcTyVarBndrs, except that it brings *mutable*
-- tyvars into scope, not immutable ones
--
-- Furthermore, the tyvars are PatSigTvs, which means that we get better
-- error messages when type variables escape:
-- Inferred type is less polymorphic than expected
-- Quantified type variable `t' escapes
-- It is mentioned in the environment:
-- t is bound by the pattern type signature at tcfail103.hs:6
mapM zonk kinded_tvs `thenM` \ tyvars ->
tcExtendTyVarEnv tyvars thing_inside
where
zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' ->
newMutTyVar name kind' VanillaTv
newMutTyVar name kind' PatSigTv
zonk (UserTyVar name) = pprTrace "BAD: Un-kinded tyvar" (ppr name) $
returnM (mkTyVar name liftedTypeKind)
\end{code}
......
......@@ -24,7 +24,7 @@ module TcMType (
--------------------------------
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt,
SourceTyCtxt(..), checkValidTheta, checkFreeness,
checkValidInstHead, instTypeErr, checkAmbiguity,
arityErr,
......@@ -43,6 +43,7 @@ module TcMType (
-- friends:
import HsSyn ( HsType )
import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation
Kind, ThetaType
)
......@@ -62,6 +63,7 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
tyVarsOfType, tyVarsOfTypes,
eqKind, isTypeKind,
)
import PprType ( pprThetaArrow )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
......@@ -526,16 +528,22 @@ data UserTypeCtxt
-- With gla-exts that's right, but for H98 we should complain.
pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature")
pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of constructor") <+> quotes (ppr c)
pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of a type synonym declaration") <+> quotes (ppr c)
pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition")
pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature")
pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n)
pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a `default' declaration")
pprHsSigCtxt :: UserTypeCtxt -> HsType Name -> SDoc
pprHsSigCtxt ctxt hs_ty = pprUserTypeCtxt hs_ty ctxt
pprUserTypeCtxt ty (FunSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
pprUserTypeCtxt ty ExprSigCtxt = sep [ptext SLIT("In an expression type signature:"), nest 2 (ppr ty)]
pprUserTypeCtxt ty (ConArgCtxt c) = sep [ptext SLIT("In the type of the constructor"), pp_sig c ty]
pprUserTypeCtxt ty (TySynCtxt c) = sep [ptext SLIT("In the RHS of the type synonym") <+> quotes (ppr c) <> comma,
nest 2 (ptext SLIT(", namely") <+> ppr ty)]
pprUserTypeCtxt ty GenPatCtxt = sep [ptext SLIT("In the type pattern of a generic definition:"), nest 2 (ppr ty)]
pprUserTypeCtxt ty PatSigCtxt = sep [ptext SLIT("In a pattern type signature:"), nest 2 (ppr ty)]
pprUserTypeCtxt ty ResSigCtxt = sep [ptext SLIT("In a result type signature:"), nest 2 (ppr ty)]
pprUserTypeCtxt ty (ForSigCtxt n) = sep [ptext SLIT("In the foreign declaration:"), pp_sig n ty]
pprUserTypeCtxt ty (RuleSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
pprUserTypeCtxt ty DefaultDeclCtxt = sep [ptext SLIT("In a type in a `default' declaration:"), nest 2 (ppr ty)]
pp_sig n ty = nest 2 (ppr n <+> dcolon <+> ppr ty)
\end{code}
\begin{code}
......
......@@ -27,7 +27,7 @@ import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType,
kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..), pprUserTypeCtxt )
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcUnify ( unifyKind )
import TcType ( TcKind, ThetaType, TcType,
mkArrowKind, liftedTypeKind,
......@@ -433,8 +433,7 @@ checkValidTyCl decl
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| isSynTyCon tc
= addErrCtxt (checkTypeCtxt syn_ctxt syn_rhs) $
checkValidType syn_ctxt syn_rhs
= checkValidType syn_ctxt syn_rhs
| otherwise
= -- Check the context on the data decl
checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_`
......@@ -530,23 +529,6 @@ checkValidClass cls
fieldTypeMisMatch field_name
= sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
checkTypeCtxt ctxt ty
= vcat [ptext SLIT("In the type:") <+> ppr_ty,
ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
where
-- Hack alert. If there are no tyvars, (ppr sigma_ty) will print
-- something strange like {Eq k} -> k -> k, because there is no
-- ForAll at the top of the type. Since this is going to the user
-- we want it to look like a proper Haskell type even then; hence the hack
--
-- This shows up in the complaint about
-- case C a where
-- op :: Eq a => a -> a
ppr_ty | null forall_tvs = pprThetaArrow theta <+> ppr tau
| otherwise = ppr ty
(forall_tvs, theta, tau) = tcSplitSigmaTy ty
dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
where
......
......@@ -241,6 +241,10 @@ data TyVarDetails
| InstTv -- Ditto, but instance decl
| PatSigTv -- Scoped type variable, introduced by a pattern
-- type signature
-- \ x::a -> e
| VanillaTv -- Everything else
isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible
......@@ -266,6 +270,7 @@ tyVarBindingInfo tv
details SigTv = ptext SLIT("type signature")
details ClsTv = ptext SLIT("class declaration")
details InstTv = ptext SLIT("instance declaration")
details PatSigTv = ptext SLIT("pattern type signature")
details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
\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