| 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
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
-- 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)
)
import TcMType ( newKindVar, tcInstType, newMutTyVar,
zonkTcType, zonkTcKindToKind,
- checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
+ checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyKind, unifyFunKind, unifyTypeKind )
import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..),
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
= 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
-- 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}
--------------------------------
-- Checking type validity
- Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
+ Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt,
SourceTyCtxt(..), checkValidTheta, checkFreeness,
checkValidInstHead, instTypeErr, checkAmbiguity,
arityErr,
-- friends:
+import HsSyn ( HsType )
import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation
Kind, ThetaType
)
tyVarsOfType, tyVarsOfTypes,
eqKind, isTypeKind,
)
+import PprType ( pprThetaArrow )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
-- 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}
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,
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_`
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
| 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
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}
projects / ghc-hetmet.git / commitdiff