From 98643c2d5bd08ec71edd555e8989e530de6f5921 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 13 Oct 2003 14:54:40 +0000 Subject: [PATCH] [project @ 2003-10-13 14:54:37 by simonpj] Type error cosmetics --- ghc/compiler/hsSyn/HsTypes.lhs | 28 ++++++++++------------------ ghc/compiler/iface/IfaceType.lhs | 2 +- ghc/compiler/typecheck/TcHsType.lhs | 18 ++++++++++-------- ghc/compiler/typecheck/TcMType.lhs | 30 +++++++++++++++++++----------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 22 ++-------------------- ghc/compiler/typecheck/TcType.lhs | 5 +++++ 6 files changed, 47 insertions(+), 58 deletions(-) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 79b662f..6d8013c 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -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 diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 2c83155..a4cf183 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 3be9d31..9a73ff3 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 7c75d91..c6ee4d7 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index d41de58..279bf81 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 3a10ed1..44b0c2a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -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} -- 1.7.10.4