Restore old GHC generics behavior vis-à-vis Fixity
authorRyanGlScott <ryan.gl.scott@gmail.com>
Wed, 6 Jan 2016 11:05:05 +0000 (12:05 +0100)
committerBen Gamari <ben@smart-cactus.org>
Wed, 6 Jan 2016 11:05:12 +0000 (12:05 +0100)
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

compiler/typecheck/TcGenGenerics.hs
testsuite/tests/generics/T11358.hs [new file with mode: 0644]
testsuite/tests/generics/T11358.stdout [new file with mode: 0644]
testsuite/tests/generics/all.T

index 8c44467..43433da 100644 (file)
@@ -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 (file)
index 0000000..8f52d5c
--- /dev/null
@@ -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 (file)
index 0000000..f7b347d
--- /dev/null
@@ -0,0 +1 @@
+Prefix, Infix LeftAssociative 9
index 3253483..cae975c 100644 (file)
@@ -35,7 +35,7 @@ test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques'])
 
 test('T7878', extra_clean(['T7878A.o'     ,'T7878A.hi'
                           ,'T7878A.o-boot','T7878A.hi-boot'
-                          ,'T7878B.o'     ,'T7878B.hi']), 
+                          ,'T7878B.o'     ,'T7878B.hi']),
               multimod_compile, ['T7878', '-v0'])
 
 test('T8468', normal, compile_fail, [''])
@@ -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, [''])