Use newDFunName for both manual and derived instances (#17339)wip/T17339

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.

5 files changed, 45 insertions, 18 deletions

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'])