From: simonpj@microsoft.com Date: Thu, 11 Jan 2007 09:07:04 +0000 (+0000) Subject: Add the function TypeRep.pprTypeApp, and use it X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cd290fc88d35d5a32c994664baa56a5eae250e9e Add the function TypeRep.pprTypeApp, and use it pprTypeApp :: SDoc -> [Type] -> SDoc pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys)) --- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 966976b..5c0dbcd 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -142,7 +142,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, + Type, dropForAlls, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -189,6 +190,7 @@ import RdrName ( plusGlobalRdrEnv, Provenance(..), import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Name ( nameOccName ) import Type ( tidyType ) +import Var ( varName ) import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) @@ -218,14 +220,14 @@ import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), import HsSyn import Type ( Kind, Type, dropForAlls, PredType, ThetaType, pprThetaArrow, pprParendType, splitForAllTys, - funResultTy ) + pprTypeApp, funResultTy ) import Id ( Id, idType, isImplicitId, isDeadBinder, isExportedId, isLocalId, isGlobalId, isRecordSelector, recordSelectorFieldLabel, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, isBottomingId ) -import Var ( TyVar, varName ) +import Var ( TyVar ) import TysPrim ( alphaTyVars ) import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity, diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index ea97495..51144ec 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -158,7 +158,7 @@ pprDataConDecl exts gadt_style show_label dataCon -- printing out the dataCon as a type signature, in GADT style pp_tau = foldr add pp_res_ty tys_w_strs - pp_res_ty = ppr_bndr tyCon <+> hsep (map GHC.pprParendType res_tys) + pp_res_ty = GHC.pprTypeApp (ppr_bndr tyCon) res_tys add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty pprParendBangTy (strict,ty) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 0972530..ff49db6 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -686,7 +686,7 @@ wrongThingErr expected thing name ptext SLIT("used as a") <+> text expected) famInstNotFound tycon tys what - = failWithTc (msg <+> quotes (ppr tycon <+> hsep (map pprParendType tys))) + = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys)) where msg = ptext $ if length what > 1 then SLIT("More than one family instance for") diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 3d42498..e7083ac 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -122,7 +122,7 @@ module TcType ( tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) where diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index b9276b7..60b55d1 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -46,13 +46,19 @@ import Maybe \begin{code} data FamInst = FamInst { fi_fam :: Name -- Family name + -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of + -- Just (tc, tys) -> tc -- Used for "rough matching"; same idea as for class instances , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs is_tys -- Used for "proper matching"; ditto , fi_tvs :: TyVarSet -- Template tyvars for full match , fi_tys :: [Type] -- Full arg types + -- INVARIANT: fi_tvs = tyConTyVars fi_tycon + -- fi_tys = case tyConFamInst_maybe fi_tycon of + -- Just (_, tys) -> tys , fi_tycon :: TyCon -- Representation tycon } @@ -82,8 +88,7 @@ pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) = pprTyConSort <+> pprHead where - pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> - sep (map pprParendType tys) + pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance") | isNewTyCon tycon = ptext SLIT("newtype instance") | isSynTyCon tycon = ptext SLIT("type instance") diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 147f546..fd81795 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -95,7 +95,7 @@ module Type ( substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, pprForAll, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll, pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where @@ -611,11 +611,14 @@ tyConOrigHead tycon = case tyConFamInst_maybe tycon of Just famInst -> famInst -- Pretty prints a tycon, using the family instance in case of a --- representation tycon. -pprSourceTyCon tycon | Just (repTyCon, tys) <- tyConFamInst_maybe tycon = - ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon - | otherwise = - ppr tycon +-- representation tycon. For example +-- e.g. data T [a] = ... +-- In that case we want to print `T [a]', where T is the family TyCon +pprSourceTyCon tycon + | Just (repTyCon, tys) <- tyConFamInst_maybe tycon + = ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 6a9c609..cc8e4be 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -15,7 +15,8 @@ module TypeRep ( funTyCon, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, + pprTyThingCategory, pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, -- Kinds @@ -432,6 +433,9 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty +pprTypeApp :: SDoc -> [Type] -> SDoc +pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys)) + ------------------ pprPred :: PredType -> SDoc pprPred (ClassP cls tys) = pprClassPred cls tys @@ -439,8 +443,7 @@ pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT("~")), ppr ty2] pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas) - <+> sep (map pprParendType tys) +pprClassPred clas tys = pprTypeApp (parenSymOcc (getOccName clas) (ppr clas)) tys pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) @@ -520,8 +523,7 @@ ppr_tc_app p tc tys | isTupleTyCon tc && tyConArity tc == length tys = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) | otherwise - = maybeParen p TyConPrec $ - ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys) + = maybeParen p TyConPrec (pprTypeApp (ppr_tc tc) tys) ppr_tc :: TyCon -> SDoc ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)