diff options
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Arrows.hs | 42 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/T21301.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/T21301.stderr | 1 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/all.T | 1 |
5 files changed, 56 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 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, ['']) |