diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2022-01-24 18:35:27 -0500 |
---|---|---|
committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2022-01-24 19:10:43 -0500 |
commit | 88ec3a83c4892c7079a6aa37c02885a1fa8da5ae (patch) | |
tree | ebb2af0d69f0f7cd7e582857348563cdeee240f8 | |
parent | 3b009e1a6247057ff976043695b797b5d0649414 (diff) | |
download | haskell-88ec3a83c4892c7079a6aa37c02885a1fa8da5ae.tar.gz |
DeriveGeneric: look up datacon fixities using getDataConFixityFunwip/T20994
Previously, `DeriveGeneric` would look up the fixity of a data constructor
using `getFixityEnv`, but this is subtly incorrect for data constructors
defined in external modules. This sort of situation can happen with
`StandaloneDeriving`, as noticed in #20994. In fact, the same bug has occurred
in the past in #9830, and while that bug was fixed for `deriving Read` and
`deriving Show`, the fix was never extended to `DeriveGeneric` due to an
oversight. This patch corrects that oversight.
Fixes #20994.
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generics.hs | 32 | ||||
-rw-r--r-- | compiler/GHC/Tc/Deriv/Utils.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T20994.hs | 27 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 1 |
4 files changed, 49 insertions, 19 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index a6969170c9..56b7e0de09 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -37,7 +37,6 @@ import GHC.Unit.Module ( moduleName, moduleNameFS import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader -import GHC.Types.Fixity.Env import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic @@ -77,11 +76,11 @@ For the generic representation we need to generate: \end{itemize} -} -gen_Generic_binds :: GenericKind -> [Type] -> DerivInstTys +gen_Generic_binds :: GenericKind -> (Name -> Fixity) -> [Type] -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst) -gen_Generic_binds gk inst_tys dit = do +gen_Generic_binds gk get_fixity inst_tys dit = do dflags <- getDynFlags - repTyInsts <- tc_mkRepFamInsts gk inst_tys dit + repTyInsts <- tc_mkRepFamInsts gk get_fixity inst_tys dit let (binds, sigs) = mkBindsRep dflags gk dit return (binds, sigs, repTyInsts) @@ -390,13 +389,14 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> DerivInstTys -- Information about the last type argument, - -- including the data type's TyCon - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> (Name -> Fixity) -- Get the Fixity for a data constructor Name + -> [Type] -- The type(s) to which Generic(1) is applied + -- in the generated instance + -> DerivInstTys -- Information about the last type argument, + -- including the data type's TyCon + -> TcM FamInst -- Generated representation0 coercion +tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -426,7 +426,7 @@ tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = where all_tyvars = tyConTyVars tycon -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ dit arg_ki + ; repTy <- tc_mkRepTy gk_ get_fixity dit arg_ki -- `rep_name` is a name we generate for the synonym ; mod <- getModule @@ -526,6 +526,8 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_ + -- Get the Fixity for a data constructor Name + -> (Name -> Fixity) -- Information about the last type argument to Generic(1) -> DerivInstTys -- The kind of the representation type's argument @@ -533,7 +535,7 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 -> Kind -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k = +tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName @@ -573,8 +575,6 @@ tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k = pDStr <- tcLookupPromDataCon decidedStrictDataConName pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - fix_env <- getFixityEnv - let mkSum' a b = mkTyConApp plus [k,a,b] mkProd a b = mkTyConApp times [k,a,b] mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a @@ -631,7 +631,7 @@ tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k = ctName = mkStrLitTy . occNameFS . nameOccName . dataConName ctFix c | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of + = case get_fixity (dataConName c) of Fixity _ n InfixL -> buildFix n pLA Fixity _ n InfixR -> buildFix n pRA Fixity _ n InfixN -> buildFix n pNA diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 1737ae2e50..2036e98300 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -584,8 +584,10 @@ hasStockDeriving clas ; return (binds, [], deriv_stuff, field_names) } generic gen_fn _ inst_tys dit - = do { (binds, sigs, faminst) <- gen_fn inst_tys dit - ; let field_names = all_field_names (dit_rep_tc dit) + = do { let tc = dit_rep_tc dit + ; fix_env <- getDataConFixityFun tc + ; (binds, sigs, faminst) <- gen_fn fix_env inst_tys dit + ; let field_names = all_field_names tc ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) } -- See Note [Deriving and unused record selectors] @@ -626,7 +628,7 @@ getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file --- c.f. GHC.Rename.Env.lookupFixity, and #9830 +-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994 getDataConFixityFun tc = do { this_mod <- getModule ; if nameIsLocalOrFrom this_mod name diff --git a/testsuite/tests/deriving/should_compile/T20994.hs b/testsuite/tests/deriving/should_compile/T20994.hs new file mode 100644 index 0000000000..807f16a9b6 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T20994.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T20994 where + +import Data.Kind (Constraint, Type) +import GHC.Generics + +type (++) :: [a] -> [a] -> [a] +type family xs ++ ys where + '[] ++ ys = ys + (x:xs) ++ ys = x:(xs ++ ys) + +type GetConFixities :: (Type -> Type) -> [FixityI] +type family GetConFixities rep where + GetConFixities (D1 (MetaData _ _ _ _) f) = GetConFixities f + GetConFixities (C1 (MetaCons _ fix _) _) = '[fix] + GetConFixities (f :+: g) = GetConFixities f ++ GetConFixities g + GetConFixities V1 = '[] + +type Dict :: Constraint -> Type +data Dict c where + Dict :: c => Dict c + +-- Check that (:) is `infixr 5` according to its Rep instance. +test :: Dict (GetConFixities (Rep [a]) ~ [PrefixI, InfixI RightAssociative 5]) +test = Dict diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 4a80c84cc1..a33cb364c3 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -136,3 +136,4 @@ test('T20496', multiline_grep_errmsg(r"rnd\n( .*\n)*"), compile, ['-ddump-tc-tra test('T20375', normal, compile, ['']) test('T20387', normal, compile, ['']) test('T20501', normal, compile, ['']) +test('T20994', normal, compile, ['']) |