Use newDFunName for both manual and derived instances (#17339)
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 10 Oct 2019 18:33:10 +0000 (14:33 -0400)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Sat, 12 Oct 2019 10:33:42 +0000 (06:33 -0400)
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
compiler/typecheck/TcEnv.hs
testsuite/tests/deriving/should_compile/T17339.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/T17339.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T

index 9b4f31e..0efe7a7 100644 (file)
@@ -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
index 6ce3758..6f1ab3f 100644 (file)
@@ -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 (file)
index 0000000..4312d2f
--- /dev/null
@@ -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 (file)
index 0000000..68da373
--- /dev/null
@@ -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
+
+
+
index 04fd025..55c7d90 100644 (file)
@@ -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'])