diff options
| -rw-r--r-- | compiler/ghci/Debugger.hs | 5 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 2 | ||||
| -rw-r--r-- | compiler/main/PprTyThing.hs | 156 | ||||
| -rw-r--r-- | compiler/types/TypeRep.lhs | 126 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 52 |
5 files changed, 189 insertions, 152 deletions
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 0ceffcdcf1..0807bf17b5 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 918b1ae022..d52835db2c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 ), diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index f5c4bd2bb9..947d8b216f 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -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. diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index e0d435a10a..62c5a116ef 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -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 diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 220ee17b5a..4715474623 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -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 |