Modularise pretty-printing for foralls
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 May 2014 07:19:01 +0000 (08:19 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 May 2014 07:19:01 +0000 (08:19 +0100)
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.

compiler/main/PprTyThing.hs
compiler/types/Coercion.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
testsuite/tests/ghci/scripts/T7939.stdout

index 01932f6..4934024 100644 (file)
@@ -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
index a436bcf..53326e6 100644 (file)
@@ -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
index 88054ce..7395329 100644 (file)
@@ -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,
 
index 5787d87..866fc77 100644 (file)
@@ -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
@@ -631,15 +632,21 @@ ppr_sigma_type show_foralls ty
 
     split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
     split1 tvs ty               = (reverse tvs, 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
index 9a88b5c..a479376 100644 (file)
@@ -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