[commit: ghc] ghc-8.0: Fix derived Ix instances for one-constructor GADTs (706a730)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/706a7305415a8e22b7dc4e2b8406f5b660642d1c/ghc

>---------------------------------------------------------------

commit 706a7305415a8e22b7dc4e2b8406f5b660642d1c
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sun Sep 11 10:27:36 2016 -0400

    Fix derived Ix instances for one-constructor GADTs
    
    Standalone-derived `Ix` instances would panic on GADTs with exactly
    one constructor, since the list of fields was being passed to a function that
    uses `foldl1` in order to generate an implementation for `inRange`. This adds a
    simple check that makes `inRange` be `True` whenever a product type has no
    fields.
    
    Fixes #12583.
    
    Test Plan: make test TEST=12583
    
    Reviewers: simonpj, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2521
    
    GHC Trac Issues: #12583
    
    (cherry picked from commit 7b7ea8f40e7400b8c183595a85bb2c65c9f9bb29)


>---------------------------------------------------------------

706a7305415a8e22b7dc4e2b8406f5b660642d1c
 compiler/hsSyn/HsExpr.hs                          | 12 +++++++++---
 compiler/typecheck/TcGenDeriv.hs                  |  7 ++++++-
 docs/users_guide/8.0.2-notes.rst                  |  3 +++
 testsuite/tests/deriving/should_compile/T12583.hs | 11 +++++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 5 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 103f59a..ee64c0c 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1899,9 +1899,15 @@ ppr_do_stmts stmts
 pprComp :: (OutputableBndr id, Outputable body)
         => [LStmt id body] -> SDoc
 pprComp quals     -- Prints:  body | qual1, ..., qualn
-  | not (null quals)
-  , L _ (LastStmt body _ _) <- last quals
-  = hang (ppr body <+> vbar) 2 (pprQuals (dropTail 1 quals))
+  | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
+  = if null initStmts
+       -- If there are no statements in a list comprehension besides the last
+       -- one, we simply treat it like a normal list. This does arise
+       -- occasionally in code that GHC generates, e.g., in implementations of
+       -- 'range' for derived 'Ix' instances for product datatypes with exactly
+       -- one constructor (e.g., see Trac #12583).
+       then ppr body
+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)
   | otherwise
   = pprPanic "pprComp" (pprQuals quals)
 
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index f2da4dd..8c6bc81 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -867,7 +867,12 @@ gen_Ix_binds loc tycon
       = mk_easy_FunBind loc inRange_RDR
                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                  con_pat cs_needed] $
-          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
+          if con_arity == 0
+             -- If the product type has no fields, inRange is trivially true
+             -- (see Trac #12853).
+             then true_Expr
+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
+                    as_needed bs_needed cs_needed)
       where
         in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
 
diff --git a/docs/users_guide/8.0.2-notes.rst b/docs/users_guide/8.0.2-notes.rst
index a5b106d..c121962 100644
--- a/docs/users_guide/8.0.2-notes.rst
+++ b/docs/users_guide/8.0.2-notes.rst
@@ -10,6 +10,9 @@ Highlights
 
 -  Many, many bug fixes.
 
+-  A bug has been fixed that caused standalone derived ``Ix`` instances to fail
+   for GADTs with exactly one constructor (:ghc-ticket:`12583`).
+
 Full details
 ------------
 
diff --git a/testsuite/tests/deriving/should_compile/T12583.hs b/testsuite/tests/deriving/should_compile/T12583.hs
new file mode 100644
index 0000000..9dc151b
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T12583.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T12583 where
+
+import Data.Ix
+
+data Foo a where
+  MkFoo :: (Eq a, Ord a, Ix a) => Foo a
+deriving instance Eq  (Foo a)
+deriving instance Ord (Foo a)
+deriving instance Ix  (Foo a)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 6b37420..473450d 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -72,3 +72,4 @@ test('T11732c', normal, compile, [''])
 test('T11833', normal, compile, [''])
 test('T11837', normal, compile, [''])
 test('T12399', normal, compile, [''])
+test('T12583', normal, compile, [''])