diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-09-16 13:30:42 +0100 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-09-17 10:06:02 +0100 |
commit | 2a5dc2420f0a001010593873da609cb7a5e08884 (patch) | |
tree | ca0352370ec9d3cd0742b0328fd5a8a7903d66c2 | |
parent | 2d15175266d0e0d9ca6565124b0c17e207b5541c (diff) | |
download | haskell-wip/t20371.tar.gz |
deriving: Always use module prefix in dataTypeNamewip/t20371
This fixes a long standard bug where the module prefix was omitted
from the data type name supplied by Data.Typeable instances.
Instead of reusing the Outputable instance for TyCon, we now take
matters into our own hands and explicitly print the module followed by
the type constructor name.
Fixes #20371
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T14682.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/drv-empty-data.stderr | 89 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_run/T20371.hs | 19 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_run/T20371.stdout | 6 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_run/T20371A.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_run/all.T | 1 |
7 files changed, 81 insertions, 51 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 7ceefbd57a..b63b7696b1 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -82,6 +82,8 @@ import GHC.Data.Pair import GHC.Data.Bag import Data.List ( find, partition, intersperse ) +import GHC.Data.Maybe ( expectJust ) +import GHC.Unit.Module type BagDerivStuff = Bag DerivStuff @@ -2139,9 +2141,12 @@ genAuxBindSpecOriginal dflags loc spec gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs) = mkHsVarBind loc dataT_RDR rhs where + tc_name = tyConName tycon + tc_name_string = occNameString (getOccName tc_name) + definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) ctx = initDefaultSDocContext dflags rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon))) + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string))) `nlHsApp` nlList (map nlHsVar dataC_RDRs) gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr index d888ad8e90..1d84be7b50 100644 --- a/testsuite/tests/deriving/should_compile/T14682.stderr +++ b/testsuite/tests/deriving/should_compile/T14682.stderr @@ -73,7 +73,7 @@ Derived class instances: $tFoo :: Data.Data.DataType $cFoo :: Data.Data.Constr - $tFoo = Data.Data.mkDataType "Foo" [$cFoo] + $tFoo = Data.Data.mkDataType "T14682.Foo" [$cFoo] $cFoo = Data.Data.mkConstrTag $tFoo "Foo" 1 [] Data.Data.Prefix Derived type family instances: diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr index cb0aca5e05..7523bf6d0b 100644 --- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr +++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr @@ -34,8 +34,7 @@ Derived class instances: Data.Traversable.traverse _ z = GHC.Base.pure (case z of {}) instance GHC.Generics.Generic (DrvEmptyData.Void a) where - GHC.Generics.from x - = GHC.Generics.M1 (case x of x -> case x of {}) + GHC.Generics.from x = GHC.Generics.M1 (case x of x -> case x of {}) GHC.Generics.to (GHC.Generics.M1 x) = case x of x -> case x of {} instance GHC.Generics.Generic1 DrvEmptyData.Void where @@ -51,7 +50,7 @@ Derived class instances: (GHC.Base.pure (case z of {})) $tVoid :: Data.Data.DataType - $tVoid = Data.Data.mkDataType "Void" [] + $tVoid = Data.Data.mkDataType "DrvEmptyData.Void" [] Derived type family instances: type GHC.Generics.Rep (DrvEmptyData.Void a) = GHC.Generics.D1 @@ -66,124 +65,116 @@ Derived type family instances: ==================== Filling in method body ==================== -GHC.Read.Read [DrvEmptyData.Void a[ssk:1]] - GHC.Read.readsPrec = GHC.Read.$dmreadsPrec - @(DrvEmptyData.Void a[ssk:1]) +GHC.Read.Read [DrvEmptyData.Void a] + GHC.Read.readsPrec = GHC.Read.$dmreadsPrec @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Show.Show [DrvEmptyData.Void a[ssk:1]] - GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a[ssk:1]) +GHC.Show.Show [DrvEmptyData.Void a] + GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Show.Show [DrvEmptyData.Void a[ssk:1]] - GHC.Show.showList = GHC.Show.$dmshowList - @(DrvEmptyData.Void a[ssk:1]) +GHC.Show.Show [DrvEmptyData.Void a] + GHC.Show.showList = GHC.Show.$dmshowList @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]] - GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Ord [DrvEmptyData.Void a] + GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -GHC.Classes.Eq [DrvEmptyData.Void a[ssk:1]] - GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a[ssk:1]) +GHC.Classes.Eq [DrvEmptyData.Void a] + GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.dataCast2 = Data.Data.$dmdataCast2 - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.dataCast2 = Data.Data.$dmdataCast2 @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapQl = Data.Data.$dmgmapQl - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapQl = Data.Data.$dmgmapQl @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapQr = Data.Data.$dmgmapQr - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapQr = Data.Data.$dmgmapQr @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapQi = Data.Data.$dmgmapQi - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapQi = Data.Data.$dmgmapQi @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapMp = Data.Data.$dmgmapMp - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapMp = Data.Data.$dmgmapMp @(DrvEmptyData.Void a) ==================== Filling in method body ==================== -Data.Data.Data [DrvEmptyData.Void a[ssk:1]] - Data.Data.gmapMo = Data.Data.$dmgmapMo - @(DrvEmptyData.Void a[ssk:1]) +Data.Data.Data [DrvEmptyData.Void a] + Data.Data.gmapMo = Data.Data.$dmgmapMo @(DrvEmptyData.Void a) diff --git a/testsuite/tests/deriving/should_run/T20371.hs b/testsuite/tests/deriving/should_run/T20371.hs new file mode 100644 index 0000000000..4b783914e5 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T20371.hs @@ -0,0 +1,19 @@ +module Main where + +import T20371A + +import Data.Data +import Data.Monoid +import Data.Functor.Identity + +data C = C deriving Data + +main = do + print (dataTypeName $ dataTypeOf A) + print (dataTypeName $ dataTypeOf (A :.: A)) + print (dataTypeName $ dataTypeOf C) + + print (dataTypeName $ dataTypeOf (All True)) + print (dataTypeName $ dataTypeOf (Identity True)) + print (dataTypeName $ dataTypeOf (Just True)) + diff --git a/testsuite/tests/deriving/should_run/T20371.stdout b/testsuite/tests/deriving/should_run/T20371.stdout new file mode 100644 index 0000000000..884ff0005f --- /dev/null +++ b/testsuite/tests/deriving/should_run/T20371.stdout @@ -0,0 +1,6 @@ +"T20371A.A" +"T20371A.:*:" +"Main.C" +"Data.Semigroup.Internal.All" +"Data.Functor.Identity.Identity" +"GHC.Maybe.Maybe" diff --git a/testsuite/tests/deriving/should_run/T20371A.hs b/testsuite/tests/deriving/should_run/T20371A.hs new file mode 100644 index 0000000000..8c0789f75e --- /dev/null +++ b/testsuite/tests/deriving/should_run/T20371A.hs @@ -0,0 +1,8 @@ +module T20371A where + +import Data.Data + +data A = A deriving Data + +data a :*: b = a :.: b deriving Data + diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T index cf0cb922ed..0cec1db5f7 100644 --- a/testsuite/tests/deriving/should_run/all.T +++ b/testsuite/tests/deriving/should_run/all.T @@ -46,3 +46,4 @@ test('T10598_run', normal, compile_and_run, ['']) test('T11535', when(opsys('mingw32'), expect_broken_for(12210, ['ghci'])), compile_and_run, ['']) test('T14918', normal, compile_and_run, ['']) +test('T20371', normal, compile_and_run, ['-dppr-debug']) |