[commit: ghc] master: Modularise pretty-printing for foralls (3c3ce82)
git at git.haskell.org
git at git.haskell.org
Tue May 6 08:43:36 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/3c3ce829b64a9b5cc509db19d5d1acf44a565053/ghc
>---------------------------------------------------------------
commit 3c3ce829b64a9b5cc509db19d5d1acf44a565053
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue May 6 08:19:01 2014 +0100
Modularise pretty-printing for foralls
See TypeRep.pprUserForAll. This just makes forall-printing a bit more
consistent. In particular, I wasn't seeing the kind foralls when
displaying a CoAxiom or CoAxBranch
The output on T7939 is just possible a bit too verbose now, but even if so
that's an error in the right direction.
>---------------------------------------------------------------
3c3ce829b64a9b5cc509db19d5d1acf44a565053
compiler/main/PprTyThing.hs | 8 ++------
compiler/types/Coercion.lhs | 2 +-
compiler/types/Type.lhs | 2 +-
compiler/types/TypeRep.lhs | 27 +++++++++++++++++----------
testsuite/tests/ghci/scripts/T7939.stdout | 4 ++--
5 files changed, 23 insertions(+), 20 deletions(-)
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 01932f6..4934024 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -32,14 +32,13 @@ import CoAxiom( CoAxiom(..), brListMap )
import HscTypes( tyThingParent_maybe )
import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
import Kind( synTyConResKind )
-import TypeRep( pprTvBndrs, pprForAll, suppressKinds )
+import TypeRep( pprTvBndrs, pprUserForAll, suppressKinds )
import TysPrim( alphaTyVars )
import MkIface ( tyThingToIfaceDecl )
import TcType
import Name
import VarEnv( emptyTidyEnv )
import StaticFlags( opt_PprStyle_Debug )
-import DynFlags
import Outputable
import FastString
@@ -234,7 +233,7 @@ pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc
pprDataConDecl ss gadt_style dataCon
| not gadt_style = ppr_fields tys_w_strs
| otherwise = ppr_bndr dataCon <+> dcolon <+>
- sep [ pp_foralls, pprThetaArrowTy theta, pp_tau ]
+ sep [ pprUserForAll forall_tvs, pprThetaArrowTy theta, pp_tau ]
-- Printing out the dataCon as a type signature, in GADT style
where
(forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon)
@@ -242,9 +241,6 @@ pprDataConDecl ss gadt_style dataCon
labels = dataConFieldLabels dataCon
stricts = dataConStrictMarks dataCon
tys_w_strs = zip (map user_ify stricts) arg_tys
- pp_foralls = sdocWithDynFlags $ \dflags ->
- ppWhen (gopt Opt_PrintExplicitForalls dflags)
- (pprForAll forall_tvs)
pp_tau = foldr add (ppr res_ty) tys_w_strs
add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index a436bcf..53326e6 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -724,7 +724,7 @@ pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
pprCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
, cab_lhs = lhs
, cab_rhs = rhs })
- = hang (ifPprDebug (pprForAll tvs))
+ = hang (pprUserForAll tvs)
2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs)))
pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 88054ce..7395329 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -128,7 +128,7 @@ module Type (
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
- pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType,
+ pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon,
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 5787d87..866fc77 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -39,7 +39,8 @@ module TypeRep (
-- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory, pprSigmaType,
- pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
+ pprEqPred, pprTheta, pprForAll, pprUserForAll,
+ pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit, suppressKinds,
Prec(..), maybeParen, pprTcApp,
pprPrefixApp, pprArrowChain, ppr_type,
@@ -618,11 +619,11 @@ ppr_tylit _ tl =
-------------------
ppr_sigma_type :: Bool -> Type -> SDoc
--- Bool <=> Show the foralls
-ppr_sigma_type show_foralls ty
- = sep [ ppWhen (show_foralls || any tv_has_kind_var tvs)
- (pprForAll tvs)
- -- See Note [When to print foralls]
+-- Bool <=> Show the foralls unconditionally
+ppr_sigma_type show_foralls_unconditionally ty
+ = sep [ if show_foralls_unconditionally
+ then pprForAll tvs
+ else pprUserForAll tvs
, pprThetaArrowTy ctxt
, pprType tau ]
where
@@ -635,11 +636,17 @@ ppr_sigma_type show_foralls ty
split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
split2 ps ty = (reverse ps, ty)
- tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv)))
-
pprSigmaType :: Type -> SDoc
-pprSigmaType ty = sdocWithDynFlags $ \dflags ->
- ppr_sigma_type (gopt Opt_PrintExplicitForalls dflags) ty
+pprSigmaType ty = ppr_sigma_type False ty
+
+pprUserForAll :: [TyVar] -> SDoc
+-- Print a user-level forall; see Note [WHen to print foralls]
+pprUserForAll tvs
+ = sdocWithDynFlags $ \dflags ->
+ ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
+ pprForAll tvs
+ where
+ tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv)))
pprForAll :: [TyVar] -> SDoc
pprForAll [] = empty
diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout
index 9a88b5c..a479376 100644
--- a/testsuite/tests/ghci/scripts/T7939.stdout
+++ b/testsuite/tests/ghci/scripts/T7939.stdout
@@ -13,11 +13,11 @@ type family H (a :: Bool) :: Bool where H 'False = 'True
H :: Bool -> Bool
type family J (a :: [k]) :: Bool where
J '[] = 'False
- J (h : t) = 'True
+ forall (k :: BOX) (h :: k) (t :: [k]). J (h : t) = 'True
-- Defined at T7939.hs:17:1
J :: [k] -> Bool
type family K (a :: [k]) :: Maybe k where
K '[] = 'Nothing
- K (h : t) = 'Just h
+ forall (k :: BOX) (h :: k) (t :: [k]). K (h : t) = 'Just h
-- Defined at T7939.hs:21:1
K :: [k] -> Maybe k
More information about the ghc-commits
mailing list