Do not print synonyms in :i (->), :i Type (#18594)

This adds a new printing flag `sdocPrintTypeAbbreviations` that is used
specifically to avoid ghci printing 'type (->) = (->)' and 'type Type = Type'.

11 files changed, 61 insertions, 8 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index b5ded38737..2c6c3affbd 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -5079,6 +5079,7 @@ initSDocContext dflags style = SDC
   , sdocStarIsType                  = xopt LangExt.StarIsType dflags
   , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags
   , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags
+  , sdocPrintTypeAbbreviations      = True
   , sdocDynFlags                    = dflags
   }
 
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 842bb2815a..bd576b26cf 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -45,6 +45,8 @@ module GHC.Iface.Syntax (
 
 import GHC.Prelude
 
+import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey )
+import GHC.Types.Unique ( hasKey )
 import GHC.Iface.Type
 import GHC.Iface.Recomp.Binary
 import GHC.Core( IsOrphan, isOrphan )
@@ -947,13 +949,19 @@ pprIfaceDecl ss (IfaceSynonym { ifName    = tc
                               , ifResKind = res_kind})
   = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)
          , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals)
-           2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
+           2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau
                   , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
          ]
   where
     (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
     name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc)
 
+    -- See Note [Printing type abbreviations] in GHC.Iface.Type
+    ppr_tau | tc `hasKey` liftedTypeKindTyConKey ||
+              tc `hasKey` unrestrictedFunTyConKey
+            = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau
+            | otherwise = ppr tau
+
     -- See Note [Suppressing binder signatures] in GHC.Iface.Type
     suppress_bndr_sig = SuppressBndrSig True
 
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 52d07f0fcb..1067e6cab3 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -783,6 +783,22 @@ Here we'd like to omit the kind annotation:
 
    type F :: Symbol -> Type
    type F s = blah
+
+Note [Printing type abbreviations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and
+`FUN 'Many` as `(->)`.
+This way, error messages don't refer to levity polymorphism or linearity
+if it is not necessary.
+
+However, when printing the definition of Type or (->) with :info,
+this would give confusing output: `type (->) = (->)` (#18594).
+Solution: detect when we are in :info and disable displaying the synonym
+with the SDoc option sdocPrintTypeAbbreviations.
+
+If there will be a need, in the future we could expose it as a flag
+-fprint-type-abbreviations or even two separate flags controlling
+TYPE 'LiftedRep and FUN 'Many.
 -}
 
 -- | Do we want to suppress kind annotations on binders?
@@ -1364,12 +1380,14 @@ pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
 pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
 pprTyTcApp ctxt_prec tc tys =
     sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+    sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
     getPprDebug $ \debug ->
-    pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) debug
+    pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds)
+                print_type_abbreviations debug
 
 pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
-            -> PrintExplicitKinds -> Bool -> SDoc
-pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug
+            -> PrintExplicitKinds -> Bool -> Bool -> SDoc
+pprTyTcApp' ctxt_prec tc tys printExplicitKinds printTypeAbbreviations debug
   | ifaceTyConName tc `hasKey` ipClassKey
   , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
            Required (IA_Arg ty Required IA_Nil) <- tys
@@ -1393,11 +1411,13 @@ pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug
   | tc `ifaceTyConHasKey` tYPETyConKey
   , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
   , rep `ifaceTyConHasKey` liftedRepDataConKey
+  , printTypeAbbreviations  -- See Note [Printing type abbreviations]
   = ppr_kind_type ctxt_prec
 
   | tc `ifaceTyConHasKey` funTyConKey
   , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys
   , rep `ifaceTyConHasKey` manyDataConKey
+  , printTypeAbbreviations  -- See Note [Printing type abbreviations]
   = pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) (appArgsIfaceTypes $ stripInvisArgs printExplicitKinds args))
 
   | otherwise
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 1875d8faf9..23bceff20a 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -344,6 +344,7 @@ data SDocContext = SDC
   , sdocStarIsType                  :: !Bool
   , sdocLinearTypes                 :: !Bool
   , sdocImpredicativeTypes          :: !Bool
+  , sdocPrintTypeAbbreviations      :: !Bool
   , sdocDynFlags                    :: DynFlags -- TODO: remove
   }
 
@@ -390,6 +391,7 @@ defaultSDocContext = SDC
   , sdocStarIsType                  = False
   , sdocImpredicativeTypes          = False
   , sdocLinearTypes                 = False
+  , sdocPrintTypeAbbreviations      = True
   , sdocDynFlags                    = error "defaultSDocContext: DynFlags not available"
   }
 
diff --git a/testsuite/tests/ghci/T18060/T18060.stdout b/testsuite/tests/ghci/T18060/T18060.stdout
index 8c3a2794fe..9e4683a1c4 100644
--- a/testsuite/tests/ghci/T18060/T18060.stdout
+++ b/testsuite/tests/ghci/T18060/T18060.stdout
@@ -1,5 +1,5 @@
 type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
   	-- Defined in ‘GHC.Types’
 infixr -1 ->
 instance Applicative ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout
index f7e40fd0f4..5786372e9d 100644
--- a/testsuite/tests/ghci/scripts/T8535.stdout
+++ b/testsuite/tests/ghci/scripts/T8535.stdout
@@ -1,5 +1,5 @@
 type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
   	-- Defined in ‘GHC.Types’
 infixr -1 ->
 instance Applicative ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout
index f7e40fd0f4..5786372e9d 100644
--- a/testsuite/tests/ghci/scripts/ghci020.stdout
+++ b/testsuite/tests/ghci/scripts/ghci020.stdout
@@ -1,5 +1,5 @@
 type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
   	-- Defined in ‘GHC.Types’
 infixr -1 ->
 instance Applicative ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout
index f7e40fd0f4..5786372e9d 100644
--- a/testsuite/tests/ghci/should_run/T10145.stdout
+++ b/testsuite/tests/ghci/should_run/T10145.stdout
@@ -1,5 +1,5 @@
 type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
   	-- Defined in ‘GHC.Types’
 infixr -1 ->
 instance Applicative ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/should_run/T18594.script b/testsuite/tests/ghci/should_run/T18594.script
new file mode 100644
index 0000000000..815275914c
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T18594.script
@@ -0,0 +1,6 @@
+:m GHC.Types
+:i (->)
+:set -XStarIsType
+:i Type
+:set -XNoStarIsType
+:i Type
diff --git a/testsuite/tests/ghci/should_run/T18594.stdout b/testsuite/tests/ghci/should_run/T18594.stdout
new file mode 100644
index 0000000000..9e2e79cd8b
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T18594.stdout
@@ -0,0 +1,15 @@
+type (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
+  	-- Defined in ‘GHC.Types’
+infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Base’
+instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
+instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’
+type Type :: *
+type Type = TYPE 'LiftedRep
+  	-- Defined in ‘GHC.Types’
+type Type :: Type
+type Type = TYPE 'LiftedRep
+  	-- Defined in ‘GHC.Types’
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index 8130d512d4..3de49c1f34 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -75,3 +75,4 @@ test('T18064',
     ],
    ghci_script,
    ['T18064.script'])
+test('T18594', just_ghci, ghci_script, ['T18594.script'])