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 (file)
--- 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 (file)
--- 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 (file)
--- 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