Fix parsing & printing of unboxed sums

The pretty-printing of partially applied unboxed sums was incorrect,
as we incorrectly dropped the first half of the arguments, even
for a partial application such as

  (# | #) @IntRep @DoubleRep Int#

which lead to the nonsensical (# DoubleRep | Int# #).

This patch also allows users to write unboxed sum type constructors
such as

  (# | #) :: TYPE r1 -> TYPE r2 -> TYPE (SumRep '[r1,r2]).

Fixes #20858 and #20859.

10 files changed, 151 insertions, 0 deletions

diff --git a/testsuite/tests/unboxedsums/T20858.hs b/testsuite/tests/unboxedsums/T20858.hs
new file mode 100644
index 0000000000..cada160764
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20858.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module T20858 where
+
+import Data.Kind
+  ( Type )
+import GHC.Exts
+  ( Double#, Int#, Word# )
+
+type GetFunKind :: k -> Type
+type family GetFunKind x where
+  forall arg_k res_k (a :: arg_k -> res_k) (b :: arg_k). GetFunKind (a b) = arg_k -> res_k
+
+type GetFun :: forall res_k. forall (x :: res_k) -> GetFunKind x
+type family GetFun x where
+  GetFun (a b) = a
+
+type S1 = GetFun (# Int# | Double# | Word# #)
+type S2 = GetFun S1
+type S3 = GetFun S2
diff --git a/testsuite/tests/unboxedsums/T20858.script b/testsuite/tests/unboxedsums/T20858.script
new file mode 100644
index 0000000000..ab91eb1444
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20858.script
@@ -0,0 +1,5 @@
+:seti -XUnboxedSums
+:l T20858
+:kind! S1
+:kind! S2
+:kind! S3
diff --git a/testsuite/tests/unboxedsums/T20858.stdout b/testsuite/tests/unboxedsums/T20858.stdout
new file mode 100644
index 0000000000..2c50fc3e80
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20858.stdout
@@ -0,0 +1,18 @@
+S1 :: TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              '[ 'GHC.Types.IntRep, 'GHC.Types.DoubleRep, 'GHC.Types.WordRep])
+= (# | | #) Int# Double#
+S2 :: TYPE 'GHC.Types.DoubleRep
+      -> TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              '[ 'GHC.Types.IntRep, 'GHC.Types.DoubleRep, 'GHC.Types.WordRep])
+= (# | | #) Int#
+S3 :: TYPE 'GHC.Types.IntRep
+      -> TYPE 'GHC.Types.DoubleRep
+      -> TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              '[ 'GHC.Types.IntRep, 'GHC.Types.DoubleRep, 'GHC.Types.WordRep])
+= (# | | #)
diff --git a/testsuite/tests/unboxedsums/T20858b.script b/testsuite/tests/unboxedsums/T20858b.script
new file mode 100644
index 0000000000..ab91eb1444
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20858b.script
@@ -0,0 +1,5 @@
+:seti -XUnboxedSums
+:l T20858
+:kind! S1
+:kind! S2
+:kind! S3
diff --git a/testsuite/tests/unboxedsums/T20858b.stdout b/testsuite/tests/unboxedsums/T20858b.stdout
new file mode 100644
index 0000000000..e9818ad468
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20858b.stdout
@@ -0,0 +1,52 @@
+S1 :: TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              ((':)
+                 @GHC.Types.RuntimeRep
+                 'GHC.Types.IntRep
+                 ((':)
+                    @GHC.Types.RuntimeRep
+                    'GHC.Types.DoubleRep
+                    ((':)
+                       @GHC.Types.RuntimeRep
+                       'GHC.Types.WordRep
+                       ('[] @GHC.Types.RuntimeRep)))))
+= (# | | #)
+    @'GHC.Types.IntRep
+    @'GHC.Types.DoubleRep
+    @'GHC.Types.WordRep
+    Int#
+    Double#
+S2 :: TYPE 'GHC.Types.DoubleRep
+      -> TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              ((':)
+                 @GHC.Types.RuntimeRep
+                 'GHC.Types.IntRep
+                 ((':)
+                    @GHC.Types.RuntimeRep
+                    'GHC.Types.DoubleRep
+                    ((':)
+                       @GHC.Types.RuntimeRep
+                       'GHC.Types.WordRep
+                       ('[] @GHC.Types.RuntimeRep)))))
+= (# | | #)
+    @'GHC.Types.IntRep @'GHC.Types.DoubleRep @'GHC.Types.WordRep Int#
+S3 :: TYPE 'GHC.Types.IntRep
+      -> TYPE 'GHC.Types.DoubleRep
+      -> TYPE 'GHC.Types.WordRep
+      -> TYPE
+           ('GHC.Types.SumRep
+              ((':)
+                 @GHC.Types.RuntimeRep
+                 'GHC.Types.IntRep
+                 ((':)
+                    @GHC.Types.RuntimeRep
+                    'GHC.Types.DoubleRep
+                    ((':)
+                       @GHC.Types.RuntimeRep
+                       'GHC.Types.WordRep
+                       ('[] @GHC.Types.RuntimeRep)))))
+= (# | | #)
+    @'GHC.Types.IntRep @'GHC.Types.DoubleRep @'GHC.Types.WordRep
diff --git a/testsuite/tests/unboxedsums/T20859.hs b/testsuite/tests/unboxedsums/T20859.hs
new file mode 100644
index 0000000000..5e7c14bab1
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T20859.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module T20859 where
+
+import GHC.Exts
+  ( Double#, Int#, Word# )
+
+foo :: (# Int# | Double# | Word# #) -> (# | | #) Int# Double# Word#
+foo x = x
diff --git a/testsuite/tests/unboxedsums/UnboxedSumsTH.hs b/testsuite/tests/unboxedsums/UnboxedSumsTH.hs
new file mode 100644
index 0000000000..5bf912bc11
--- /dev/null
+++ b/testsuite/tests/unboxedsums/UnboxedSumsTH.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module UnboxedSumsTH where
+
+import Data.Proxy
+import Language.Haskell.TH
+
+-- Check that we can quote the type constructor (# | #).
+testTC :: Proxy (# | #)
+testTC = $( conE 'Proxy `appTypeE` conT ''(# | #) )
diff --git a/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.hs b/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.hs
new file mode 100644
index 0000000000..46ed1c13c1
--- /dev/null
+++ b/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module UnboxedSumsTH_Fail where
+
+import Data.Proxy
+import Language.Haskell.TH
+
+-- (# | #) is not a valid data constructor,
+-- as it doesn't indicate which alternative we are taking.
+testDC :: (# Integer | Bool #)
+testDC = $( conE '(# | #) `appE` litE (IntegerL 77) )
diff --git a/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.stderr b/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.stderr
new file mode 100644
index 0000000000..d8b7f25bd8
--- /dev/null
+++ b/testsuite/tests/unboxedsums/UnboxedSumsTH_Fail.stderr
@@ -0,0 +1,2 @@
+
+UnboxedSumsTH_Fail.hs:13:22: error: parse error on input ‘|’
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index c3cf9f1559..ba25543d54 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -17,6 +17,9 @@ test('unboxedsums10', omit_ways(['ghci']), compile_and_run, [''])
 test('unboxedsums11', omit_ways(['ghci']), compile_and_run, [''])
 test('unboxedsums12', omit_ways(['ghci']), compile, [''])
 
+test('UnboxedSumsTH', omit_ways(['ghci']), compile, [''])
+test('UnboxedSumsTH_Fail', omit_ways(['ghci']), compile_fail, [''])
+
 test('ffi1', normal, compile_fail, [''])
 test('thunk', only_ways(['normal']), compile_and_run, [''])
 test('T12375', only_ways(['normal']), compile_and_run, [''])
@@ -27,3 +30,8 @@ test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
 test('UbxSumLevPoly', normal, compile, ['-Wno-overlapping-patterns'])
 test('T14051', normal, multi_compile, ['T14051.hs', [('T14051a.hs', '')], '-O2 -v0'])
 test('T19645', normal, compile_and_run, [''])
+test('T20858', normal, ghci_script, ['T20858.script'])
+test('T20858b', [extra_files(['T20858.hs'])
+                ,extra_hc_opts("-fprint-explicit-runtime-reps -fprint-explicit-kinds")]
+              , ghci_script, ['T20858b.script'])
+test('T20859', normal, compile, [''])