Add -dsuppress-coercion-types to make coercions even smaller.

Instead of `` `cast` <Co:11> :: (Some -> Really -> Large Type)``
simply print `` `cast` <Co:11> :: ... ``

6 files changed, 23 insertions, 13 deletions

diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index c24e223553..d4b2cbeb93 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -172,8 +172,12 @@ noParens pp = pp
 pprOptCo :: Coercion -> SDoc
 -- Print a coercion optionally; i.e. honouring -dsuppress-coercions
 pprOptCo co = sdocOption sdocSuppressCoercions $ \case
-              True  -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> ppr (coercionType co)
-              False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]
+              True  -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type
+              False -> parens $ sep [ppr co, dcolon <+> co_type]
+    where
+      co_type = sdocOption sdocSuppressCoercionTypes $ \case
+          True -> text "..."
+          False -> ppr (coercionType co)
 
 ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
 ppr_id_occ add_par id
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index f158e6a42b..a4e5827bc6 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -399,8 +399,10 @@ data GeneralFlag
    | Opt_ShowLoadedModules
    | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]
 
-   -- Suppress all coercions, them replacing with '...'
+   -- Suppress a coercions inner structure, replacing it with '...'
    | Opt_SuppressCoercions
+   -- Suppress the type of a coercion as well
+   | Opt_SuppressCoercionTypes
    | Opt_SuppressVarKinds
    -- Suppress module id prefixes on variables.
    | Opt_SuppressModulePrefixes
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 061209d315..43f58884fc 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2376,6 +2376,7 @@ dynamic_flags_deps = [
   -- have otherwise identical names.
   , make_ord_flag defGhcFlag "dsuppress-all"
       (NoArg $ do setGeneralFlag Opt_SuppressCoercions
+                  setGeneralFlag Opt_SuppressCoercionTypes
                   setGeneralFlag Opt_SuppressVarKinds
                   setGeneralFlag Opt_SuppressModulePrefixes
                   setGeneralFlag Opt_SuppressTypeApplications
@@ -3330,6 +3331,7 @@ dFlagsDeps = [
      (useInstead "-d" "suppress-stg-exts"),
   flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,
   flagSpec "suppress-coercions"         Opt_SuppressCoercions,
+  flagSpec "suppress-coercion-types"    Opt_SuppressCoercionTypes,
   flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,
   flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,
   flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,
@@ -4997,6 +4999,7 @@ initSDocContext dflags style = SDC
   , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags
   , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags
   , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags
+  , sdocSuppressCoercionTypes       = gopt Opt_SuppressCoercionTypes dflags
   , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags
   , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags
   , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 6ff57e5775..c820c8b51d 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -381,6 +381,7 @@ data SDocContext = SDC
   , sdocSuppressTypeApplications    :: !Bool
   , sdocSuppressIdInfo              :: !Bool
   , sdocSuppressCoercions           :: !Bool
+  , sdocSuppressCoercionTypes       :: !Bool
   , sdocSuppressUnfoldings          :: !Bool
   , sdocSuppressVarKinds            :: !Bool
   , sdocSuppressUniques             :: !Bool
@@ -441,6 +442,7 @@ defaultSDocContext = SDC
   , sdocSuppressTypeApplications    = False
   , sdocSuppressIdInfo              = False
   , sdocSuppressCoercions           = False
+  , sdocSuppressCoercionTypes       = False
   , sdocSuppressUnfoldings          = False
   , sdocSuppressVarKinds            = False
   , sdocSuppressUniques             = False
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index abc685099b..0c09c4c3ec 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -915,6 +915,11 @@ parts that you are not interested in.
 
     Suppress the printing of type coercions.
 
+.. ghc-flag:: -dsuppress-coercion-types
+    :shortdesc: Suppress the printing of coercion types in Core dumps to make them
+        shorter
+    :type: dynamic
+
 .. ghc-flag:: -dsuppress-var-kinds
     :shortdesc: Suppress the printing of variable kinds
     :type: dynamic
diff --git a/testsuite/tests/numeric/should_compile/T15547.stderr b/testsuite/tests/numeric/should_compile/T15547.stderr
index e9dfbd0621..8560c4a8be 100644
--- a/testsuite/tests/numeric/should_compile/T15547.stderr
+++ b/testsuite/tests/numeric/should_compile/T15547.stderr
@@ -5,31 +5,25 @@ Result size of Tidy Core
 
 nat2Word#
   = \ @n $dKnownNat _ ->
-      naturalToWord# ($dKnownNat `cast` <Co:5> :: KnownNat n ~R# Natural)
+      naturalToWord# ($dKnownNat `cast` <Co:5> :: ...)
 
 foo = \ _ -> 18##
 
 fd
   = \ @n $dKnownNat _ ->
-      naturalToWord#
-        ($dKnownNat
-         `cast` <Co:13> :: KnownNat (Div (n + 63) 64) ~R# Natural)
+      naturalToWord# ($dKnownNat `cast` <Co:13> :: ...)
 
 d = \ _ -> 3##
 
 fm
   = \ @n $dKnownNat _ ->
-      naturalToWord#
-        ($dKnownNat
-         `cast` <Co:17> :: KnownNat (Mod (n - 1) 64 + 1) ~R# Natural)
+      naturalToWord# ($dKnownNat `cast` <Co:17> :: ...)
 
 m = \ _ -> 9##
 
 fp
   = \ @n $dKnownNat _ ->
-      naturalToWord#
-        ($dKnownNat
-         `cast` <Co:21> :: KnownNat (2 ^ (Mod (n + 63) 64 + 1)) ~R# Natural)
+      naturalToWord# ($dKnownNat `cast` <Co:21> :: ...)
 
 p = \ _ -> 512##