summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/prelude/PrelNames.hs3
-rw-r--r--compiler/typecheck/TcGenGenerics.hs8
-rw-r--r--docs/users_guide/glasgow_exts.xml1
-rw-r--r--libraries/base/GHC/Generics.hs6
-rw-r--r--testsuite/tests/generics/GenDerivOutput.stderr2
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_0.stderr1
-rw-r--r--testsuite/tests/generics/GenDerivOutput1_1.stderr4
-rw-r--r--testsuite/tests/generics/T10030.hs7
-rw-r--r--testsuite/tests/generics/T10030.stdout2
-rw-r--r--testsuite/tests/generics/all.T1
-rw-r--r--testsuite/tests/perf/compiler/T5642.hs1
11 files changed, 33 insertions, 3 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 3b40385c22..dbee720135 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -693,7 +693,7 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
prodDataCon_RDR, comp1DataCon_RDR,
unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,
from_RDR, from1_RDR, to_RDR, to1_RDR,
- datatypeName_RDR, moduleName_RDR, isNewtypeName_RDR,
+ datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,
conName_RDR, conFixity_RDR, conIsRecord_RDR,
noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
@@ -723,6 +723,7 @@ to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1")
datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName")
+packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName")
isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype")
selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName")
conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName")
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 2c90c17baa..649aa5fc99 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -24,7 +24,8 @@ import DataCon
import TyCon
import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
-import Module ( Module, moduleName, moduleNameString )
+import Module ( Module, moduleName, moduleNameString
+ , modulePackageKey, packageKeyString )
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
import RdrName
@@ -680,7 +681,8 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
[ unitBag (mkRdrFunBind (L loc name) matches)
| (name, matches) <- l ]
dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches)
- , (moduleName_RDR, moduleName_matches)]
+ , (moduleName_RDR, moduleName_matches)
+ , (packageName_RDR, pkgName_matches)]
++ ifElseEmpty (isNewTyCon tycon)
[ (isNewtypeName_RDR, isNewtype_matches) ] )
@@ -716,6 +718,8 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
$ tyConName_user
moduleName_matches = mkStringLHS . moduleNameString . moduleName
. nameModule . tyConName $ tycon
+ pkgName_matches = mkStringLHS . packageKeyString . modulePackageKey
+ . nameModule . tyConName $ tycon
isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
conName_matches c = mkStringLHS . occNameString . nameOccName
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 279c59c9c4..f38e0d7351 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -12358,6 +12358,7 @@ data C1_1UserTree
instance Datatype D1UserTree where
datatypeName _ = "UserTree"
moduleName _ = "Main"
+ packageName _ = "main"
instance Constructor C1_0UserTree where
conName _ = "Node"
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index b89d628526..39700051ea 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -648,6 +648,8 @@ class Datatype d where
datatypeName :: t d (f :: * -> *) a -> [Char]
-- | The fully-qualified name of the module where the type is declared
moduleName :: t d (f :: * -> *) a -> [Char]
+ -- | The package name of the module where the type is declared
+ packageName :: t d (f :: * -> *) a -> [Char]
-- | Marks if the datatype is actually a newtype
isNewtype :: t d (f :: * -> *) a -> Bool
isNewtype _ = False
@@ -756,6 +758,7 @@ data C_Int
instance Datatype D_Int where
datatypeName _ = "Int"
moduleName _ = "GHC.Int"
+ packageName _ = "base"
instance Constructor C_Int where
conName _ = "" -- JPM: I'm not sure this is the right implementation...
@@ -773,6 +776,7 @@ data C_Float
instance Datatype D_Float where
datatypeName _ = "Float"
moduleName _ = "GHC.Float"
+ packageName _ = "base"
instance Constructor C_Float where
conName _ = "" -- JPM: I'm not sure this is the right implementation...
@@ -790,6 +794,7 @@ data C_Double
instance Datatype D_Double where
datatypeName _ = "Double"
moduleName _ = "GHC.Float"
+ packageName _ = "base"
instance Constructor C_Double where
conName _ = "" -- JPM: I'm not sure this is the right implementation...
@@ -807,6 +812,7 @@ data C_Char
instance Datatype D_Char where
datatypeName _ = "Char"
moduleName _ = "GHC.Base"
+ packageName _ = "base"
instance Constructor C_Char where
conName _ = "" -- JPM: I'm not sure this is the right implementation...
diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr
index b47b3f3e42..68283ef63f 100644
--- a/testsuite/tests/generics/GenDerivOutput.stderr
+++ b/testsuite/tests/generics/GenDerivOutput.stderr
@@ -91,6 +91,7 @@ Derived instances:
instance GHC.Generics.Datatype GenDerivOutput.D1List where
GHC.Generics.datatypeName _ = "List"
GHC.Generics.moduleName _ = "GenDerivOutput"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor GenDerivOutput.C1_0List where
GHC.Generics.conName _ = "Nil"
@@ -108,6 +109,7 @@ Derived instances:
instance GHC.Generics.Datatype GenDerivOutput.D1Rose where
GHC.Generics.datatypeName _ = "Rose"
GHC.Generics.moduleName _ = "GenDerivOutput"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor GenDerivOutput.C1_0Rose where
GHC.Generics.conName _ = "Empty"
diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr
index 222d2d3165..0a89f4bb1a 100644
--- a/testsuite/tests/generics/GenDerivOutput1_0.stderr
+++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr
@@ -24,6 +24,7 @@ Derived instances:
instance GHC.Generics.Datatype GenDerivOutput1_0.D1List where
GHC.Generics.datatypeName _ = "List"
GHC.Generics.moduleName _ = "GenDerivOutput1_0"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor GenDerivOutput1_0.C1_0List where
GHC.Generics.conName _ = "Nil"
diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr
index 6b9f546990..3fac6d2803 100644
--- a/testsuite/tests/generics/GenDerivOutput1_1.stderr
+++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr
@@ -156,6 +156,7 @@ Derived instances:
instance GHC.Generics.Datatype CanDoRep1_1.D1Da where
GHC.Generics.datatypeName _ = "Da"
GHC.Generics.moduleName _ = "CanDoRep1_1"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor CanDoRep1_1.C1_0Da where
GHC.Generics.conName _ = "D0"
@@ -173,6 +174,7 @@ Derived instances:
instance GHC.Generics.Datatype CanDoRep1_1.D1Db where
GHC.Generics.datatypeName _ = "Db"
GHC.Generics.moduleName _ = "CanDoRep1_1"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor CanDoRep1_1.C1_0Db where
GHC.Generics.conName _ = "D0b"
@@ -190,6 +192,7 @@ Derived instances:
instance GHC.Generics.Datatype CanDoRep1_1.D1Dc where
GHC.Generics.datatypeName _ = "Dc"
GHC.Generics.moduleName _ = "CanDoRep1_1"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dc where
GHC.Generics.conName _ = "D0c"
@@ -207,6 +210,7 @@ Derived instances:
instance GHC.Generics.Datatype CanDoRep1_1.D1Dd where
GHC.Generics.datatypeName _ = "Dd"
GHC.Generics.moduleName _ = "CanDoRep1_1"
+ GHC.Generics.packageName _ = "main"
instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dd where
GHC.Generics.conName _ = "D0d"
diff --git a/testsuite/tests/generics/T10030.hs b/testsuite/tests/generics/T10030.hs
new file mode 100644
index 0000000000..e57a115dfc
--- /dev/null
+++ b/testsuite/tests/generics/T10030.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import GHC.Generics
+
+main = do
+ putStrLn $ packageName $ from $ Just True
+ putStrLn $ packageName $ from $ True
diff --git a/testsuite/tests/generics/T10030.stdout b/testsuite/tests/generics/T10030.stdout
new file mode 100644
index 0000000000..8d9f99b6ec
--- /dev/null
+++ b/testsuite/tests/generics/T10030.stdout
@@ -0,0 +1,2 @@
+base
+ghc-prim
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index b5050e458a..c51de18a9c 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -40,3 +40,4 @@ test('T7878', extra_clean(['T7878A.o' ,'T7878A.hi'
test('T8468', normal, compile_fail, [''])
test('T8479', normal, compile, [''])
test('T9563', normal, compile, [''])
+test('T10030', normal, compile_and_run, [''])
diff --git a/testsuite/tests/perf/compiler/T5642.hs b/testsuite/tests/perf/compiler/T5642.hs
index 9e82f6a83f..0c466ea2ce 100644
--- a/testsuite/tests/perf/compiler/T5642.hs
+++ b/testsuite/tests/perf/compiler/T5642.hs
@@ -247,6 +247,7 @@ module GenBigTypes where
instance Datatype D1BigSum where
datatypeName _ = "BigSum"
moduleName _ = "GenBigTypes"
+ packageName _ = "main"
instance Constructor C1_0BigSum where
conName _ = "C0"
View Lorry Controller Status