summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-04-05 16:58:14 +0100
committerMatthew Pickering <matthewtpickering@gmail.com>2021-04-08 09:25:56 +0100
commit64f69caa70c4404f17e83d9a8642b35f17dc696a (patch)
treef147f0b776fc7eb32bc207c4b45a67e7001e897e
parentce706faeef3964116c6e1dd0e6ae2f2e77fde57d (diff)
downloadhaskell-wip/no-tidy-ghci.tar.gz
Don't tidy type in pprTypeForUserwip/no-tidy-ghci
There used to be some cases were kinds were not generalised properly before being printed in GHCi. This seems to have changed in the past so now it's uncessary to tidy before printing out the test case. ``` > :set -XPolyKinds > data A x y > :k A k1 -> k2 -> A ``` This tidying was causing issues with an attempt to increase sharing by making `mkTyConApp` (see !4762)
-rw-r--r--compiler/GHC/Types/TyThing/Ppr.hs17
-rw-r--r--ghc/GHCi/UI.hs15
2 files changed, 10 insertions, 22 deletions
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
index aad90365a7..b4084f9bf8 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ b/compiler/GHC/Types/TyThing/Ppr.hs
@@ -13,7 +13,6 @@ module GHC.Types.TyThing.Ppr (
pprTyThingLoc,
pprTyThingInContextLoc,
pprTyThingHdr,
- pprTypeForUser,
pprFamInst
) where
@@ -25,12 +24,11 @@ import GHC.Driver.Ppr (warnPprTrace)
import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )
import GHC.Types.Name
-import GHC.Types.Var.Env( emptyTidyEnv )
-import GHC.Core.Type ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )
+import GHC.Core.Type ( ArgFlag(..), mkTyVarBinders )
import GHC.Core.Coercion.Axiom ( coAxiomTyCon )
import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )
-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )
+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )
import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
, showToHeader, pprIfaceDecl )
@@ -192,17 +190,6 @@ pprTyThing ss ty_thing
Nothing -> WARN( True, ppr name ) Nothing
-- Nothing is unexpected here; TyThings have External names
-pprTypeForUser :: Type -> SDoc
--- The type is tidied
-pprTypeForUser ty
- = pprSigmaType tidy_ty
- where
- (_, tidy_ty) = tidyOpenType emptyTidyEnv ty
- -- Often the types/kinds we print in ghci are fully generalised
- -- and have no free variables, but it turns out that we sometimes
- -- print un-generalised kinds (eg when doing :k T), so it's
- -- better to use tidyOpenType here
-
showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index a97200c5c3..80700e9caf 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -66,6 +66,7 @@ import GHC.Driver.Env
import GHC.Runtime.Context
import GHC.Types.TyThing
import GHC.Types.TyThing.Ppr
+import GHC.Core.TyCo.Ppr
import GHC.Types.SafeHaskell ( getSafeMode )
import GHC.Types.Name
import GHC.Types.SourceText
@@ -1855,10 +1856,10 @@ sigAndLocDoc :: String -> TyThing -> SDoc
sigAndLocDoc str tyThing =
let tyThingTyDoc :: TyThing -> SDoc
tyThingTyDoc = \case
- AnId i -> pprTypeForUser $ varType i
- AConLike (RealDataCon dc) -> pprTypeForUser $ dataConDisplayType False dc
+ AnId i -> pprSigmaType $ varType i
+ AConLike (RealDataCon dc) -> pprSigmaType $ dataConDisplayType False dc
AConLike (PatSynCon patSyn) -> pprPatSynType patSyn
- ATyCon tyCon -> pprTypeForUser $ GHC.tyConKind tyCon
+ ATyCon tyCon -> pprSigmaType $ GHC.tyConKind tyCon
ACoAxiom _ -> empty
tyDoc = tyThingTyDoc tyThing
@@ -2229,7 +2230,7 @@ typeOfExpr str = handleSourceError GHC.printException $
do_it mode expr_str
= do { ty <- GHC.exprType mode expr_str
; printForUser $ sep [ text expr_str
- , nest 2 (dcolon <+> pprTypeForUser ty)] }
+ , nest 2 (dcolon <+> pprSigmaType ty)] }
-----------------------------------------------------------------------------
-- | @:type-at@ command
@@ -2277,7 +2278,7 @@ allTypesCmd _ = runExceptGhcMonad $ do
let tyInfo = unwords . words $
showSDocForUser (hsc_dflags hsc_env)
(hsc_units hsc_env)
- alwaysQualify (pprTypeForUser ty)
+ alwaysQualify (pprSigmaType ty)
liftIO . putStrLn $
showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
| otherwise = return ()
@@ -2362,8 +2363,8 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()
kindOfType norm str = handleSourceError GHC.printException $ do
(ty, kind) <- GHC.typeKind norm str
- printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
- , ppWhen norm $ equals <+> pprTypeForUser ty ]
+ printForUser $ vcat [ text str <+> dcolon <+> pprSigmaType kind
+ , ppWhen norm $ equals <+> pprSigmaType ty ]
-----------------------------------------------------------------------------
-- :quit