From: simonpj@microsoft.com Date: Tue, 11 Sep 2007 08:51:23 +0000 (+0000) Subject: Define and use PprTyThing.pprTypeForUser X-Git-Tag: 2007-09-25~103 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=046feb1ea3b3dafb21c43fda88778198c1c709d6 Define and use PprTyThing.pprTypeForUser When printing types for the user, the interactive UI often wants to leave foralls implicit. But then (as Claus points out) we need to be careful about name capture. For example with this source program class C a b where op :: forall a. a -> b we were erroneously displaying the class in GHCi (with suppressed foralls) thus: class C a b where op :: a -> b which is utterly wrong. This patch fixes the problem, removes GHC.dropForAlls (which is dangerous), and instead supplies PprTyThing.pprTypeForUser, which does the right thing. --- diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index fd84f9d..e0fddac 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -26,12 +26,12 @@ import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) +import PprTyThing import DynFlags import Packages import PackageConfig import UniqFM import HscTypes ( implicitTyThings ) -import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name @@ -610,12 +610,13 @@ afterRunStmt step_here run_result = do let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` io (mapM (GHC.lookupName session) namesSorted) - docs_ty <- mapM showTyThing tythings - terms <- mapM (io . GHC.obtainTermB session 10 False) - [ id | (AnId id, Just _) <- zip tythings docs_ty] + let ids = [id | AnId id <- tythings] + terms <- mapM (io . GHC.obtainTermB session 10 False) ids docs_terms <- mapM (io . showTerm session) terms - printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) - (catMaybes docs_ty) + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) + (map (pprTyThing pefas . AnId) ids) docs_terms runBreakCmd :: GHC.BreakInfo -> GHCi () @@ -991,8 +992,10 @@ typeOfExpr str maybe_ty <- io (GHC.exprType cms str) case maybe_ty of Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + Just ty -> do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str @@ -1000,7 +1003,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + Just ty -> printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1299,26 +1302,10 @@ showBindings = do compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 -showTyThing :: TyThing -> GHCi (Maybe SDoc) -showTyThing (AnId id) = do - ty' <- cleanType (GHC.idType id) - return $ Just $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return Nothing - printTyThing :: TyThing -> GHCi () -printTyThing tyth = do - mb_x <- showTyThing tyth - case mb_x of - Just x -> printForUser x - Nothing -> return () - --- if -fglasgow-exts is on we show the foralls, otherwise we don't. -cleanType :: Type -> GHCi Type -cleanType ty = do - dflags <- getDynFlags - if dopt Opt_PrintExplicitForalls dflags - then return ty - else return $! GHC.dropForAlls ty +printTyThing tyth = do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 31894b8..707a81d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -154,8 +154,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d58bd11..6a0bf82 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -19,16 +19,19 @@ module PprTyThing ( pprTyThingInContext, pprTyThingLoc, pprTyThingInContextLoc, - pprTyThingHdr + pprTyThingHdr, + pprTypeForUser ) where #include "HsVersions.h" import qualified GHC +import GHC ( TyThing(..) ) import TyCon ( tyConFamInst_maybe ) -import Type ( pprTypeApp ) -import GHC ( TyThing(..), SrcSpan ) +import Type ( TyThing(..), tidyTopType, pprTypeApp ) +import TcType ( tcMultiSplitSigmaTy, mkPhiTy ) +import SrcLoc ( SrcSpan ) import Var import Name import Outputable @@ -98,7 +101,7 @@ pprTyConHdr pefas tyCon | otherwise = empty pprDataConSig pefas dataCon = - ppr_bndr dataCon <+> dcolon <+> pprType pefas (GHC.dataConType dataCon) + ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon) pprClassHdr pefas cls = let (tyVars, funDeps) = GHC.classTvsFds cls @@ -122,21 +125,33 @@ pprRecordSelector pefas id pprId :: PrintExplicitForalls -> Var -> SDoc pprId pefas ident - = hang (ppr_bndr ident <+> dcolon) 2 - (pprType pefas (GHC.idType ident)) - -pprType :: PrintExplicitForalls -> GHC.Type -> SDoc -pprType True ty = ppr ty -pprType False ty = ppr (GHC.dropForAlls ty) + = hang (ppr_bndr ident <+> dcolon) + 2 (pprTypeForUser pefas (GHC.idType ident)) + +pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc +-- We do two things here. +-- a) We tidy the type, regardless +-- b) If 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 [p | (_tvs, ps) <- ctxt, p <- ps] ty') + where + tidy_ty = tidyTopType ty + (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty pprTyCon pefas tyCon | GHC.isSynTyCon tyCon = if GHC.isOpenTyCon tyCon then pprTyConHdr pefas tyCon <+> dcolon <+> - pprType pefas (GHC.synTyConResKind tyCon) + pprTypeForUser pefas (GHC.synTyConResKind tyCon) else let rhs_type = GHC.synTyConType tyCon - in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprType pefas rhs_type) + in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) | otherwise = pprAlgTyCon pefas tyCon (const True) (const True) @@ -209,21 +224,31 @@ pprClass pefas cls where methods = GHC.classMethods cls -pprClassOneMethod pefas cls this_one = - hang (pprClassHdr pefas cls <+> ptext SLIT("where")) - 2 (vcat (ppr_trim show_meth methods)) +pprClassOneMethod pefas cls this_one + = hang (pprClassHdr pefas cls <+> ptext SLIT("where")) + 2 (vcat (ppr_trim show_meth methods)) where methods = GHC.classMethods cls show_meth id | id == this_one = Just (pprClassMethod pefas id) | otherwise = Nothing -pprClassMethod pefas id = - hang (ppr_bndr id <+> dcolon) 2 (pprType pefas (classOpType id)) +pprClassMethod pefas id + = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty) where -- Here's the magic incantation to strip off the dictionary -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. - classOpType id = GHC.funResultTy rho_ty - where (_sel_tyvars, rho_ty) = GHC.splitForAllTys (GHC.idType id) + -- + -- It's important to tidy it *before* splitting it up, so that if + -- we have class C a b where + -- op :: forall a. a -> b + -- then the inner forall on op gets renamed to a1, and we print + -- (when dropping foralls) + -- class C a b where + -- op :: a1 -> b + + tidy_sel_ty = tidyTopType (GHC.idType id) + (_sel_tyvars, rho_ty) = GHC.splitForAllTys tidy_sel_ty + op_ty = GHC.funResultTy rho_ty ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs