Improve pretty-printing of types
authorunknown <simonpj@MSRC-4971295.europe.corp.microsoft.com>
Tue, 1 Oct 2013 15:34:00 +0000 (16:34 +0100)
committerunknown <simonpj@MSRC-4971295.europe.corp.microsoft.com>
Tue, 1 Oct 2013 15:54:58 +0000 (16:54 +0100)
* The main change is to suppress printing (in types) of
     kind for-alls
     kind applications
  The new flag -fprint-explicit-kinds prints them as before
  (by analogy with the existing -fprint-explicit-foralls)

* I also took advantage of the fact that SDoc now has access
  to DynFlags, to tidy up the way in which explicit for-alls
  are printed.  Instead of passing a boolean flag around, we
  now simply consult the DynFlags.  Much neater.

I still need to add documentation for the flag

compiler/ghci/Debugger.hs
compiler/main/DynFlags.hs
compiler/main/PprTyThing.hs
compiler/types/TypeRep.lhs
ghc/InteractiveUI.hs

index 0ceffcd..0807bf1 100644 (file)
@@ -206,9 +206,8 @@ newGrimName userName  = do
 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
 pprTypeAndContents id = do
   dflags  <- GHC.getSessionDynFlags
-  let pefas     = gopt Opt_PrintExplicitForalls dflags
-      pcontents = gopt Opt_PrintBindContents dflags
-      pprdId    = (PprTyThing.pprTyThing pefas . AnId) id
+  let pcontents = gopt Opt_PrintBindContents dflags
+      pprdId    = (PprTyThing.pprTyThing . AnId) id
   if pcontents 
     then do
       let depthBound = 100
index 918b1ae..d52835d 100644 (file)
@@ -283,6 +283,7 @@ data GeneralFlag
    | Opt_WarnIsError                    -- -Werror; makes warnings fatal
 
    | Opt_PrintExplicitForalls
+   | Opt_PrintExplicitKinds
 
    -- optimisation opts
    | Opt_Strictness
@@ -2583,6 +2584,7 @@ fFlags :: [FlagSpec GeneralFlag]
 fFlags = [
   ( "error-spans",                      Opt_ErrorSpans, nop ),
   ( "print-explicit-foralls",           Opt_PrintExplicitForalls, nop ),
+  ( "print-explicit-kinds",             Opt_PrintExplicitKinds, nop ),
   ( "strictness",                       Opt_Strictness, nop ),
   ( "late-dmd-anal",                    Opt_LateDmdAnal, nop ),
   ( "specialise",                       Opt_Specialise, nop ),
index f5c4bd2..947d8b2 100644 (file)
@@ -14,7 +14,6 @@
 -- for details
 
 module PprTyThing (
-       PrintExplicitForalls,
        pprTyThing,
        pprTyThingInContext, 
        pprTyThingLoc,
@@ -33,11 +32,13 @@ import Coercion( pprCoAxiom, pprCoAxBranch )
 import CoAxiom( CoAxiom(..), brListMap )
 import HscTypes( tyThingParent_maybe )
 import Type( tidyTopType, tidyOpenType )
-import TypeRep( pprTvBndrs )
+import TypeRep( pprTvBndrs, suppressKinds )
 import TcType
+import Class( classTyCon )
 import Name
 import VarEnv( emptyTidyEnv )
 import StaticFlags( opt_PprStyle_Debug )
+import DynFlags
 import Outputable
 import FastString
 
@@ -47,8 +48,6 @@ import FastString
 -- This should be a good source of sample code for using the GHC API to
 -- inspect source code entities.
 
-type PrintExplicitForalls = Bool
-
 type ShowSub = [Name]
 --   []     <=> print all sub-components of the current thing
 --   (n:ns) <=> print sub-component 'n' with ShowSub=ns
@@ -67,56 +66,58 @@ showSub_maybe (n:ns) thing = if n == getName thing then Just ns
 
 ----------------------------
 -- | Pretty-prints a 'TyThing' with its defining location.
-pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing
-  = showWithLoc (pprDefinedAt (GHC.getName tyThing)) (pprTyThing pefas tyThing)
+pprTyThingLoc :: TyThing -> SDoc
+pprTyThingLoc tyThing
+  = showWithLoc (pprDefinedAt (GHC.getName tyThing)) (pprTyThing tyThing)
 
 -- | Pretty-prints a 'TyThing'.
-pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThing pefas thing = ppr_ty_thing pefas showAll thing
+pprTyThing :: TyThing -> SDoc
+pprTyThing thing = ppr_ty_thing showAll thing
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
 -- is a data constructor, record selector, or class method, then
 -- the entity's parent declaration is pretty-printed with irrelevant
 -- parts omitted.
-pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContext pefas thing
+pprTyThingInContext :: TyThing -> SDoc
+pprTyThingInContext thing
   = go [] thing
   where
     go ss thing = case tyThingParent_maybe thing of
                     Just parent -> go (getName thing : ss) parent
-                    Nothing     -> ppr_ty_thing pefas ss thing
+                    Nothing     -> ppr_ty_thing ss thing
 
 -- | Like 'pprTyThingInContext', but adds the defining location.
-pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContextLoc pefas tyThing
+pprTyThingInContextLoc :: TyThing -> SDoc
+pprTyThingInContextLoc tyThing
   = showWithLoc (pprDefinedAt (GHC.getName tyThing))
-                (pprTyThingInContext pefas tyThing)
+                (pprTyThingInContext tyThing)
 
 -- | Pretty-prints the 'TyThing' header. For functions and data constructors
 -- the function is equivalent to 'pprTyThing' but for type constructors
 -- and classes it prints only the header part of the declaration.
-pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingHdr pefas (AnId id)          = pprId         pefas id
-pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
-pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
-pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
+pprTyThingHdr :: TyThing -> SDoc
+pprTyThingHdr (AnId id)          = pprId         id
+pprTyThingHdr (ADataCon dataCon) = pprDataConSig dataCon
+pprTyThingHdr (ATyCon tyCon)     = pprTyConHdr   tyCon
+pprTyThingHdr (ACoAxiom ax)      = pprCoAxiom ax
 
 ------------------------
-ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc
-ppr_ty_thing pefas _  (AnId id)          = pprId         pefas id
-ppr_ty_thing pefas _  (ADataCon dataCon) = pprDataConSig pefas dataCon
-ppr_ty_thing pefas ss (ATyCon tyCon)            = pprTyCon      pefas ss tyCon
-ppr_ty_thing _     _  (ACoAxiom ax)             = pprCoAxiom    ax
-
-pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
-pprTyConHdr pefas tyCon
+ppr_ty_thing :: ShowSub -> TyThing -> SDoc
+ppr_ty_thing _  (AnId id)          = pprId         id
+ppr_ty_thing _  (ADataCon dataCon) = pprDataConSig dataCon
+ppr_ty_thing ss (ATyCon tyCon)     = pprTyCon      ss tyCon
+ppr_ty_thing _  (ACoAxiom ax)      = pprCoAxiom    ax
+
+pprTyConHdr :: TyCon -> SDoc
+pprTyConHdr tyCon
   | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
   = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
   | Just cls <- tyConClass_maybe tyCon
-  = pprClassHdr pefas cls
+  = pprClassHdr cls
   | otherwise
-  = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars
+  = sdocWithDynFlags $ \dflags ->
+    ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon
+    <+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars)
   where
     vars | GHC.isPrimTyCon tyCon ||
           GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
@@ -134,36 +135,40 @@ pprTyConHdr pefas tyCon
        | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
        | otherwise        = empty      -- Returns 'empty' if null theta
 
-pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
-pprDataConSig pefas dataCon
-  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
+pprDataConSig :: GHC.DataCon -> SDoc
+pprDataConSig dataCon
+  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser (GHC.dataConType dataCon)
 
-pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
-pprClassHdr _ cls
-  = ptext (sLit "class") <+>
+pprClassHdr :: GHC.Class -> SDoc
+pprClassHdr cls
+  = sdocWithDynFlags $ \dflags ->
+    ptext (sLit "class") <+>
     sep [ GHC.pprThetaArrowTy (GHC.classSCTheta cls)
-        , ppr_bndr cls <+> pprTvBndrs tyVars
+        , ppr_bndr cls 
+          <+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs)
         , GHC.pprFundeps funDeps ]
   where
-     (tyVars, funDeps) = GHC.classTvsFds cls
+     (tvs, funDeps) = GHC.classTvsFds cls
 
-pprId :: PrintExplicitForalls -> Var -> SDoc
-pprId pefas ident
+pprId :: Var -> SDoc
+pprId ident
   = hang (ppr_bndr ident <+> dcolon)
-        2 (pprTypeForUser pefas (GHC.idType ident))
+        2 (pprTypeForUser (GHC.idType ident))
 
-pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
+pprTypeForUser :: GHC.Type -> SDoc
 -- We do two things here.
 -- a) We tidy the type, regardless
--- b) If PrintExplicitForAlls is True, we discard the foralls
+-- b) If Opt_PrintExplicitForAlls is True, we discard the foralls
 --     but we do so `deeply'
 -- Prime example: a class op might have type
 --     forall a. C a => forall b. Ord b => stuff
 -- Then we want to display
 --     (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty
-  | print_foralls = ppr tidy_ty
-  | otherwise     = ppr (mkPhiTy ctxt ty')
+pprTypeForUser ty
+  = sdocWithDynFlags $ \ dflags ->
+    if gopt Opt_PrintExplicitForalls dflags
+    then ppr tidy_ty
+    else ppr (mkPhiTy ctxt ty')
   where
     (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
     (_, tidy_ty)   = tidyOpenType emptyTidyEnv ty
@@ -172,37 +177,37 @@ pprTypeForUser print_foralls ty
      -- print un-generalised kinds (eg when doing :k T), so it's
      -- better to use tidyOpenType here
 
-pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
-pprTyCon pefas ss tyCon
+pprTyCon :: ShowSub -> TyCon -> SDoc
+pprTyCon ss tyCon
   | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon
   = case syn_rhs of
-      OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> 
-                                 pprTypeForUser pefas (GHC.synTyConResKind tyCon)
+      OpenSynFamilyTyCon -> pprTyConHdr tyCon <+> dcolon <+> 
+                                 pprTypeForUser (GHC.synTyConResKind tyCon)
       ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
         hang closed_family_header
            2 (vcat (brListMap (pprCoAxBranch tyCon) branches))
       AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..")
-      SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 
+      SynonymTyCon rhs_ty -> hang (pprTyConHdr tyCon <+> equals) 
                                      2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!
-      BuiltInSynFamTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> 
-                             pprTypeForUser pefas (GHC.synTyConResKind tyCon)
+      BuiltInSynFamTyCon {} -> pprTyConHdr tyCon <+> dcolon <+> 
+                             pprTypeForUser (GHC.synTyConResKind tyCon)
 
                                                  -- e.g. type T = forall a. a->a
   | Just cls <- GHC.tyConClass_maybe tyCon
-  = pprClass pefas ss cls
+  = pprClass ss cls
   | otherwise
-  = pprAlgTyCon pefas ss tyCon
+  = pprAlgTyCon ss tyCon
 
   where
     closed_family_header
-      = pprTyConHdr pefas tyCon <+> dcolon <+>
-        pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where")
+      = pprTyConHdr tyCon <+> dcolon <+>
+        pprTypeForUser (GHC.synTyConResKind tyCon) <+> ptext (sLit "where")
 
-pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
-pprAlgTyCon pefas ss tyCon
-  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
+pprAlgTyCon :: ShowSub -> TyCon -> SDoc
+pprAlgTyCon ss tyCon
+  | gadt      = pprTyConHdr tyCon <+> ptext (sLit "where") $$
                   nest 2 (vcat (ppr_trim (map show_con datacons)))
-  | otherwise = hang (pprTyConHdr pefas tyCon)
+  | otherwise = hang (pprTyConHdr tyCon)
                   2 (add_bars (ppr_trim (map show_con datacons)))
   where
     datacons = GHC.tyConDataCons tyCon
@@ -210,11 +215,11 @@ pprAlgTyCon pefas ss tyCon
 
     ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
     show_con dc
-      | ok_con dc = Just (pprDataConDecl pefas ss gadt dc)
+      | ok_con dc = Just (pprDataConDecl ss gadt dc)
       | otherwise = Nothing
 
-pprDataConDecl :: PrintExplicitForalls -> ShowSub -> Bool -> GHC.DataCon -> SDoc
-pprDataConDecl pefas ss gadt_style dataCon
+pprDataConDecl :: ShowSub -> Bool -> GHC.DataCon -> SDoc
+pprDataConDecl ss gadt_style dataCon
   | not gadt_style = ppr_fields tys_w_strs
   | otherwise      = ppr_bndr dataCon <+> dcolon <+>
                        sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
@@ -225,8 +230,9 @@ pprDataConDecl pefas ss gadt_style dataCon
     labels     = GHC.dataConFieldLabels dataCon
     stricts    = GHC.dataConStrictMarks dataCon
     tys_w_strs = zip (map user_ify stricts) arg_tys
-    pp_foralls | pefas     = GHC.pprForAll forall_tvs
-               | otherwise = empty
+    pp_foralls = sdocWithDynFlags $ \dflags ->
+                 ppWhen (gopt Opt_PrintExplicitForalls dflags)
+                        (GHC.pprForAll forall_tvs)
 
     pp_tau = foldr add (ppr res_ty) tys_w_strs
     add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
@@ -256,26 +262,26 @@ pprDataConDecl pefas ss gadt_style dataCon
          <+> (braces $ sep $ punctuate comma $ ppr_trim $
                map maybe_show_label (zip labels fields))
 
-pprClass :: PrintExplicitForalls -> ShowSub -> GHC.Class -> SDoc
-pprClass pefas ss cls
+pprClass :: ShowSub -> GHC.Class -> SDoc
+pprClass ss cls
   | null methods && null assoc_ts
-  = pprClassHdr pefas cls
+  = pprClassHdr cls
   | otherwise
-  = vcat [ pprClassHdr pefas cls <+> ptext (sLit "where")
+  = vcat [ pprClassHdr cls <+> ptext (sLit "where")
          , nest 2 (vcat $ ppr_trim $ 
                    map show_at assoc_ts ++ map show_meth methods)]
   where
     methods  = GHC.classMethods cls
     assoc_ts = GHC.classATs cls
-    show_meth id | showSub ss id  = Just (pprClassMethod pefas id)
+    show_meth id | showSub ss id  = Just (pprClassMethod id)
                 | otherwise      = Nothing
     show_at tc = case showSub_maybe ss tc of
-                      Just ss' -> Just (pprTyCon pefas ss' tc)
+                      Just ss' -> Just (pprTyCon ss' tc)
                       Nothing  -> Nothing
 
-pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
-pprClassMethod pefas id
-  = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty)
+pprClassMethod :: Id -> SDoc
+pprClassMethod id
+  = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser op_ty)
   where
   -- Here's the magic incantation to strip off the dictionary
   -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
index e0d435a..62c5a11 100644 (file)
@@ -40,8 +40,8 @@ module TypeRep (
        pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
        pprTyThing, pprTyThingCategory, pprSigmaType,
        pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
-        pprKind, pprParendKind, pprTyLit,
-       Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
+        pprKind, pprParendKind, pprTyLit, suppressKinds,
+       Prec(..), maybeParen, pprTcApp, 
         pprPrefixApp, pprArrowChain, ppr_type,
 
         -- Free variables
@@ -81,8 +81,8 @@ import PrelNames
 import Outputable
 import FastString
 import Pair
-import StaticFlags( opt_PprStyle_Debug )
 import Util
+import DynFlags
 
 -- libraries
 import Data.List( mapAccumL, partition )
@@ -527,10 +527,7 @@ pprEqPred (Pair ty1 ty2)
 
 ------------
 pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred = ppr_class_pred ppr_type
-
-ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc
-ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys
+pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
 
 ------------
 pprTheta :: ThetaType -> SDoc
@@ -582,7 +579,7 @@ ppr_type _ (TyConApp tc [LitTy (StrTyLit n),ty])
   | tc `hasKey` ipClassNameKey
   = char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty
 
-ppr_type p (TyConApp tc tys)  = pprTcApp p ppr_type tc tys
+ppr_type p (TyConApp tc tys)  = pprTyTcApp p tc tys
 
 ppr_type p (LitTy l)          = ppr_tylit p l
 ppr_type p ty@(ForAllTy {})   = ppr_forall_type p ty
@@ -620,9 +617,14 @@ ppr_tylit _ tl =
 ppr_sigma_type :: Bool -> Type -> SDoc
 -- Bool <=> Show the foralls
 ppr_sigma_type show_foralls ty
-  =  sep [ if show_foralls then pprForAll tvs else empty
-        , pprThetaArrowTy ctxt
-        , pprType tau ]
+  = sdocWithDynFlags $ \ dflags -> 
+    let filtered_tvs | gopt Opt_PrintExplicitKinds dflags 
+                     = tvs
+                     | otherwise
+                     = filterOut isKindVar tvs
+    in sep [ ppWhen show_foralls (pprForAll filtered_tvs)
+           , pprThetaArrowTy ctxt
+           , pprType tau ]
   where
     (tvs,  rho) = split1 [] ty
     (ctxt, tau) = split2 [] rho
@@ -635,7 +637,8 @@ ppr_sigma_type show_foralls ty
 
 
 pprSigmaType :: Type -> SDoc
-pprSigmaType ty = ppr_sigma_type opt_PprStyle_Debug ty
+pprSigmaType ty = sdocWithDynFlags $ \dflags ->
+                  ppr_sigma_type (gopt Opt_PrintExplicitForalls dflags) ty
 
 pprForAll :: [TyVar] -> SDoc
 pprForAll []  = empty
@@ -671,7 +674,26 @@ remember to parenthesise the operator, thus
 See Trac #2766.
 
 \begin{code}
+pprTypeApp :: TyCon -> [Type] -> SDoc
+pprTypeApp tc tys = pprTyTcApp TopPrec tc tys
+        -- We have to use ppr on the TyCon (not its name)
+        -- so that we get promotion quotes in the right place
+
+pprTyTcApp :: Prec -> TyCon -> [Type] -> SDoc
+-- Used for types only; so that we can make a
+-- special case for type-level lists
+pprTyTcApp p tc tys
+  | tc `hasKey` consDataConKey
+  , [_kind,ty1,ty2] <- tys
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_PrintExplicitKinds dflags then pprTcApp  p ppr_type tc tys
+                                   else pprTyList p ty1 ty2
+
+  | otherwise
+  = pprTcApp p ppr_type tc tys
+
 pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+-- Used for both types and coercions, hence polymorphism
 pprTcApp _ pp tc [ty]
   | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets   (pp TopPrec ty)
   | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
@@ -691,43 +713,63 @@ pprTcApp p pp tc tys
     (tupleParens (tupleTyConSort dc_tc) $
      sep (punctuate comma (map (pp TopPrec) ty_args)))
 
-  | not opt_PprStyle_Debug
-  , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey, eqReprPrimTyConKey] 
-                           -- We need to special case the type equality TyCons because
-  , [_, ty1,ty2] <- tys    -- with kind polymorphism it has 3 args, so won't get printed infix
-                           -- With -dppr-debug switch this off so we can see the kind
-  = pprInfixApp p pp (ppr tc) ty1 ty2
-
   | otherwise
-  = ppr_type_name_app p pp (getName tc) (ppr tc) tys
+  = sdocWithDynFlags (pprTcApp_help p pp tc tys)
 
-----------------
-pprTypeApp :: TyCon -> [Type] -> SDoc
-pprTypeApp tc tys 
-  = ppr_type_name_app TopPrec ppr_type (getName tc) (ppr tc) tys
-        -- We have to use ppr on the TyCon (not its name)
-        -- so that we get promotion quotes in the right place
+pprTcApp_help :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc
+-- This one has accss to the DynFlags
+pprTcApp_help p pp tc tys dflags
+  | not (isSymOcc (nameOccName (tyConName tc)))
+  = pprPrefixApp p (ppr tc) (map (pp TyConPrec) tys_wo_kinds)
 
-pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
--- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
-pprTypeNameApp p pp name tys
-  = ppr_type_name_app p pp name (ppr name) tys
+  | [ty1,ty2] <- tys_wo_kinds  -- Infix, two arguments;
+                               -- we know nothing of precedence though
+  = pprInfixApp p pp (ppr tc) ty1 ty2
 
-ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> Name -> SDoc -> [a] -> SDoc
-ppr_type_name_app p pp nm_tc pp_tc tys
-  | not (isSymOcc (nameOccName nm_tc))
-  = pprPrefixApp p pp_tc (map (pp TyConPrec) tys)
+  |  tc `hasKey` liftedTypeKindTyConKey 
+  || tc `hasKey` unliftedTypeKindTyConKey 
+  = ASSERT( null tys ) ppr tc   -- Do not wrap *, # in parens
 
-  | [ty1,ty2] <- tys  -- Infix, two arguments;
-                      -- we know nothing of precedence though
-  = pprInfixApp p pp pp_tc ty1 ty2
+  | otherwise
+  = pprPrefixApp p (parens (ppr tc)) (map (pp TyConPrec) tys_wo_kinds)
+  where
+    tys_wo_kinds = suppressKinds dflags (tyConKind tc) tys
 
-  |  nm_tc `hasKey` liftedTypeKindTyConKey 
-  || nm_tc `hasKey` unliftedTypeKindTyConKey 
-  = ASSERT( null tys ) pp_tc   -- Do not wrap *, # in parens
+------------------
+suppressKinds :: DynFlags -> Kind -> [a] -> [a]
+-- Given the kind of a TyCon, and the args to which it is applied,
+-- suppress the args that are kind args
+suppressKinds dflags kind xs
+  | gopt Opt_PrintExplicitKinds dflags = xs
+  | otherwise                          = suppress kind xs
+  where
+    suppress (ForAllTy _ kind) (_ : xs) = suppress kind xs
+    suppress (FunTy _ res)     (x:xs)   = x : suppress res xs
+    suppress _                 xs       = xs
 
-  | otherwise
-  = pprPrefixApp p (parens pp_tc) (map (pp TyConPrec) tys)
+----------------
+pprTyList :: Prec -> Type -> Type -> SDoc
+-- Given a type-level list (t1 ': t2), see if we can print 
+-- it in list notation [t1, ...].  
+pprTyList p ty1 ty2
+  = case gather ty2 of
+      (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma 
+                                            (map (ppr_type TopPrec) (ty1:arg_tys))))
+      (arg_tys, Just tl) -> maybeParen p FunPrec $
+                            hang (ppr_type FunPrec ty1)
+                               2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]])
+  where
+    gather :: Type -> ([Type], Maybe Type)
+     -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
+     --             = (tys, Just tl) means ty is of form t1:t2:...tn:tl
+    gather (TyConApp tc tys)
+      | tc `hasKey` consDataConKey
+      , [_kind, ty1,ty2] <- tys
+      , (args, tl) <- gather ty2
+      = (ty1:args, tl)
+      | tc `hasKey` nilDataConKey
+      = ([], Nothing)
+    gather ty = ([], Just ty)
 
 ----------------
 pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc
index 220ee17..4715474 100644 (file)
@@ -1062,12 +1062,10 @@ info allInfo s  = handleSourceError GHC.printException $ do
 
 infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
 infoThing allInfo str = do
-    dflags    <- getDynFlags
-    let pefas = gopt Opt_PrintExplicitForalls dflags
     names     <- GHC.parseName str
     mb_stuffs <- mapM (GHC.getInfo allInfo) names
     let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)
-    return $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered)
+    return $ vcat (intersperse (text "") $ map pprInfo filtered)
 
   -- Filter out names whose parent is also there Good
   -- example is '[]', which is both a type and data
@@ -1081,10 +1079,9 @@ filterOutChildren get_thing xs
                      Just p  -> getName p `elemNameSet` all_names
                      Nothing -> False
 
-pprInfo :: PrintExplicitForalls
-        -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
-pprInfo pefas (thing, fixity, cls_insts, fam_insts)
-  =  pprTyThingInContextLoc pefas thing
+pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
+pprInfo (thing, fixity, cls_insts, fam_insts)
+  =  pprTyThingInContextLoc thing
   $$ show_fixity
   $$ vcat (map GHC.pprInstance cls_insts)
   $$ vcat (map GHC.pprFamInst  fam_insts)
@@ -1463,9 +1460,7 @@ typeOfExpr str
   = handleSourceError GHC.printException
   $ do
        ty <- GHC.exprType str
-       dflags <- getDynFlags
-       let pefas = gopt Opt_PrintExplicitForalls dflags
-       printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
+       printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
 
 -----------------------------------------------------------------------------
 -- :kind
@@ -1475,9 +1470,7 @@ kindOfType norm str
   = handleSourceError GHC.printException
   $ do
        (ty, kind) <- GHC.typeKind norm str
-       dflags <- getDynFlags
-       let pefas = gopt Opt_PrintExplicitForalls dflags
-       printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser pefas kind
+       printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
                            , ppWhen norm $ equals <+> ppr ty ]
 
 
@@ -1651,8 +1644,7 @@ browseModule bang modl exports_only = do
 
         rdr_env <- GHC.getGRE
 
-        let pefas              = gopt Opt_PrintExplicitForalls dflags
-            things | bang      = catMaybes mb_things
+        let things | bang      = catMaybes mb_things
                    | otherwise = filtered_things
             pretty | bang      = pprTyThing
                    | otherwise = pprTyThingInContext
@@ -1682,7 +1674,7 @@ browseModule bang modl exports_only = do
               where (g,ng) = partition ((==m).fst) mts
 
         let prettyThings, prettyThings' :: [SDoc]
-            prettyThings = map (pretty pefas) things
+            prettyThings = map pretty things
             prettyThings' | bang      = annotate $ zip modNames prettyThings
                           | otherwise = prettyThings
         liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
@@ -1990,12 +1982,13 @@ showDynFlags show_all dflags = do
 
         (ghciFlags,others)  = partition (\(_, f, _) -> f `elem` flgs)
                                         DynFlags.fFlags
-        flgs = [Opt_PrintExplicitForalls
-                ,Opt_PrintBindResult
-                ,Opt_BreakOnException
-                ,Opt_BreakOnError
-                ,Opt_PrintEvldWithShow
-                ]
+        flgs = [ Opt_PrintExplicitForalls
+               , Opt_PrintKindArgs
+               , Opt_PrintBindResult
+               , Opt_BreakOnException
+               , Opt_BreakOnError
+               , Opt_PrintEvldWithShow
+               ]
 
 setArgs, setOptions :: [String] -> GHCi ()
 setProg, setEditor, setStop :: String -> GHCi ()
@@ -2254,15 +2247,12 @@ showBindings = do
   where
     makeDoc (AnId i) = pprTypeAndContents i
     makeDoc tt = do
-        dflags    <- getDynFlags
-        let pefas = gopt Opt_PrintExplicitForalls dflags
         mb_stuff <- GHC.getInfo False (getName tt)
-        return $ maybe (text "") (pprTT pefas) mb_stuff
+        return $ maybe (text "") pprTT mb_stuff
 
-    pprTT :: PrintExplicitForalls
-          -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
-    pprTT pefas (thing, fixity, _cls_insts, _fam_insts) =
-        pprTyThing pefas thing
+    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
+    pprTT (thing, fixity, _cls_insts, _fam_insts)
+      = pprTyThing thing
         $$ show_fixity
       where
         show_fixity
@@ -2271,9 +2261,7 @@ showBindings = do
 
 
 printTyThing :: TyThing -> GHCi ()
-printTyThing tyth = do dflags <- getDynFlags
-                       let pefas = gopt Opt_PrintExplicitForalls dflags
-                       printForUser (pprTyThing pefas tyth)
+printTyThing tyth = printForUser (pprTyThing tyth)
 
 showBkptTable :: GHCi ()
 showBkptTable = do