diff options
author | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-03-29 20:06:31 +0200 |
---|---|---|
committer | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-04-01 20:33:05 +0200 |
commit | 3596684e704fb4edc453ba0ae0c6c296c2812fbf (patch) | |
tree | 4d12443e49424a8a8cd16872955cfbc01cb638b3 /compiler | |
parent | c6f77f3912a9178cf839a14c3d6ed590820d18ed (diff) | |
download | haskell-3596684e704fb4edc453ba0ae0c6c296c2812fbf.tar.gz |
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
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Arrows.hs | 31 |
2 files changed, 38 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 |