Fix printing of promoted unboxed tuples (#18653)wip/T18653

6 files changed, 25 insertions, 4 deletions

diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index d9cf158ef6..055ca17c97 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -1018,7 +1018,9 @@ mk_tuple Unboxed arity = (tycon, tuple_con)
                          UnboxedTuple flavour
 
     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> #
+    -- Example: the kind of (#,#) is
+    --        forall (k1::RuntimeRep) (k2::RuntimeRep). TYPE k1 -> TYPE k2 ->
+    --                                                  TYPE (TupleRep '[k1, k2])
     tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
                                         (\ks -> map tYPE ks)
 
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index a65e89853c..e05741d11b 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -189,8 +189,8 @@ toIfaceTypeX fr (TyConApp tc tys)
 
   | Just dc <- isPromotedDataCon_maybe tc
   , isBoxedTupleDataCon dc
-  , n_tys == 2*arity
-  = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
+  , n_tys == arity
+  = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc tys)
 
   | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
   , (k1:k2:_) <- tys
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 57c31920b4..3438d3f5e2 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -1573,7 +1573,18 @@ pprTuple ctxt_prec sort promoted args =
   case promoted of
     IsPromoted
       -> let tys = appArgsIfaceTypes args
-             args' = drop (length tys `div` 2) tys
+             -- For promoted boxed tuples, drop half of the type arguments:
+             -- display '(,) @Type @(Type -> Type) Int Maybe
+             -- as      '(Int, Maybe)
+             -- For promoted unboxed tuples, additionally drop RuntimeRep vars;
+             -- display '(#,#) @LiftedRep @LiftedRep @Type @(Type -> Type) Int Maybe
+             -- as      '(# Int, Maybe #)
+             -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
+             -- and ticket #18653
+             toDrop = case sort of
+                        UnboxedTuple -> 2 * length tys `div` 3
+                        _            ->     length tys `div` 2
+             args' = drop toDrop tys
              spaceIfPromoted = case args' of
                arg0:_ -> pprSpaceIfPromotedTyCon arg0
                _ -> id
diff --git a/testsuite/tests/ghci/scripts/T18653.script b/testsuite/tests/ghci/scripts/T18653.script
new file mode 100644
index 0000000000..491edc2e73
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T18653.script
@@ -0,0 +1,3 @@
+:set -XDataKinds -XUnboxedTuples
+:kind! '(#,,,#) Int Char Bool Maybe
+:kind! '(,,,) Int Char Bool Maybe
diff --git a/testsuite/tests/ghci/scripts/T18653.stdout b/testsuite/tests/ghci/scripts/T18653.stdout
new file mode 100644
index 0000000000..0c92aada31
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T18653.stdout
@@ -0,0 +1,4 @@
+'(#,,,#) Int Char Bool Maybe :: (# *, *, *, * -> * #)
+= '(# Int, Char, Bool, Maybe #)
+'(,,,) Int Char Bool Maybe :: (*, *, *, * -> *)
+= '(Int, Char, Bool, Maybe)
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 2f8aafe2e0..44ff14655a 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -319,3 +319,4 @@ test('T17431', normal, ghci_script, ['T17431.script'])
 test('T17549', normal, ghci_script, ['T17549.script'])
 test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_broken(17669)], ghci_script, ['T17669.script'])
 test('T18644', normal, ghci_script, ['T18644.script'])
+test('T18653', normal, ghci_script, ['T18653.script'])