Fix error when using empty case in arrow notation

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

5 files changed, 50 insertions, 13 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 fffa3347b0..253bd1b60d 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TupleSections #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -50,7 +51,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
 
@@ -772,6 +775,7 @@ dsCases ids local_vars stack_id 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)
@@ -792,12 +796,22 @@ dsCases ids local_vars stack_id 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
+  (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 LamCase
+        (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.
 
-      (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+  let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
 
   -- Note that we replace the MatchGroup result type by sum_ty,
   -- which is the type of matches'
@@ -1231,11 +1245,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
diff --git a/testsuite/tests/arrows/should_compile/T21301.hs b/testsuite/tests/arrows/should_compile/T21301.hs
new file mode 100644
index 0000000000..52e1e5ae13
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T21301.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE Arrows, EmptyCase #-}
+
+import Control.Arrow
+
+main = print $ baz (Just 43)
+
+baz :: ArrowChoice p => p (Maybe Int) String
+baz = proc x ->
+  (| id (case () of)
+  |) x
diff --git a/testsuite/tests/arrows/should_compile/T21301.stderr b/testsuite/tests/arrows/should_compile/T21301.stderr
new file mode 100644
index 0000000000..ac9dc11858
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T21301.stderr
@@ -0,0 +1 @@
+T21301: T21301.hs:(8,7)-(10,6): Non-exhaustive patterns in case
diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T
index 6d7e1b4102..781a26953b 100644
--- a/testsuite/tests/arrows/should_compile/all.T
+++ b/testsuite/tests/arrows/should_compile/all.T
@@ -18,3 +18,4 @@ test('T5283', normal, compile, [''])
 test('T5333', normal, compile, [''])
 test('T18950', normal, compile, [''])
 test('T15175', normal, compile, [''])
+test('T21301', [exit_code(1)], compile_and_run, [''])