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.

25 files changed, 311 insertions, 54 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
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index e51e327866..e6ce12f8ae 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1635,7 +1635,6 @@ data HsBracket p
   | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]
   | VarBr  (XVarBr p)   Bool (LIdP p)
                                 -- True: 'x, False: ''T
-                                -- (The Bool flag is used only in pprHsBracket)
   | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]
   | XBracket !(XXBracket p)           -- Extension point; see Note [Trees That Grow]
                                       -- in Language.Haskell.Syntax.Extension
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 5dac95565a..bb70761f1d 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -25,6 +25,19 @@ Compiler
   parameters with such kinds are unlikely to be very useful, due to
   :ghc-ticket:`18759`.
 
+- Changes to the treatment of :extension:`UnboxedSums`:
+
+  - GHC can now parse unboxed sum type constructors ``(# | #)``, ``(# | | #)``,
+    ``(# | | | #)`, etc. Partial applications need to be written in prefix form,
+    e.g. ``(# | #) Int#``.
+
+  - Unboxed sums now require the :extension:`UnboxedSums` extension to be enabled.
+
+  - The :extension:`UnboxedTuples` extension now implies
+    :extension:`UnboxedSums`. This means that code using unboxed sums that
+    enabled the :extension:`UnboxedTuples` extension but didn't explicitly
+    enable :extension:`UnboxedSums` will continue to work without changes.
+
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/exts/primitives.rst b/docs/users_guide/exts/primitives.rst
index 578ca1c4f7..2b8e88aa23 100644
--- a/docs/users_guide/exts/primitives.rst
+++ b/docs/users_guide/exts/primitives.rst
@@ -147,6 +147,8 @@ Unboxed tuples
 .. extension:: UnboxedTuples
     :shortdesc: Enable the use of unboxed tuple syntax.
 
+    :implies: :extension:`UnboxedSums`
+
     :since: 6.8.1
 
 
@@ -200,6 +202,10 @@ example desugars like this:
 
 Indeed, the bindings can even be recursive.
 
+To refer to the unboxed tuple type constructors themselves, e.g. if you
+want to attach instances to them, use ``(# #)``, ``(#,#)``, ``(#,,#)``, etc.
+This mirrors the syntax for boxed tuples ``()``, ``(,)``, ``(,,)``, etc.
+
 .. _unboxed-sums:
 
 Unboxed sums
@@ -211,6 +217,7 @@ Unboxed sums
     :since: 8.2.1
 
     Enable the use of unboxed sum syntax.
+    Implied by :extension:`UnboxedTuples`.
 
 `-XUnboxedSums` enables new syntax for anonymous, unboxed sum types. The syntax
 for an unboxed sum type with N alternatives is ::
@@ -237,6 +244,14 @@ The pattern syntax reflects the term syntax: ::
       (# (# i, str #) | #) -> ...
       (# | bool #) -> ...
 
+Note that spaces are always required around bars. For example, ``(# | 1# | | #)``
+is valid, but ``(# | 1# || #)`` and ``(#| 1# | | #)`` are both invalid.
+
+The type constructors themselves can be written in prefix form as ``(# | #)``,
+``(# | | #)``, ``(# | | | #)``, etc. Partial applications must also use prefix form,
+i.e. ``(# | #) Int#``. Saturated applications can be written either way,
+so that ``(# | #) Int# Float#`` is equivalent to ``(# Int# | Float# #)``.
+
 Unboxed sums are "unboxed" in the sense that, instead of allocating sums in the
 heap and representing values as pointers, unboxed sums are represented as their
 components, just like unboxed tuples. These "components" depend on alternatives
diff --git a/testsuite/tests/typecheck/should_fail/T15067.stderr b/testsuite/tests/typecheck/should_fail/T15067.stderr
index a2ecc4326c..a1000205c1 100644
--- a/testsuite/tests/typecheck/should_fail/T15067.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15067.stderr
@@ -1,13 +1,11 @@
 
 T15067.hs:9:14: error:
-    • No instance for (Typeable (# GHC.Types.LiftedRep #))
+    • No instance for (Typeable (# | #))
         arising from a use of ‘typeRep’
         GHC can't yet do polykinded
-          Typeable ((# GHC.Types.LiftedRep #) :: *
-                                                 -> *
-                                                 -> TYPE
-                                                      ('GHC.Types.SumRep
-                                                         '[GHC.Types.LiftedRep,
-                                                           GHC.Types.LiftedRep]))
+          Typeable ((# | #) :: *
+                               -> *
+                               -> TYPE
+                                    ('GHC.Types.SumRep '[GHC.Types.LiftedRep, GHC.Types.LiftedRep]))
     • In the expression: typeRep
       In an equation for ‘floopadoop’: floopadoop = typeRep
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, [''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 8e9d84067f..967ae61035 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -3100,6 +3100,12 @@ instance ExactPrint (LocatedN RdrName) where
         forM_ cs (\loc -> markKw (AddEpAnn AnnComma loc))
         markKw (AddEpAnn kwc c)
         markTrailing t
+      NameAnnBars a o bs c t -> do
+        let (kwo,kwc) = adornments a
+        markKw (AddEpAnn kwo o)
+        forM_ bs (\loc -> markKw (AddEpAnn AnnVbar loc))
+        markKw (AddEpAnn kwc c)
+        markTrailing t
       NameAnnOnly a o c t -> do
         markName a o Nothing c
         markTrailing t