From 02191891c080137a161c7861706db3dd484254d1 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Sat, 12 Sep 2020 18:01:51 +0200 Subject: Fix printing of promoted unboxed tuples (#18653) --- compiler/GHC/Builtin/Types.hs | 4 +++- compiler/GHC/CoreToIface.hs | 4 ++-- compiler/GHC/Iface/Type.hs | 13 ++++++++++++- testsuite/tests/ghci/scripts/T18653.script | 3 +++ testsuite/tests/ghci/scripts/T18653.stdout | 4 ++++ testsuite/tests/ghci/scripts/all.T | 1 + 6 files changed, 25 insertions(+), 4 deletions(-) create mode 100644 testsuite/tests/ghci/scripts/T18653.script create mode 100644 testsuite/tests/ghci/scripts/T18653.stdout 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']) -- cgit v1.2.1