Commit 852b6030 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 4dc4b844
......@@ -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
......
{-# 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"))
Prefix, Infix LeftAssociative 9
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment