Template Haskell support for unboxed sums

This adds new constructors `UnboxedSumE`, `UnboxedSumT`, and
`UnboxedSumP` to represent unboxed sums in Template Haskell.

One thing you can't currently do is, e.g., `reify ''(#||#)`, since I
don't believe unboxed sum type/data constructors can be written in
prefix form.  I will look at fixing that as part of #12514.

Fixes #12478.

Test Plan: make test TEST=T12478_{1,2,3}

Reviewers: osa1, goldfire, austin, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2448

GHC Trac Issues: #12478

18 files changed, 277 insertions, 93 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 427a56f479..4dd0789e23 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -977,6 +977,9 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do
 repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
                                  tcon <- repTupleTyCon (length tys)
                                  repTapps tcon tys1
+repTy (HsSumTy tys)         = do tys1 <- repLTys tys
+                                 tcon <- repUnboxedSumTyCon (length tys)
+                                 repTapps tcon tys1
 repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                    `nlHsAppTy` ty2)
 repTy (HsParTy t)           = repLTy t
@@ -1176,6 +1179,10 @@ repE e@(ExplicitTuple es boxed)
   | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
                         ; repUnboxedTup xs }
 
+repE (ExplicitSum alt arity e _)
+ = do { e1 <- repLE e
+      ; repUnboxedSum e1 alt arity }
+
 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
@@ -1584,6 +1591,7 @@ repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e'
 repP (TuplePat ps boxed _)
   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
+repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
@@ -1793,6 +1801,14 @@ repPtup (MkC ps) = rep2 tupPName [ps]
 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
 
+repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repPunboxedSum (MkC p) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumPName [ p
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
 
@@ -1849,6 +1865,14 @@ repTup (MkC es) = rep2 tupEName [es]
 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 
+repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repUnboxedSum (MkC e) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumEName [ e
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
 
@@ -2185,6 +2209,11 @@ repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
 repUnboxedTupleTyCon i = do dflags <- getDynFlags
                             rep2 unboxedTupleTName [mkIntExprInt dflags i]
 
+repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
+-- Note: not Core TH.SumArity; it's easier to be direct here
+repUnboxedSumTyCon arity = do dflags <- getDynFlags
+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]
+
 repArrowTyCon :: DsM (Core TH.TypeQ)
 repArrowTyCon = rep2 arrowTName []
 
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index ee1f1066bc..c29db585a7 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -771,6 +771,10 @@ cvtl e = wrapL (cvt e)
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
                                    ; return $ ExplicitTuple
                                            (map (noLoc . Present) es') Unboxed }
+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
+                                       ; unboxedSumChecks alt arity
+                                       ; return $ ExplicitSum
+                                             alt arity e' placeHolderType }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
                             ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
     cvt (MultiIfE alts)
@@ -1045,6 +1049,10 @@ cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
 cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
 cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }
 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
+cvtp (UnboxedSumP p alt arity)
+                       = do { p' <- cvtPat p
+                            ; unboxedSumChecks alt arity
+                            ; return $ SumPat p' alt arity placeHolderType }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
                             ; return $ ConPatIn s' (PrefixCon ps') }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
@@ -1138,6 +1146,16 @@ cvtTypeKind ty_str ty
              | otherwise
              -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
                         tys'
+           UnboxedSumT n
+             | n < 2
+            -> failWith $
+                   vcat [ text "Illegal sum arity:" <+> text (show n)
+                        , nest 2 $
+                            text "Sums must have an arity of at least 2" ]
+             | length tys' == n -- Saturated
+             -> returnL (HsSumTy tys')
+             | otherwise
+             -> mk_apps (HsTyVar (noLoc (getRdrName (sumTyCon n)))) tys'
            ArrowT
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
              | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
@@ -1348,6 +1366,22 @@ overloadedLit _             = False
 cvtFractionalLit :: Rational -> FractionalLit
 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
 
+-- Checks that are performed when converting unboxed sum expressions and
+-- patterns alike.
+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
+unboxedSumChecks alt arity
+    | alt > arity
+    = failWith $ text "Sum alternative"    <+> text (show alt)
+             <+> text "exceeds its arity," <+> text (show arity)
+    | alt <= 0
+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
+                      , nest 2 $ text "Sum alternatives must start from 1" ]
+    | arity < 2
+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
+                      , nest 2 $ text "Sums must have an arity of at least 2" ]
+    | otherwise
+    = return ()
+
 --------------------------------------------------------------------
 --      Turning Name back into RdrName
 --------------------------------------------------------------------
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index e3a58cccdd..9ae54332d5 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -38,7 +38,7 @@ templateHaskellNames = [
     floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
     charPrimLName,
     -- Pat
-    litPName, varPName, tupPName, unboxedTupPName,
+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
     conPName, tildePName, bangPName, infixPName,
     asPName, wildPName, recPName, listPName, sigPName, viewPName,
     -- FieldPat
@@ -50,7 +50,7 @@ templateHaskellNames = [
     -- Exp
     varEName, conEName, litEName, appEName, infixEName,
     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
-    tupEName, unboxedTupEName,
+    tupEName, unboxedTupEName, unboxedSumEName,
     condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
@@ -93,7 +93,8 @@ templateHaskellNames = [
     prefixPatSynName, infixPatSynName, recordPatSynName,
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
-    tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
+    tupleTName, unboxedTupleTName, unboxedSumTName,
+    arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
     wildCardTName,
     -- TyLit
@@ -236,12 +237,14 @@ stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
 charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey
 
 -- data Pat = ...
-litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
-    asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
+    sigPName, viewPName :: Name
 litPName   = libFun (fsLit "litP")   litPIdKey
 varPName   = libFun (fsLit "varP")   varPIdKey
 tupPName   = libFun (fsLit "tupP")   tupPIdKey
 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
 conPName   = libFun (fsLit "conP")   conPIdKey
 infixPName = libFun (fsLit "infixP") infixPIdKey
 tildePName = libFun (fsLit "tildeP") tildePIdKey
@@ -268,8 +271,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 -- data Exp = ...
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
-    unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
-    doEName, compEName, staticEName, unboundVarEName :: Name
+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
+    caseEName, doEName, compEName, staticEName, unboundVarEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -282,6 +285,7 @@ lamEName        = libFun (fsLit "lamE")        lamEIdKey
 lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
 tupEName        = libFun (fsLit "tupE")        tupEIdKey
 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
+unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
 condEName       = libFun (fsLit "condE")       condEIdKey
 multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey
 letEName        = libFun (fsLit "letE")        letEIdKey
@@ -414,16 +418,16 @@ infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
 recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
 
 -- data Type = ...
-forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
-    listTName, appTName, sigTName, equalityTName, litTName,
-    promotedTName, promotedTupleTName,
-    promotedNilTName, promotedConsTName,
-    wildCardTName :: Name
+forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
+    unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName,
+    litTName, promotedTName, promotedTupleTName, promotedNilTName,
+    promotedConsTName, wildCardTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
 varTName            = libFun (fsLit "varT")           varTIdKey
 conTName            = libFun (fsLit "conT")           conTIdKey
 tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey
 unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey
+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey
 arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
 listTName           = libFun (fsLit "listT")          listTIdKey
 appTName            = libFun (fsLit "appT")           appTIdKey
@@ -727,23 +731,24 @@ liftStringIdKey :: Unique
 liftStringIdKey     = mkPreludeMiscIdUnique 230
 
 -- data Pat = ...
-litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey,
-  tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey,
-  sigPIdKey, viewPIdKey :: Unique
+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
+  listPIdKey, sigPIdKey, viewPIdKey :: Unique
 litPIdKey         = mkPreludeMiscIdUnique 240
 varPIdKey         = mkPreludeMiscIdUnique 241
 tupPIdKey         = mkPreludeMiscIdUnique 242
 unboxedTupPIdKey  = mkPreludeMiscIdUnique 243
-conPIdKey         = mkPreludeMiscIdUnique 244
-infixPIdKey       = mkPreludeMiscIdUnique 245
-tildePIdKey       = mkPreludeMiscIdUnique 246
-bangPIdKey        = mkPreludeMiscIdUnique 247
-asPIdKey          = mkPreludeMiscIdUnique 248
-wildPIdKey        = mkPreludeMiscIdUnique 249
-recPIdKey         = mkPreludeMiscIdUnique 250
-listPIdKey        = mkPreludeMiscIdUnique 251
-sigPIdKey         = mkPreludeMiscIdUnique 252
-viewPIdKey        = mkPreludeMiscIdUnique 253
+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244
+conPIdKey         = mkPreludeMiscIdUnique 245
+infixPIdKey       = mkPreludeMiscIdUnique 246
+tildePIdKey       = mkPreludeMiscIdUnique 247
+bangPIdKey        = mkPreludeMiscIdUnique 248
+asPIdKey          = mkPreludeMiscIdUnique 249
+wildPIdKey        = mkPreludeMiscIdUnique 250
+recPIdKey         = mkPreludeMiscIdUnique 251
+listPIdKey        = mkPreludeMiscIdUnique 252
+sigPIdKey         = mkPreludeMiscIdUnique 253
+viewPIdKey        = mkPreludeMiscIdUnique 254
 
 -- type FieldPat = ...
 fieldPatIdKey :: Unique
@@ -761,7 +766,7 @@ clauseIdKey         = mkPreludeMiscIdUnique 262
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
-    unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
+    unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
@@ -778,22 +783,23 @@ lamEIdKey         = mkPreludeMiscIdUnique 278
 lamCaseEIdKey     = mkPreludeMiscIdUnique 279
 tupEIdKey         = mkPreludeMiscIdUnique 280
 unboxedTupEIdKey  = mkPreludeMiscIdUnique 281
-condEIdKey        = mkPreludeMiscIdUnique 282
-multiIfEIdKey     = mkPreludeMiscIdUnique 283
-letEIdKey         = mkPreludeMiscIdUnique 284
-caseEIdKey        = mkPreludeMiscIdUnique 285
-doEIdKey          = mkPreludeMiscIdUnique 286
-compEIdKey        = mkPreludeMiscIdUnique 287
-fromEIdKey        = mkPreludeMiscIdUnique 288
-fromThenEIdKey    = mkPreludeMiscIdUnique 289
-fromToEIdKey      = mkPreludeMiscIdUnique 290
-fromThenToEIdKey  = mkPreludeMiscIdUnique 291
-listEIdKey        = mkPreludeMiscIdUnique 292
-sigEIdKey         = mkPreludeMiscIdUnique 293
-recConEIdKey      = mkPreludeMiscIdUnique 294
-recUpdEIdKey      = mkPreludeMiscIdUnique 295
-staticEIdKey      = mkPreludeMiscIdUnique 296
-unboundVarEIdKey  = mkPreludeMiscIdUnique 297
+unboxedSumEIdKey  = mkPreludeMiscIdUnique 282
+condEIdKey        = mkPreludeMiscIdUnique 283
+multiIfEIdKey     = mkPreludeMiscIdUnique 284
+letEIdKey         = mkPreludeMiscIdUnique 285
+caseEIdKey        = mkPreludeMiscIdUnique 286
+doEIdKey          = mkPreludeMiscIdUnique 287
+compEIdKey        = mkPreludeMiscIdUnique 288
+fromEIdKey        = mkPreludeMiscIdUnique 289
+fromThenEIdKey    = mkPreludeMiscIdUnique 290
+fromToEIdKey      = mkPreludeMiscIdUnique 291
+fromThenToEIdKey  = mkPreludeMiscIdUnique 292
+listEIdKey        = mkPreludeMiscIdUnique 293
+sigEIdKey         = mkPreludeMiscIdUnique 294
+recConEIdKey      = mkPreludeMiscIdUnique 295
+recUpdEIdKey      = mkPreludeMiscIdUnique 296
+staticEIdKey      = mkPreludeMiscIdUnique 297
+unboundVarEIdKey  = mkPreludeMiscIdUnique 298
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
@@ -907,27 +913,27 @@ infixPatSynIdKey  = mkPreludeMiscIdUnique 370
 recordPatSynIdKey = mkPreludeMiscIdUnique 371
 
 -- data Type = ...
-forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
-    listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey,
-    promotedTIdKey, promotedTupleTIdKey,
-    promotedNilTIdKey, promotedConsTIdKey,
-    wildCardTIdKey :: Unique
+forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
+    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
+    equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,
+    promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique
 forallTIdKey        = mkPreludeMiscIdUnique 380
 varTIdKey           = mkPreludeMiscIdUnique 381
 conTIdKey           = mkPreludeMiscIdUnique 382
 tupleTIdKey         = mkPreludeMiscIdUnique 383
 unboxedTupleTIdKey  = mkPreludeMiscIdUnique 384
-arrowTIdKey         = mkPreludeMiscIdUnique 385
-listTIdKey          = mkPreludeMiscIdUnique 386
-appTIdKey           = mkPreludeMiscIdUnique 387
-sigTIdKey           = mkPreludeMiscIdUnique 388
-equalityTIdKey      = mkPreludeMiscIdUnique 389
-litTIdKey           = mkPreludeMiscIdUnique 390
-promotedTIdKey      = mkPreludeMiscIdUnique 391
-promotedTupleTIdKey = mkPreludeMiscIdUnique 392
-promotedNilTIdKey   = mkPreludeMiscIdUnique 393
-promotedConsTIdKey  = mkPreludeMiscIdUnique 394
-wildCardTIdKey      = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 385
+arrowTIdKey         = mkPreludeMiscIdUnique 386
+listTIdKey          = mkPreludeMiscIdUnique 387
+appTIdKey           = mkPreludeMiscIdUnique 388
+sigTIdKey           = mkPreludeMiscIdUnique 389
+equalityTIdKey      = mkPreludeMiscIdUnique 390
+litTIdKey           = mkPreludeMiscIdUnique 391
+promotedTIdKey      = mkPreludeMiscIdUnique 392
+promotedTupleTIdKey = mkPreludeMiscIdUnique 393
+promotedNilTIdKey   = mkPreludeMiscIdUnique 394
+promotedConsTIdKey  = mkPreludeMiscIdUnique 395
+wildCardTIdKey      = mkPreludeMiscIdUnique 396
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 6e09b99c12..d879e56be1 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1819,7 +1819,8 @@ reify_tc_app tc tys
     tc_binders  = tyConBinders tc
     tc_res_kind = tyConResKind tc
 
-    r_tc | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)
+    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)
+         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)
              -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
          | isTupleTyCon tc                = if isPromotedDataCon tc
                                             then TH.PromotedTupleT arity
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index a9b30502d0..f0b931e356 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -213,6 +213,8 @@ template-haskell
 
 -  Version number XXXXX (was 2.9.0.0)
 
+-  Added support for unboxed sums :ghc-ticket:`12478`.
+
 time
 ~~~~
 
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 5bd610cd76..984bbc6b4f 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -24,6 +24,7 @@ module Language.Haskell.TH(
         Info(..), ModuleInfo(..),
         InstanceDec,
         ParentName,
+        SumAlt, SumArity,
         Arity,
         Unlifted,
         -- *** Language extension lookup
@@ -95,7 +96,7 @@ module Language.Haskell.TH(
         intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
         charL, stringL, stringPrimL, charPrimL,
     -- *** Patterns
-        litP, varP, tupP, conP, uInfixP, parensP, infixP,
+        litP, varP, tupP, unboxedSumP, conP, uInfixP, parensP, infixP,
         tildeP, bangP, asP, wildP, recP,
         listP, sigP, viewP,
         fieldPat,
@@ -106,8 +107,8 @@ module Language.Haskell.TH(
     -- *** Expressions
         dyn, varE, conE, litE, appE, uInfixE, parensE, staticE,
         infixE, infixApp, sectionL, sectionR,
-        lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE,
-        listE, sigE, recConE, recUpdE, stringE, fieldExp,
+        lamE, lam1E, lamCaseE, tupE, unboxedSumE, condE, multiIfE, letE, caseE,
+        appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
     -- **** Ranges
     fromE, fromThenE, fromToE, fromThenToE,
 
@@ -120,8 +121,8 @@ module Language.Haskell.TH(
 
     -- *** Types
         forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
-        listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT,
-        promotedConsT,
+        listT, tupleT, unboxedSumT, sigT, litT, promotedT, promotedTupleT,
+        promotedNilT, promotedConsT,
     -- **** Type literals
     numTyLit, strTyLit,
     -- **** Strictness
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index d4529e1915..503f6ea84f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -80,12 +80,19 @@ rationalL   = RationalL
 
 litP :: Lit -> PatQ
 litP l = return (LitP l)
+
 varP :: Name -> PatQ
 varP v = return (VarP v)
+
 tupP :: [PatQ] -> PatQ
 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+
 unboxedTupP :: [PatQ] -> PatQ
 unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
+
+unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
+unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
+
 conP :: Name -> [PatQ] -> PatQ
 conP n ps = do ps' <- sequence ps
                return (ConP n ps')
@@ -266,6 +273,9 @@ tupE es = do { es1 <- sequence es; return (TupE es1)}
 unboxedTupE :: [ExpQ] -> ExpQ
 unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
 
+unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
+unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
+
 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
 condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
 
@@ -627,6 +637,9 @@ tupleT i = return (TupleT i)
 unboxedTupleT :: Int -> TypeQ
 unboxedTupleT i = return (UnboxedTupleT i)
 
+unboxedSumT :: SumArity -> TypeQ
+unboxedSumT arity = return (UnboxedSumT arity)
+
 sigT :: TypeQ -> Kind -> TypeQ
 sigT t k
   = do
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index ca74db7e45..49d0e7b0d8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -149,6 +149,7 @@ pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                        $ text "\\case" $$ nest nestDepth (ppr ms)
 pprExp _ (TupE es) = parens (commaSep es)
 pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
+pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
 -- Nesting in Cond is to avoid potential problems in do statments
 pprExp i (CondE guard true false)
  = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
@@ -179,7 +180,7 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
 pprExp _ (CompE ss) = text "[" <> ppr s
-                  <+> text "|"
+                  <+> bar
                   <+> commaSep ss'
                    <> text "]"
     where s = last ss
@@ -205,7 +206,7 @@ instance Ppr Stmt where
     ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
     ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
     ppr (NoBindS e) = ppr e
-    ppr (ParS sss) = sep $ punctuate (text "|")
+    ppr (ParS sss) = sep $ punctuate bar
                          $ map commaSep sss
 
 ------------------------------
@@ -216,8 +217,8 @@ instance Ppr Match where
 ------------------------------
 pprGuarded :: Doc -> (Guard, Exp) -> Doc
 pprGuarded eqDoc (guard, expr) = case guard of
-  NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
-  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
+  NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr
+  PatG    stmts     -> bar <+> vcat (punctuate comma $ map ppr stmts) $$
                          nest nestDepth (eqDoc <+> ppr expr)
 
 ------------------------------
@@ -266,6 +267,7 @@ pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
 pprPat _ (TupP ps)    = parens (commaSep ps)
 pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
+pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
 pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                               <+> sep (map (pprPat appPrec) ps)
 pprPat _ (ParensP p)  = parens $ pprPat noPrec p
@@ -389,7 +391,7 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
     pref :: [Doc] -> [Doc]
     pref xs | isGadtDecl = xs
     pref []              = []      -- No constructors; can't happen in H98
-    pref (d:ds)          = (char '=' <+> d):map (char '|' <+>) ds
+    pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds
 
     maybeWhere :: Doc
     maybeWhere | isGadtDecl = text "where"
@@ -436,7 +438,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
 instance Ppr FunDep where
     ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
     ppr_list [] = empty
-    ppr_list xs = char '|' <+> commaSep xs
+    ppr_list xs = bar <+> commaSep xs
 
 ------------------------------
 instance Ppr FamFlavour where
@@ -452,7 +454,7 @@ instance Ppr FamilyResultSig where
 ------------------------------
 instance Ppr InjectivityAnn where
     ppr (InjectivityAnn lhs rhs) =
-        char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
+        bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
 
 ------------------------------
 instance Ppr Foreign where
@@ -655,6 +657,7 @@ pprParendType (ConT c)            = ppr c
 pprParendType (TupleT 0)          = text "()"
 pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
 pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
+pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
 pprParendType ArrowT              = parens (text "->")
 pprParendType ListT               = text "[]"
 pprParendType (LitT l)            = pprTyLit l
@@ -795,3 +798,15 @@ commaSepWith pprFun = sep . punctuate comma . map pprFun
 -- followed by space.
 semiSep :: Ppr a => [a] -> Doc
 semiSep = sep . punctuate semi . map ppr
+
+-- Prints out the series of vertical bars that wraps an expression or pattern
+-- used in an unboxed sum.
+unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
+unboxedSumBars d alt arity = hashParens $
+    bars (alt-1) <> d <> bars (arity - alt)
+  where
+    bars i = hsep (replicate i bar)
+
+-- Text containing the vertical bar character.
+bar :: Doc
+bar = char '|'
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 62bdd10aac..8539e79bd2 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1176,8 +1176,6 @@ mk_unboxed_tup_name n_commas space
     occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)")
     tup_mod = mkModName "GHC.Tuple"
 
-
-
 -----------------------------------------------------
 --              Locations
 -----------------------------------------------------
@@ -1278,6 +1276,19 @@ In 'ClassOpI' and 'DataConI', name of the parent class or type
 -}
 type ParentName = Name
 
+-- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a
+-- particular data constructor. 'SumAlt's are one-indexed and should never
+-- exceed the value of its corresponding 'SumArity'. For example:
+--
+-- * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2)
+--
+-- * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2)
+type SumAlt = Int
+
+-- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of
+-- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2.
+type SumArity = Int
+
 -- | In 'PrimTyConI', arity of the type constructor
 type Arity = Int
 
@@ -1398,26 +1409,27 @@ data Lit = CharL Char
 
 -- | Pattern in Haskell given in @{}@
 data Pat
-  = LitP Lit                      -- ^ @{ 5 or \'c\' }@
-  | VarP Name                     -- ^ @{ x }@
-  | TupP [Pat]                    -- ^ @{ (p1,p2) }@
-  | UnboxedTupP [Pat]             -- ^ @{ (\# p1,p2 \#) }@
-  | ConP Name [Pat]               -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
-  | InfixP Pat Name Pat           -- ^ @foo ({x :+ y}) = e@
-  | UInfixP Pat Name Pat          -- ^ @foo ({x :+ y}) = e@
-                                  --
-                                  -- See "Language.Haskell.TH.Syntax#infix"
-  | ParensP Pat                   -- ^ @{(p)}@
-                                  --
-                                  -- See "Language.Haskell.TH.Syntax#infix"
-  | TildeP Pat                    -- ^ @{ ~p }@
-  | BangP Pat                     -- ^ @{ !p }@
-  | AsP Name Pat                  -- ^ @{ x \@ p }@
-  | WildP                         -- ^ @{ _ }@
-  | RecP Name [FieldPat]          -- ^ @f (Pt { pointx = x }) = g x@
-  | ListP [ Pat ]                 -- ^ @{ [1,2,3] }@
-  | SigP Pat Type                 -- ^ @{ p :: t }@
-  | ViewP Exp Pat                 -- ^ @{ e -> p }@
+  = LitP Lit                        -- ^ @{ 5 or \'c\' }@
+  | VarP Name                       -- ^ @{ x }@
+  | TupP [Pat]                      -- ^ @{ (p1,p2) }@
+  | UnboxedTupP [Pat]               -- ^ @{ (\# p1,p2 \#) }@
+  | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@
+  | ConP Name [Pat]                 -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
+  | InfixP Pat Name Pat             -- ^ @foo ({x :+ y}) = e@
+  | UInfixP Pat Name Pat            -- ^ @foo ({x :+ y}) = e@
+                                    --
+                                    -- See "Language.Haskell.TH.Syntax#infix"
+  | ParensP Pat                     -- ^ @{(p)}@
+                                    --
+                                    -- See "Language.Haskell.TH.Syntax#infix"
+  | TildeP Pat                      -- ^ @{ ~p }@
+  | BangP Pat                       -- ^ @{ !p }@
+  | AsP Name Pat                    -- ^ @{ x \@ p }@
+  | WildP                           -- ^ @{ _ }@
+  | RecP Name [FieldPat]            -- ^ @f (Pt { pointx = x }) = g x@
+  | ListP [ Pat ]                   -- ^ @{ [1,2,3] }@
+  | SigP Pat Type                   -- ^ @{ p :: t }@
+  | ViewP Exp Pat                   -- ^ @{ e -> p }@
   deriving( Show, Eq, Ord, Data, Generic )
 
 type FieldPat = (Name,Pat)
@@ -1452,6 +1464,7 @@ data Exp
   | LamCaseE [Match]                   -- ^ @{ \\case m1; m2 }@
   | TupE [Exp]                         -- ^ @{ (e1,e2) }  @
   | UnboxedTupE [Exp]                  -- ^ @{ (\# e1,e2 \#) }  @
+  | UnboxedSumE Exp SumAlt SumArity    -- ^ @{ (\#|e|\#) }@
   | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@
   | MultiIfE [(Guard, Exp)]            -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
   | LetE [Dec] Exp                     -- ^ @{ let x=e1;   y=e2 in e3 }@
@@ -1804,6 +1817,7 @@ data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> -> \<t
           -- See Note [Representing concrete syntax in types]
           | TupleT Int                    -- ^ @(,), (,,), etc.@
           | UnboxedTupleT Int             -- ^ @(\#,\#), (\#,,\#), etc.@
+          | UnboxedSumT SumArity          -- ^ @(\#|\#), (\#||\#), etc.@
           | ArrowT                        -- ^ @->@
           | EqualityT                     -- ^ @~@
           | ListT                         -- ^ @[]@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index e9084e27f9..d6f0d46c02 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -8,6 +8,8 @@
     `PatSynSigD`), and two new data types (`PatSynDir` and `PatSynArgs`),
     among other changes. (#8761)
 
+  * Add support for unboxed sums. (#12478)
+
 ## 2.11.0.0  *May 2016*
 
   * Bundled with GHC 8.0.1
diff --git a/testsuite/tests/th/T12478_1.hs b/testsuite/tests/th/T12478_1.hs
new file mode 100644
index 0000000000..3d2ab1062b
--- /dev/null
+++ b/testsuite/tests/th/T12478_1.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module Main where
+
+import Language.Haskell.TH
+
+data T = T (# Int | Char #)
+
+$(return [])
+
+main :: IO ()
+main = putStrLn $(reify ''T >>= stringE . show)
diff --git a/testsuite/tests/th/T12478_1.stdout b/testsuite/tests/th/T12478_1.stdout
new file mode 100644
index 0000000000..8437f925d5
--- /dev/null
+++ b/testsuite/tests/th/T12478_1.stdout
@@ -0,0 +1 @@
+TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] [])
diff --git a/testsuite/tests/th/T12478_2.hs b/testsuite/tests/th/T12478_2.hs
new file mode 100644
index 0000000000..bb0a73ba0f
--- /dev/null
+++ b/testsuite/tests/th/T12478_2.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+-- Essentially the same as TH_repUnboxedTuples, but for unboxed sums
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = case bar () of
+       (# a |   #) -> print a
+       (#   | b #) -> print b
+
+bar :: () -> (# String | Int #)
+bar () = $( do e <- [| case (# 'b' | #) of
+                        (# 'a' |   #) -> (# "One"   |   #)
+                        (# 'b' |   #) -> (#         | 2 #)
+                        (# _   |   #) -> (# "Three" |   #)
+                        (#     | _ #) -> (#         | 4 #)
+                     |]
+               return e )
diff --git a/testsuite/tests/th/T12478_2.stdout b/testsuite/tests/th/T12478_2.stdout
new file mode 100644
index 0000000000..0cfbf08886
--- /dev/null
+++ b/testsuite/tests/th/T12478_2.stdout
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/th/T12478_3.hs b/testsuite/tests/th/T12478_3.hs
new file mode 100644
index 0000000000..7c84eee50f
--- /dev/null
+++ b/testsuite/tests/th/T12478_3.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module T12478_3 where
+
+import Language.Haskell.TH
+
+$(do let ubxSum = unboxedSumT 2 `appT` conT ''Int `appT` conT ''Int
+     x <- newName "x"
+     y <- newName "y"
+
+     [d| swap :: $(ubxSum) -> $(ubxSum)
+         swap $(unboxedSumP (varP x) 1 2) = $(unboxedSumE (varE x) 2 2)
+         swap $(unboxedSumP (varP y) 2 2) = $(unboxedSumE (varE y) 1 2)
+      |])
diff --git a/testsuite/tests/th/T12478_4.hs b/testsuite/tests/th/T12478_4.hs
new file mode 100644
index 0000000000..9017f32bd1
--- /dev/null
+++ b/testsuite/tests/th/T12478_4.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module T12478_4 where
+
+import Language.Haskell.TH
+
+f :: $(unboxedSumT 1 `appT` conT ''()) -> Int
+f _ = 42
diff --git a/testsuite/tests/th/T12478_4.stderr b/testsuite/tests/th/T12478_4.stderr
new file mode 100644
index 0000000000..6a68b3d15a
--- /dev/null
+++ b/testsuite/tests/th/T12478_4.stderr
@@ -0,0 +1,6 @@
+
+T12478_4.hs:7:8: error:
+    • Illegal sum arity: 1
+        Sums must have an arity of at least 2
+      When splicing a TH type: (#  #) GHC.Tuple.()
+    • In the untyped splice: $(unboxedSumT 1 `appT` conT ''())
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b05d601670..592e133e7d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -421,4 +421,9 @@ test('T12130', extra_clean(['T12130a.hi','T12130a.o']),
 test('T12403', omit_ways(['ghci']),
               compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T12407', omit_ways(['ghci']), compile, ['-v0'])
+test('T12478_1', omit_ways(['ghci']), compile_and_run,
+     ['-v0 -dsuppress-uniques'])
+test('T12478_2', omit_ways(['ghci']), compile_and_run, ['-v0'])
+test('T12478_3', omit_ways(['ghci']), compile, ['-v0'])
+test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0'])
 test('T12513', omit_ways(['ghci']), compile_fail, ['-v0'])