diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-04-05 16:58:14 +0100 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-04-08 09:25:56 +0100 |
commit | 64f69caa70c4404f17e83d9a8642b35f17dc696a (patch) | |
tree | f147f0b776fc7eb32bc207c4b45a67e7001e897e | |
parent | ce706faeef3964116c6e1dd0e6ae2f2e77fde57d (diff) | |
download | haskell-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.hs | 17 | ||||
-rw-r--r-- | 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 |