Implement the EmptyDataDeriving proposal

This implements the `EmptyDataDeriving` proposal put forth in
https://github.com/ghc-proposals/ghc-proposals/blob/dbf51608/proposals/0006-deriving-empty.rst.
This has two major changes:

* The introduction of an `EmptyDataDeriving` extension, which
  permits directly deriving `Eq`, `Ord`, `Read`, and `Show` instances
  for empty data types.
* An overhaul in the code that is emitted in derived instances for
  empty data types. To see an overview of the changes brought forth,
  refer to the changes to the 8.4.1 release notes.

Test Plan: ./validate

Reviewers: bgamari, dfeuer, austin, hvr, goldfire

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #7401, #10577, #13117

Differential Revision: https://phabricator.haskell.org/D4047

9 files changed, 276 insertions, 13 deletions

diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
index 47d5a984ab..e131c1cf5b 100644
--- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
+++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
@@ -2,25 +2,24 @@
 ==================== Derived instances ====================
 Derived class instances:
   instance GHC.Read.Read (DrvEmptyData.Void a) where
-    GHC.Read.readPrec
-      = GHC.Read.parens Text.ParserCombinators.ReadPrec.pfail
+    GHC.Read.readPrec = Text.ParserCombinators.ReadPrec.pfail
     GHC.Read.readList = GHC.Read.readListDefault
     GHC.Read.readListPrec = GHC.Read.readListPrecDefault
   
   instance GHC.Show.Show (DrvEmptyData.Void a) where
-    GHC.Show.showsPrec _ = GHC.Err.error "Void showsPrec"
+    GHC.Show.showsPrec z = case z of
   
   instance GHC.Classes.Ord (DrvEmptyData.Void a) where
-    GHC.Classes.compare _ _ = GHC.Err.error "Void compare"
+    GHC.Classes.compare _ z = GHC.Types.EQ
   
   instance GHC.Classes.Eq (DrvEmptyData.Void a) where
-    (GHC.Classes.==) _ _ = GHC.Err.error "Void =="
+    (GHC.Classes.==) _ z = GHC.Types.True
   
   instance Data.Data.Data a =>
            Data.Data.Data (DrvEmptyData.Void a) where
-    Data.Data.gfoldl _ _ _ = GHC.Err.error "Void gfoldl"
+    Data.Data.gfoldl _ _ z = case z of
     Data.Data.gunfold k z c = case Data.Data.constrIndex c of
-    Data.Data.toConstr _ = GHC.Err.error "Void toConstr"
+    Data.Data.toConstr z = case z of
     Data.Data.dataTypeOf _ = DrvEmptyData.$tVoid
     Data.Data.dataCast1 f = Data.Typeable.gcast1 f
   
@@ -46,8 +45,7 @@ Derived class instances:
   
   instance Language.Haskell.TH.Syntax.Lift
              (DrvEmptyData.Void a) where
-    Language.Haskell.TH.Syntax.lift _
-      = GHC.Err.error "Can't lift value of empty datatype Void"
+    Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of)
   
   DrvEmptyData.$tVoid :: Data.Data.DataType
   DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" []
@@ -65,3 +63,237 @@ Derived type family instances:
 
 
 ==================== Filling in method body ====================
+GHC.Read.Read [DrvEmptyData.Void a[ssk:2]]
+  GHC.Read.readsPrec = GHC.Read.$dmreadsPrec
+                         @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
+  GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
+  GHC.Show.showList = GHC.Show.$dmshowList
+                        @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Eq [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.dataCast2 = Data.Data.$dmdataCast2
+                          @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQl = Data.Data.$dmgmapQl
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQr = Data.Data.$dmgmapQr
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQi = Data.Data.$dmgmapQi
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapMp = Data.Data.$dmgmapMp
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapMo = Data.Data.$dmgmapMo
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.fold = Data.Foldable.$dmfold @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr = Data.Foldable.$dmfoldr @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr' = Data.Foldable.$dmfoldr' @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl = Data.Foldable.$dmfoldl @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl' = Data.Foldable.$dmfoldl' @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr1 = Data.Foldable.$dmfoldr1 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl1 = Data.Foldable.$dmfoldl1 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.toList = Data.Foldable.$dmtoList @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.null = Data.Foldable.$dmnull @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.length = Data.Foldable.$dmlength @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.elem = Data.Foldable.$dmelem @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.maximum = Data.Foldable.$dmmaximum
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.minimum = Data.Foldable.$dmminimum
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.sum = Data.Foldable.$dmsum @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.product = Data.Foldable.$dmproduct
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.sequenceA = Data.Traversable.$dmsequenceA
+                                 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.mapM = Data.Traversable.$dmmapM
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.sequence = Data.Traversable.$dmsequence
+                                @(DrvEmptyData.Void)
+
+
diff --git a/testsuite/tests/deriving/should_fail/T7401_fail.hs b/testsuite/tests/deriving/should_fail/T7401_fail.hs
new file mode 100644
index 0000000000..730223f179
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T7401_fail.hs
@@ -0,0 +1,3 @@
+module T7401_fail where
+
+data D deriving Eq
diff --git a/testsuite/tests/deriving/should_fail/T7401_fail.stderr b/testsuite/tests/deriving/should_fail/T7401_fail.stderr
new file mode 100644
index 0000000000..feb841f962
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T7401_fail.stderr
@@ -0,0 +1,6 @@
+
+T7401_fail.hs:3:17: error:
+    • Can't make a derived instance of ‘Eq D’:
+        ‘D’ must have at least one data constructor
+        Use EmptyDataDeriving to enable deriving for empty data types
+    • In the data declaration for ‘D’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index 1861e6dd0a..c9b8469c3c 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -44,6 +44,7 @@ test('T7148a', normal, compile_fail, [''])
 # T7800 was removed as it was out of date re: fixing #9858
 test('T5498', normal, compile_fail, [''])
 test('T6147', normal, compile_fail, [''])
+test('T7401_fail', normal, compile_fail, [''])
 test('T8165_fail1', normal, compile_fail, [''])
 test('T8165_fail2', normal, compile_fail, [''])
 test('T8851', normal, compile_fail, [''])
diff --git a/testsuite/tests/deriving/should_run/T5628.stderr b/testsuite/tests/deriving/should_run/T5628.stderr
deleted file mode 100644
index e203374673..0000000000
--- a/testsuite/tests/deriving/should_run/T5628.stderr
+++ /dev/null
@@ -1,3 +0,0 @@
-T5628: Void ==
-CallStack (from ImplicitParams):
-  error, called at T5628.hs:5:1 in main:Main
diff --git a/testsuite/tests/deriving/should_run/T5628.stdout b/testsuite/tests/deriving/should_run/T5628.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T5628.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/deriving/should_run/T7401.hs b/testsuite/tests/deriving/should_run/T7401.hs
new file mode 100644
index 0000000000..2f56df4e69
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T7401.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE EmptyDataDeriving #-}
+module Main where
+
+import Data.Function
+
+data Foo
+  deriving (Eq, Ord, Read, Show)
+
+foo1 :: Foo
+foo1 = fix id
+
+foo2 :: Foo
+foo2 = let x = y
+           y = x
+        in y
+
+main :: IO ()
+main = do
+  print (foo1 ==        foo2)
+  print (foo1 `compare` foo2)
diff --git a/testsuite/tests/deriving/should_run/T7401.stdout b/testsuite/tests/deriving/should_run/T7401.stdout
new file mode 100644
index 0000000000..886c3aedac
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T7401.stdout
@@ -0,0 +1,2 @@
+True
+EQ
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index 3bcebdf371..c5605f627e 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -32,8 +32,9 @@ test('drvrun-foldable1', normal, compile_and_run, [''])
 test('T4136', normal, compile_and_run, [''])
 test('T4528a', normal, compile_and_run, [''])
 test('T5041', normal, compile_and_run, [''])
-test('T5628', exit_code(1), compile_and_run, [''])
+test('T5628', normal, compile_and_run, [''])
 test('T5712', normal, compile_and_run, [''])
+test('T7401', normal, compile_and_run, [''])
 test('T7931', normal, compile_and_run, [''])
 # T8280 is superseded by T10104
 test('T9576', exit_code(1), compile_and_run, [''])