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, 121 insertions, 46 deletions

diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index bcd74e59f4..6be9ecd293 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -202,7 +202,7 @@ import GHC.Utils.Panic.Plain
 
 import qualified Data.ByteString.Char8 as BS
 
-import Data.List        ( elemIndex )
+import Data.List        ( elemIndex, intersperse )
 
 alpha_tyvar :: [TyVar]
 alpha_tyvar = [alphaTyVar]
@@ -918,23 +918,31 @@ isBuiltInOcc_maybe occ =
 
       -- unboxed sum tycon
       _ | Just rest <- "(#" `BS.stripPrefix` name
-        , (pipes, rest') <- BS.span (=='|') rest
+        , (nb_pipes, rest') <- span_pipes rest
         , "#)" <- rest'
-             -> Just $ tyConName $ sumTyCon (1+BS.length pipes)
+             -> Just $ tyConName $ sumTyCon (1+nb_pipes)
 
       -- unboxed sum datacon
       _ | Just rest <- "(#" `BS.stripPrefix` name
-        , (pipes1, rest') <- BS.span (=='|') rest
+        , (nb_pipes1, rest') <- span_pipes rest
         , Just rest'' <- "_" `BS.stripPrefix` rest'
-        , (pipes2, rest''') <- BS.span (=='|') rest''
+        , (nb_pipes2, rest''') <- span_pipes rest''
         , "#)" <- rest'''
-             -> let arity = BS.length pipes1 + BS.length pipes2 + 1
-                    alt = BS.length pipes1 + 1
+             -> let arity = nb_pipes1 + nb_pipes2 + 1
+                    alt = nb_pipes1 + 1
                 in Just $ dataConName $ sumDataCon alt arity
       _ -> Nothing
   where
     name = bytesFS $ occNameFS occ
 
+    span_pipes :: BS.ByteString -> (Int, BS.ByteString)
+    span_pipes = go 0
+      where
+        go nb_pipes bs = case BS.uncons bs of
+          Just ('|',rest) -> go (nb_pipes + 1) rest
+          Just (' ',rest) -> go nb_pipes       rest
+          _               -> (nb_pipes, bs)
+
     choose_ns :: Name -> Name -> Name
     choose_ns tc dc
       | isTcClsNameSpace ns   = tc
@@ -1236,16 +1244,16 @@ mkSumTyConOcc :: Arity -> OccName
 mkSumTyConOcc n = mkOccName tcName str
   where
     -- No need to cache these, the caching is done in mk_sum
-    str = '(' : '#' : bars ++ "#)"
-    bars = replicate (n-1) '|'
+    str = '(' : '#' : ' ' : bars ++ " #)"
+    bars = intersperse ' ' $ replicate (n-1) '|'
 
 -- | OccName for i-th alternative of n-ary unboxed sum data constructor.
 mkSumDataConOcc :: ConTag -> Arity -> OccName
 mkSumDataConOcc alt n = mkOccName dataName str
   where
     -- No need to cache these, the caching is done in mk_sum
-    str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)"
-    bars i = replicate i '|'
+    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"
+    bars i = intersperse ' ' $ replicate i '|'
 
 -- | Type constructor for n-ary unboxed sum.
 sumTyCon :: Arity -> TyCon
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index b0b37a822c..780a38e3d7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3851,6 +3851,10 @@ impliedXFlags
     , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)
     , (LangExt.Strict, turnOn, LangExt.StrictData)
 
+    -- Historically only UnboxedTuples was required for unboxed sums to work.
+    -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.
+    , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)
+
     -- The extensions needed to declare an H98 unlifted data type
     , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)
     , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index c984303ac4..4ee786fac6 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -251,13 +251,13 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
 data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
 
                     | IfaceTupleTyCon !Arity !TupleSort
-                      -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@.
+                      -- ^ a tuple, e.g. @(a, b, c)@ or @(#a, b, c#)@.
                       -- The arity is the tuple width, not the tycon arity
                       -- (which is twice the width in the case of unboxed
                       -- tuples).
 
                     | IfaceSumTyCon !Arity
-                      -- ^ e.g. @(a | b | c)@
+                      -- ^ an unboxed sum, e.g. @(# a | b | c #)@
 
                     | IfaceEqualityTyCon
                       -- ^ A heterogeneous equality TyCon
@@ -928,7 +928,7 @@ ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty
 ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reason for IfaceFreeTyVar!
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [Free tyvars in IfaceType]
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
-ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated
 ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n
         -- Function types
 ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2)  -- Should be VisArg
@@ -1461,9 +1461,13 @@ pprTyTcApp ctxt_prec tc tys =
        , not debug
        , arity == ifaceVisAppArgsLength tys
        -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
+           -- NB: pprTuple requires a saturated tuple.
 
        | IfaceSumTyCon arity <- ifaceTyConSort info
-       -> pprSum arity (ifaceTyConIsPromoted info) tys
+       , not debug
+       , arity == ifaceVisAppArgsLength tys
+       -> pprSum (ifaceTyConIsPromoted info) tys
+           -- NB: pprSum requires a saturated unboxed sum.
 
        | tc `ifaceTyConHasKey` consDataConKey
        , False <- print_kinds
@@ -1627,8 +1631,13 @@ ppr_iface_tc_app pp ctxt_prec tc tys
   | otherwise
   = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
 
-pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc
-pprSum _arity is_promoted args
+-- | Pretty-print an unboxed sum type. The sum should be saturated:
+-- as many visible arguments as the arity of the sum.
+--
+-- NB: this always strips off the invisible 'RuntimeRep' arguments,
+-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.
+pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc
+pprSum is_promoted args
   =   -- drop the RuntimeRep vars.
       -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
     let tys   = appArgsIfaceTypes args
@@ -1636,6 +1645,12 @@ pprSum _arity is_promoted args
     in pprPromotionQuoteI is_promoted
        <> sumParens (pprWithBars (ppr_ty topPrec) args')
 
+-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).
+-- The tuple should be saturated: as many visible arguments as the arity of
+-- the tuple.
+--
+-- NB: this always strips off the invisible 'RuntimeRep' arguments,
+-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.
 pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc
 pprTuple ctxt_prec sort promoted args =
   case promoted of
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index c93ce8ff4c..5d8a9c2c9d 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -92,7 +92,8 @@ import GHC.Parser.Annotation
 import GHC.Parser.Errors.Types
 import GHC.Parser.Errors.Ppr ()
 
-import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
+import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,
+                           tupleTyCon, tupleDataCon, nilDataCon,
                            unboxedUnitTyCon, unboxedUnitDataCon,
                            listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)
 
@@ -3043,11 +3044,13 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }
                       ; return (Tuple (cos ++ $2)) } }
 
            | texp bars   { unECP $1 >>= \ $1 -> return $
-                            (Sum 1  (snd $2 + 1) $1 [] (fst $2)) }
+                            (Sum 1  (snd $2 + 1) $1 [] (map (EpaSpan . realSrcSpan) $ fst $2)) }
 
            | bars texp bars0
                 { unECP $2 >>= \ $2 -> return $
-                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }
+                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2
+                    (map (EpaSpan . realSrcSpan) $ fst $1)
+                    (map (EpaSpan . realSrcSpan) $ fst $3)) }
 
 -- Always starts with commas; always follows an expr
 commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }
@@ -3571,6 +3574,8 @@ ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit
         | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
                                                         (snd $2 + 1)))
                                        (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+        | '(#' bars '#)'        {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
+                                       (NameAnnBars NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
         | '(' '->' ')'          {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
                                        (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
         | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)
@@ -3862,13 +3867,13 @@ commas :: { ([SrcSpan],Int) }   -- One or more commas
         : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }
         | ','                    { ([gl $1],1) }
 
-bars0 :: { ([EpaLocation],Int) }     -- Zero or more bars
+bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars
         : bars                   { $1 }
         |                        { ([], 0) }
 
-bars :: { ([EpaLocation],Int) }     -- One or more bars
-        : bars '|'               { ((fst $1)++[glAA $2],snd $1 + 1) }
-        | '|'                    { ([glAA $1],1) }
+bars :: { ([SrcSpan],Int) }     -- One or more bars
+        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }
+        | '|'                    { ([gl $1],1) }
 
 {
 happyError :: P a
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 964278920a..0265cc4ce2 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -736,6 +736,14 @@ data NameAnn
       nann_close     :: EpaLocation,
       nann_trailing  :: [TrailingAnn]
       }
+  -- | Used for @(# | | #)@
+  | NameAnnBars {
+      nann_adornment :: NameAdornment,
+      nann_open      :: EpaLocation,
+      nann_bars      :: [EpaLocation],
+      nann_close     :: EpaLocation,
+      nann_trailing  :: [TrailingAnn]
+      }
   -- | Used for @()@, @(##)@, @[]@
   | NameAnnOnly {
       nann_adornment :: NameAdornment,
@@ -1274,6 +1282,8 @@ instance Outputable NameAnn where
     = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t
   ppr (NameAnnCommas a o n c t)
     = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t
+  ppr (NameAnnBars a o n b t)
+    = text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
   ppr (NameAnnOnly a o c t)
     = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
   ppr (NameAnnRArrow n t)
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index d74d17be8f..588d6692a9 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -444,11 +444,9 @@ $tab          { warnTab }
 }
 
 <0> {
-  "(#" / { ifExtension UnboxedTuplesBit `alexOrPred`
-           ifExtension UnboxedSumsBit }
+  "(#" / { ifExtension UnboxedParensBit }
          { token IToubxparen }
-  "#)" / { ifExtension UnboxedTuplesBit `alexOrPred`
-           ifExtension UnboxedSumsBit }
+  "#)" / { ifExtension UnboxedParensBit }
          { token ITcubxparen }
 }
 
@@ -2732,8 +2730,7 @@ data ExtBits
   | RecursiveDoBit -- mdo
   | QualifiedDoBit -- .do and .mdo
   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
-  | UnboxedTuplesBit -- (# and #)
-  | UnboxedSumsBit -- (# and #)
+  | UnboxedParensBit -- (# and #)
   | DatatypeContextsBit
   | MonadComprehensionsBit
   | TransformComprehensionsBit
@@ -2814,8 +2811,7 @@ mkParserOpts extensionFlags diag_opts supported
       .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo
       .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo
       .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax
-      .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples
-      .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums
+      .|. UnboxedParensBit            `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums]
       .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts
       .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
       .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions
@@ -2851,6 +2847,8 @@ mkParserOpts extensionFlags diag_opts supported
     xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
     xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)
 
+    orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts
+
     setBitIf :: ExtBits -> Bool -> ExtsBitmap
     b `setBitIf` cond | cond      = xbit b
                       | otherwise = 0
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 }
 
 ----------------------------------------
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index c650aed944..0e160ad269 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -51,6 +51,7 @@ module GHC.Types.Basic (
         TupleSort(..), tupleSortBoxity, boxityTupleSort,
         tupleParens,
 
+        UnboxedTupleOrSum(..), unboxedTupleOrSumExtension,
         sumParens, pprAlternative,
 
         -- ** The OneShotInfo type
@@ -115,6 +116,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Binary
 import GHC.Types.SourceText
+import qualified GHC.LanguageExtensions as LangExt
 import Data.Data
 import qualified Data.Semigroup as Semi
 
@@ -878,6 +880,22 @@ pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
 pprAlternative pp x alt arity =
     fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
 
+-- | Are we dealing with an unboxed tuple or an unboxed sum?
+--
+-- Used when validity checking, see 'check_ubx_tuple_or_sum'.
+data UnboxedTupleOrSum
+  = UnboxedTupleType
+  | UnboxedSumType
+  deriving Eq
+
+instance Outputable UnboxedTupleOrSum where
+  ppr UnboxedTupleType = text "UnboxedTupleType"
+  ppr UnboxedSumType   = text "UnboxedSumType"
+
+unboxedTupleOrSumExtension :: UnboxedTupleOrSum -> LangExt.Extension
+unboxedTupleOrSumExtension UnboxedTupleType = LangExt.UnboxedTuples
+unboxedTupleOrSumExtension UnboxedSumType   = LangExt.UnboxedSums
+
 {-
 ************************************************************************
 *                                                                      *