Commit 046feb1e authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent deda0c55
......@@ -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
......
......@@ -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,
......
......@@ -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
......
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