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.

3 files changed, 31 insertions, 14 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index fe3536157c..eb7a03febb 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -25,6 +25,7 @@ import GHC.Data.Bag
 import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars, mkClassPred)
+import GHC.Types.Basic (UnboxedTupleOrSum(..), unboxedTupleOrSumExtension)
 import GHC.Types.Error
 import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector)
 import GHC.Types.Id (isRecordSelector)
@@ -201,10 +202,14 @@ instance Diagnostic TcRnMessage where
     TcRnConstraintInKind ty
       -> mkSimpleDecorated $
            text "Illegal constraint in a kind:" <+> pprType ty
-    TcRnUnboxedTupleTypeFuncArg ty
+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty
       -> mkSimpleDecorated $
-           sep [ text "Illegal unboxed tuple type as function argument:"
+           sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:"
                , pprType ty ]
+        where
+          what = case tuple_or_sum of
+            UnboxedTupleType -> text "tuple"
+            UnboxedSumType   -> text "sum"
     TcRnLinearFuncInKind ty
       -> mkSimpleDecorated $
            text "Illegal linear function in a kind:" <+> pprType ty
@@ -630,7 +635,7 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnConstraintInKind{}
       -> ErrorWithoutFlag
-    TcRnUnboxedTupleTypeFuncArg{}
+    TcRnUnboxedTupleOrSumTypeFuncArg{}
       -> ErrorWithoutFlag
     TcRnLinearFuncInKind{}
       -> ErrorWithoutFlag
@@ -852,8 +857,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnConstraintInKind{}
       -> noHints
-    TcRnUnboxedTupleTypeFuncArg{}
-      -> [suggestExtension LangExt.UnboxedTuples]
+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _
+      -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum]
     TcRnLinearFuncInKind{}
       -> noHints
     TcRnForAllEscapeError{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index e84f30a7c0..f9de50f37a 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -635,8 +635,9 @@ data TcRnMessage where
   -}
   TcRnConstraintInKind :: !Type -> TcRnMessage
 
-  {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple type
-      is specified as a function argument.
+  {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple
+      or unboxed sum type is specified as a function argument, when the appropriate
+      extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled.
 
       Examples(s):
         -- T15073.hs
@@ -652,7 +653,10 @@ data TcRnMessage where
                   deriving/should_fail/T15073a.hs
                   typecheck/should_fail/T16059d
   -}
-  TcRnUnboxedTupleTypeFuncArg :: !Type -> TcRnMessage
+  TcRnUnboxedTupleOrSumTypeFuncArg
+    :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum
+    -> !Type
+    -> TcRnMessage
 
   {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is
       specified in a kind.
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 9c4b262333..b02271baf1 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -56,6 +56,7 @@ import GHC.Tc.Instance.FunDeps
 import GHC.Core.FamInstEnv
    ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) )
 import GHC.Tc.Instance.Family
+import GHC.Types.Basic   ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension )
 import GHC.Types.Name
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
@@ -693,8 +694,14 @@ check_type ve (AppTy ty1 ty2)
 check_type ve ty@(TyConApp tc tys)
   | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
   = check_syn_tc_app ve ty tc tys
+
+  -- Check for unboxed tuples and unboxed sums: these
+  -- require the corresponding extension to be enabled.
   | isUnboxedTupleTyCon tc
-  = check_ubx_tuple ve ty tys
+  = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys
+  | isUnboxedSumTyCon tc
+  = check_ubx_tuple_or_sum UnboxedSumType   ve ty tys
+
   | otherwise
   = mapM_ (check_arg_type False ve) tys
 
@@ -838,16 +845,17 @@ field to False.
 -}
 
 ----------------------------------------
-check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
-check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys
-  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
-        ; checkTcM ub_tuples_allowed (env, TcRnUnboxedTupleTypeFuncArg (tidyType env ty))
+check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
+check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys
+  = do  { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum
+        ; checkTcM ub_thing_allowed
+            (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty))
 
         ; impred <- xoptM LangExt.ImpredicativeTypes
         ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg
                 -- c.f. check_arg_type
                 -- However, args are allowed to be unlifted, or
-                -- more unboxed tuples, so can't use check_arg_ty
+                -- more unboxed tuples or sums, so can't use check_arg_ty
         ; mapM_ (check_type (ve{ve_rank = rank'})) tys }
 
 ----------------------------------------