Fix error when using empty case in arrow notationwip/T21301

It was previously not possible to use -XEmptyCase in Arrow notation,
since GHC would print "Exception: foldb of empty list".

This is now fixed.

Closes #21301

2 files changed, 44 insertions, 18 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index e17f2dda44..58c9d9eb25 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -455,6 +455,9 @@ basicKnownKeyNames
         -- The Either type
         , eitherTyConName, leftDataConName, rightDataConName
 
+        -- The Void type
+        , voidTyConName
+
         -- Plugins
         , pluginTyConName
         , frontendPluginTyConName
@@ -533,7 +536,7 @@ gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,
     gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,
-    gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING,
+    gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,
     dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
@@ -569,6 +572,7 @@ gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat")
 gHC_LIST        = mkBaseModule (fsLit "GHC.List")
 gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")
 dATA_EITHER     = mkBaseModule (fsLit "Data.Either")
+dATA_VOID       = mkBaseModule (fsLit "Data.Void")
 dATA_LIST       = mkBaseModule (fsLit "Data.List")
 dATA_STRING     = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")
@@ -947,6 +951,9 @@ eitherTyConName   = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey
 leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey
 rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey
 
+voidTyConName :: Name
+voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey
+
 -- Generics (types)
 v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
   k1TyConName, m1TyConName, sumTyConName, prodTyConName,
@@ -1869,8 +1876,11 @@ isReflPrimTyConKey                      = mkPreludeTyConUnique 82
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84
 
+voidTyConKey :: Unique
+voidTyConKey                            = mkPreludeTyConUnique 85
+
 nonEmptyTyConKey :: Unique
-nonEmptyTyConKey                        = mkPreludeTyConUnique 85
+nonEmptyTyConKey                        = mkPreludeTyConUnique 86
 
 -- Kind constructors
 liftedTypeKindTyConKey, unliftedTypeKindTyConKey,
@@ -1878,9 +1888,9 @@ liftedTypeKindTyConKey, unliftedTypeKindTyConKey,
   constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,
   vecCountTyConKey, vecElemTyConKey,
   zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique
-liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
-unliftedTypeKindTyConKey                = mkPreludeTyConUnique 88
-tYPETyConKey                            = mkPreludeTyConUnique 89
+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88
+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89
+tYPETyConKey                            = mkPreludeTyConUnique 90
 constraintKindTyConKey                  = mkPreludeTyConUnique 92
 levityTyConKey                          = mkPreludeTyConUnique 94
 runtimeRepTyConKey                      = mkPreludeTyConUnique 95
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 3d93e0b7a5..b9a2648dbf 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -1,5 +1,5 @@
-
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -50,7 +50,9 @@ import GHC.Utils.Panic
 import GHC.Types.Var.Set
 import GHC.Types.SrcLoc
 import GHC.Data.List.SetOps( assocMaybe )
+import Data.Foldable (toList)
 import Data.List (mapAccumL)
+import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
 import GHC.Utils.Misc
 import GHC.Types.Unique.DSet
 
@@ -466,6 +468,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
         fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
 
 {-
+Note [Desugaring HsCmdCase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Case commands are treated in much the same way as if commands
 (see above) except that there are more alternatives.  For example
 
@@ -516,6 +520,7 @@ dsCmd ids local_vars stack_ty res_ty
     either_con <- dsLookupTyCon eitherTyConName
     left_con <- dsLookupDataCon leftDataConName
     right_con <- dsLookupDataCon rightDataConName
+    void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName
     let
         left_id  = mkConLikeTc (RealDataCon left_con)
         right_id = mkConLikeTc (RealDataCon right_con)
@@ -536,12 +541,22 @@ dsCmd ids local_vars stack_ty res_ty
                 map (right_expr in_ty1 in_ty2) builds2,
              mkTyConApp either_con [in_ty1, in_ty2],
              do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
-        (leaves', sum_ty, core_choices) = foldb merge_branches branches
-
-        -- Replace the commands in the case with these tagged tuples,
-        -- yielding a HsExpr Id we can feed to dsExpr.
-
-        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+    (leaves', sum_ty, core_choices) <- case nonEmpty branches of
+      Just bs -> return $ foldb merge_branches bs
+      -- when the case command has no alternatives, the sum type from
+      -- Note [Desugaring HsCmdCase] becomes the empty sum type,
+      -- i.e. Void. The choices then effectively become `arr absurd`,
+      -- implemented as `arr \case {}`.
+      Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
+        dsExpr (HsLamCase EpAnnNotUsed
+          (MG { mg_alts = noLocA []
+              , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty
+              , mg_origin = Generated }))
+
+
+    -- Replace the commands in the case with these tagged tuples,
+    -- yielding a HsExpr Id we can feed to dsExpr.
+    let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
         in_ty = envStackType env_ids stack_ty
 
     core_body <- dsExpr (HsCase noExtField exp
@@ -1151,11 +1166,12 @@ replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
 
 -- Balanced fold of a non-empty list.
 
-foldb :: (a -> a -> a) -> [a] -> a
-foldb _ [] = error "foldb of empty list"
-foldb _ [x] = x
+foldb :: (a -> a -> a) -> NonEmpty a -> a
+foldb _ (x:|[]) = x
 foldb f xs = foldb f (fold_pairs xs)
   where
-    fold_pairs [] = []
-    fold_pairs [x] = [x]
-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+    fold_pairs (x1:|x2:xs) = f x1 x2 :| keep_empty fold_pairs xs
+    fold_pairs xs          = xs
+
+    keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a]
+    keep_empty f = maybe [] (toList . f) . nonEmpty