[commit: ghc] master: Restore old GHC generics behavior vis-Ã -vis Fixity (852b603)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/852b603029a047609a54453b1f9cd65035a43afe/ghc

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

commit 852b603029a047609a54453b1f9cd65035a43afe
Author: RyanGlScott <ryan.gl.scott at gmail.com>
Date:   Wed Jan 6 12:05:05 2016 +0100

    Restore old GHC generics behavior vis-à-vis Fixity
    
    Phab:D493 accidentally changed the way GHC generics looks up `Fixity`
    information when deriving `Generic` or `Generic1`. Before, a `Fixity` of
    `Infix` would be given only if a data constructor was declared infix,
    but now, `Infix` is given to any data constructor that has a fixity
    declaration (not to be confused with being declared infix!). This commit
    reverts back to the original behavior for consistency's sake.
    
    Fixes #11358.
    
    Test Plan: ./validate
    
    Reviewers: kosmikus, dreixel, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1740
    
    GHC Trac Issues: #11358


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

852b603029a047609a54453b1f9cd65035a43afe
 compiler/typecheck/TcGenGenerics.hs    | 18 +++++++-----------
 testsuite/tests/generics/T11358.hs     | 32 ++++++++++++++++++++++++++++++++
 testsuite/tests/generics/T11358.stdout |  1 +
 testsuite/tests/generics/all.T         |  1 +
 4 files changed, 41 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 8c44467..43433da 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -25,7 +25,6 @@ import Module           ( Module, moduleName, moduleNameFS
                         , moduleUnitId, unitIdFS )
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
-import NameEnv ( lookupNameEnv )
 import RdrName
 import BasicTypes
 import TysPrim
@@ -574,19 +573,16 @@ tc_mkRepTy gk_ tycon =
                               else promotedFalseDataCon
 
         ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
-        ctFix c = case myLookupFixity fix_env (dataConName c) of
-                    Just (Fixity n InfixL) -> buildFix n pLA
-                    Just (Fixity n InfixR) -> buildFix n pRA
-                    Just (Fixity n InfixN) -> buildFix n pNA
-                    Nothing                -> mkTyConTy pPrefix
+        ctFix c
+            | dataConIsInfix c
+            = case lookupFixity fix_env (dataConName c) of
+                   Fixity n InfixL -> buildFix n pLA
+                   Fixity n InfixR -> buildFix n pRA
+                   Fixity n InfixN -> buildFix n pNA
+            | otherwise = mkTyConTy pPrefix
         buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
                                              , mkNumLitTy (fromIntegral n)]
 
-        myLookupFixity :: FixityEnv -> Name -> Maybe Fixity
-        myLookupFixity env n = case lookupNameEnv env n of
-                                 Just (FixItem _ fix) -> Just fix
-                                 Nothing              -> Nothing
-
         isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0
                               then promotedTrueDataCon
                               else promotedFalseDataCon
diff --git a/testsuite/tests/generics/T11358.hs b/testsuite/tests/generics/T11358.hs
new file mode 100644
index 0000000..8f52d5c
--- /dev/null
+++ b/testsuite/tests/generics/T11358.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Main (main) where
+
+import GHC.Generics
+
+infixr 1 `T`
+data T a = T a a deriving Generic
+instance HasFixity (T a)
+
+data I a = a `I` a deriving Generic
+instance HasFixity (I a)
+
+class HasFixity a where
+  fixity :: a -> Fixity
+  default fixity :: (Generic a, GHasFixity (Rep a)) => a -> Fixity
+  fixity = gfixity . from
+
+class GHasFixity f where
+  gfixity :: f a -> Fixity
+
+instance GHasFixity f => GHasFixity (D1 d f) where
+  gfixity (M1 x) = gfixity x
+
+instance Constructor c => GHasFixity (C1 c f) where
+  gfixity c = conFixity c
+
+main :: IO ()
+main = do
+  putStrLn $ show (fixity (T "a" "b")) ++ ", " ++ show (fixity ("a" `I` "b"))
diff --git a/testsuite/tests/generics/T11358.stdout b/testsuite/tests/generics/T11358.stdout
new file mode 100644
index 0000000..f7b347d
--- /dev/null
+++ b/testsuite/tests/generics/T11358.stdout
@@ -0,0 +1 @@
+Prefix, Infix LeftAssociative 9
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index 3253483..cae975c 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -44,3 +44,4 @@ test('T9563', normal, compile, [''])
 test('T10030', normal, compile_and_run, [''])
 test('T10361a', normal, compile, [''])
 test('T10361b', normal, compile, [''])
+test('T11358', normal, compile_and_run, [''])