From 21ba8ecc6523883c7b0a2b17442e11ea4c090c23 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 10 Oct 2019 14:33:10 -0400 Subject: Use newDFunName for both manual and derived instances (#17339) Issue #17339 was caused by using a slightly different version of `newDFunName` for derived instances that, confusingly enough, did not take all arguments to the class into account when generating the `DFun` name. I cannot think of any good reason for doing this, so this patch uses `newDFunName` uniformly for both derived instances and manually written instances alike. Fixes #17339. --- compiler/typecheck/TcDeriv.hs | 4 ++-- compiler/typecheck/TcEnv.hs | 17 +--------------- testsuite/tests/deriving/should_compile/T17339.hs | 17 ++++++++++++++++ .../tests/deriving/should_compile/T17339.stderr | 23 ++++++++++++++++++++++ testsuite/tests/deriving/should_compile/all.T | 2 ++ 5 files changed, 45 insertions(+), 18 deletions(-) create mode 100644 testsuite/tests/deriving/should_compile/T17339.hs create mode 100644 testsuite/tests/deriving/should_compile/T17339.stderr diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 9b4f31e6d1..0efe7a75c7 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -1320,7 +1320,7 @@ mk_originative_eqn mechanism inst_tys = cls_tys ++ [inst_ty] doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM - dfun_name <- lift $ newDFunName' cls tc + dfun_name <- lift $ newDFunName cls inst_tys loc case deriv_ctxt of InferContext wildcard -> do { (inferred_constraints, tvs', inst_tys') @@ -1413,8 +1413,8 @@ mk_coerce_based_eqn mk_mechanism coerced_ty let mechanism = mk_mechanism coerced_ty atf_coerce_based_error_checks mechanism cls doDerivInstErrorChecks1 mechanism - dfun_name <- lift $ newDFunName' cls tycon loc <- lift getSrcSpanM + dfun_name <- lift $ newDFunName cls inst_tys loc case deriv_ctxt of SupplyContext theta -> return $ GivenTheta $ DS { ds_loc = loc diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 6ce37583a0..6f1ab3f19e 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -63,7 +63,7 @@ module TcEnv( topIdLvl, isBrackStage, -- New Ids - newDFunName, newDFunName', newFamInstTyConName, + newDFunName, newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName, mkWrapperName @@ -979,21 +979,6 @@ newDFunName clas tys loc ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } --- | Special case of 'newDFunName' to generate dict fun name for a single TyCon. -newDFunName' :: Class -> TyCon -> TcM Name -newDFunName' clas tycon -- Just a simple wrapper - = do { loc <- getSrcSpanM -- The location of the instance decl, - -- not of the tycon - ; newDFunName clas [mkTyConApp tycon []] loc } - -- The type passed to newDFunName is only used to generate - -- a suitable string; hence the empty type arg list - -{- -Make a name for the representation tycon of a family instance. It's an -*external* name, like other top-level names, and hence must be made with -newGlobalBinder. --} - newFamInstTyConName :: Located Name -> [Type] -> TcM Name newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] diff --git a/testsuite/tests/deriving/should_compile/T17339.hs b/testsuite/tests/deriving/should_compile/T17339.hs new file mode 100644 index 0000000000..4312d2ffc4 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T17339.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +module T17339 where + +class Cls a b +data A1 +data A2 +data B1 +data B2 + +instance Cls A1 B1 +instance Cls A2 B1 + +deriving anyclass instance Cls A1 B2 +deriving anyclass instance Cls A2 B2 diff --git a/testsuite/tests/deriving/should_compile/T17339.stderr b/testsuite/tests/deriving/should_compile/T17339.stderr new file mode 100644 index 0000000000..68da373ae4 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T17339.stderr @@ -0,0 +1,23 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 8, types: 20, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 2, coercions: 0, joins: 0/0} +T17339.$fClsA1B1 :: Cls A1 B1 +T17339.$fClsA1B1 = T17339.C:Cls @ A1 @ B1 + +-- RHS size: {terms: 1, types: 2, coercions: 0, joins: 0/0} +T17339.$fClsA2B1 :: Cls A2 B1 +T17339.$fClsA2B1 = T17339.C:Cls @ A2 @ B1 + +-- RHS size: {terms: 1, types: 2, coercions: 0, joins: 0/0} +T17339.$fClsA1B2 :: Cls A1 B2 +T17339.$fClsA1B2 = T17339.C:Cls @ A1 @ B2 + +-- RHS size: {terms: 1, types: 2, coercions: 0, joins: 0/0} +T17339.$fClsA2B2 :: Cls A2 B2 +T17339.$fClsA2B2 = T17339.C:Cls @ A2 @ B2 + + + diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 04fd02518f..55c7d90f09 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -119,3 +119,5 @@ test('T15831', normal, compile, ['']) test('T16179', normal, compile, ['']) test('T16518', normal, compile, ['']) test('T17324', normal, compile, ['']) +test('T17339', normal, compile, + ['-ddump-simpl -dsuppress-idinfo -dno-typeable-binds']) -- cgit v1.2.1