From 64f69caa70c4404f17e83d9a8642b35f17dc696a Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 5 Apr 2021 16:58:14 +0100
Subject: Don't tidy type in pprTypeForUser

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)
---
 compiler/GHC/Types/TyThing/Ppr.hs | 17 ++---------------
 ghc/GHCi/UI.hs                    | 15 ++++++++-------
 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
-- 
cgit v1.2.1