From bb3fe2f4d63a0ba9e86c32835b6a0c3f4d06dd7e Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Thu, 30 Sep 2021 03:38:43 -0400
Subject: [PATCH] Improve pre-empty-case situation

* Move all the empty case CPP crud into its own module. We just
  need to define a single `absurd1 :: V1 a -> b` function.

* Use `pseq` to guarantee that the compat code will actually
  produce the *correct* bottom.
---
 generic-deriving.cabal               |  1 +
 src/Generics/Deriving/Absurd.hs      | 24 ++++++++++++++++++++++++
 src/Generics/Deriving/Functor.hs     | 14 +++-----------
 src/Generics/Deriving/Show.hs        | 13 ++-----------
 src/Generics/Deriving/Traversable.hs | 13 ++-----------
 5 files changed, 32 insertions(+), 33 deletions(-)
 create mode 100644 src/Generics/Deriving/Absurd.hs

diff --git a/generic-deriving.cabal b/generic-deriving.cabal
index 94cc5db..024eb27 100644
--- a/generic-deriving.cabal
+++ b/generic-deriving.cabal
@@ -119,6 +119,7 @@ library
                         Generics.Deriving.Monoid.Internal
                         Generics.Deriving.Semigroup.Internal
                         Generics.Deriving.TH.Internal
+                        Generics.Deriving.Absurd
                         Paths_generic_deriving
   if flag(base-4-9)
     build-depends:      base >= 4.9 && < 5
diff --git a/src/Generics/Deriving/Absurd.hs b/src/Generics/Deriving/Absurd.hs
new file mode 100644
index 0000000..7645227
--- /dev/null
+++ b/src/Generics/Deriving/Absurd.hs
@@ -0,0 +1,24 @@
+{-# language CPP #-}
+#if __GLASGOW_HASKELL__ >= 708
+{-# language EmptyCase #-}
+#endif
+module Generics.Deriving.Absurd where
+import GHC.Generics
+#if __GLASGOW_HASKELL__ < 708
+import GHC.Conc (pseq)
+#endif
+
+absurd1 :: V1 a -> b
+absurd1 x =
+#if __GLASGOW_HASKELL__ >= 708
+  case x of {}
+#else
+  -- Using pseq instead of seq or a bang pattern guarantees
+  -- that the impossible error will never be reached.
+  pseq x impossible
+#endif
+{-# INLINE absurd1 #-}
+
+impossible :: a
+impossible = error "Utterly impossible"
+{-# NOINLINE impossible #-}
diff --git a/src/Generics/Deriving/Functor.hs b/src/Generics/Deriving/Functor.hs
index 82cd271..ddbd853 100644
--- a/src/Generics/Deriving/Functor.hs
+++ b/src/Generics/Deriving/Functor.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -13,10 +12,6 @@
 {-# LANGUAGE PolyKinds #-}
 #endif
 
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE EmptyCase #-}
-#endif
-
 #if __GLASGOW_HASKELL__ >= 710
 {-# LANGUAGE Safe #-}
 #elif __GLASGOW_HASKELL__ >= 701
@@ -69,6 +64,8 @@ import qualified Data.Semigroup as Semigroup (First, Last)
 import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)
 #endif
 
+import           Generics.Deriving.Absurd (absurd1)
+
 --------------------------------------------------------------------------------
 -- Generic fmap
 --------------------------------------------------------------------------------
@@ -77,12 +74,7 @@ class GFunctor' f where
   gmap' :: (a -> b) -> f a -> f b
 
 instance GFunctor' V1 where
-  gmap' _ x = case x of
-#if __GLASGOW_HASKELL__ >= 708
-                {}
-#else
-                !_ -> error "Void gmap"
-#endif
+  gmap' _ x = absurd1 x
 
 instance GFunctor' U1 where
   gmap' _ U1 = U1
diff --git a/src/Generics/Deriving/Show.hs b/src/Generics/Deriving/Show.hs
index cf2cfc6..632724d 100644
--- a/src/Generics/Deriving/Show.hs
+++ b/src/Generics/Deriving/Show.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -12,10 +11,6 @@
 {-# LANGUAGE Trustworthy #-}
 #endif
 
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE EmptyCase #-}
-#endif
-
 module Generics.Deriving.Show (
   -- * Generic show class
     GShow(..)
@@ -42,6 +37,7 @@ import           Foreign.ForeignPtr (ForeignPtr)
 import           Foreign.Ptr
 
 import           Generics.Deriving.Base
+import           Generics.Deriving.Absurd (absurd1)
 
 import           GHC.Exts hiding (Any)
 
@@ -91,12 +87,7 @@ class GShow' f where
   isNullary = error "generic show (isNullary): unnecessary case"
 
 instance GShow' V1 where
-  gshowsPrec' _ _ x = case x of
-#if __GLASGOW_HASKELL__ >= 708
-                        {}
-#else
-                        !_ -> error "Void gshowsPrec"
-#endif
+  gshowsPrec' _ _ x = absurd1 x
 
 instance GShow' U1 where
   gshowsPrec' _ _ U1 = id
diff --git a/src/Generics/Deriving/Traversable.hs b/src/Generics/Deriving/Traversable.hs
index 3d831eb..f00661f 100644
--- a/src/Generics/Deriving/Traversable.hs
+++ b/src/Generics/Deriving/Traversable.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -13,10 +12,6 @@
 {-# LANGUAGE PolyKinds #-}
 #endif
 
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE EmptyCase #-}
-#endif
-
 #if __GLASGOW_HASKELL__ >= 710
 {-# LANGUAGE Safe #-}
 #elif __GLASGOW_HASKELL__ >= 701
@@ -46,6 +41,7 @@ import           Data.Monoid (Dual)
 import           Generics.Deriving.Base
 import           Generics.Deriving.Foldable
 import           Generics.Deriving.Functor
+import           Generics.Deriving.Absurd
 
 #if MIN_VERSION_base(4,4,0)
 import           Data.Complex (Complex)
@@ -81,12 +77,7 @@ class GTraversable' t where
   gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)
 
 instance GTraversable' V1 where
-  gtraverse' _ x = pure $ case x of
-#if __GLASGOW_HASKELL__ >= 708
-                            {}
-#else
-                            !_ -> error "Void gtraverse"
-#endif
+  gtraverse' _ x = absurd1 x
 
 instance GTraversable' U1 where
   gtraverse' _ U1 = pure U1