Commit 66c5ddba authored by unknown's avatar unknown

Improve pretty-printing of types

* 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
parent bceeb016
......@@ -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
......
......@@ -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 ),
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment