[commit: ghc] master: Fix elemLocalRdrEnv (Trac #9160) (b637585)
git at git.haskell.org
git at git.haskell.org
Thu Jun 12 16:23:50 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/b637585dcbfc1ba53aa49bcb9b730cd08fea4b59/ghc
>---------------------------------------------------------------
commit b637585dcbfc1ba53aa49bcb9b730cd08fea4b59
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Jun 12 16:42:37 2014 +0100
Fix elemLocalRdrEnv (Trac #9160)
This was pretty obscure. elemLocalRdrEnv was utterly wrong (replied
False when it should reply True) when given an Exact Name. That
doesn't happen often, but it does happen in the result of a TH splice.
The result was that an associated type didn't get a type variable that
lined up with its parent class (elemLocalRdrEnv is used in
RnTypes.bindHsTyVars), and that messed up the singletons package.
I've made a completely different test case to show up the bug:
indexed_types/should_fail/T9160
I also refactored RdrName.LocalRdrEnv to be a record with named
fields, which makes the code more robust and easy to understand.
>---------------------------------------------------------------
b637585dcbfc1ba53aa49bcb9b730cd08fea4b59
compiler/basicTypes/RdrName.lhs | 60 +++++++++++++++-------
testsuite/tests/indexed-types/should_fail/T9160.hs | 19 +++++++
.../tests/indexed-types/should_fail/T9160.stderr | 11 ++++
testsuite/tests/indexed-types/should_fail/all.T | 1 +
4 files changed, 72 insertions(+), 19 deletions(-)
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index ceab808..ebfb71a 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -331,49 +331,71 @@ instance Ord RdrName where
-- It is keyed by OccName, because we never use it for qualified names
-- We keep the current mapping, *and* the set of all Names in scope
-- Reason: see Note [Splicing Exact Names] in RnEnv
-type LocalRdrEnv = (OccEnv Name, NameSet)
+data LocalRdrEnv = LRE { lre_env :: OccEnv Name
+ , lre_in_scope :: NameSet }
+
+instance Outputable LocalRdrEnv where
+ ppr (LRE {lre_env = env, lre_in_scope = ns})
+ = hang (ptext (sLit "LocalRdrEnv {"))
+ 2 (vcat [ ptext (sLit "env =") <+> pprOccEnv ppr_elt env
+ , ptext (sLit "in_scope =") <+> braces (pprWithCommas ppr (nameSetToList ns))
+ ] <+> char '}')
+ where
+ ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
+ -- So we can see if the keys line up correctly
emptyLocalRdrEnv :: LocalRdrEnv
-emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv, lre_in_scope = emptyNameSet }
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
-- The Name should be a non-top-level thing
-extendLocalRdrEnv (env, ns) name
+extendLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) name
= WARN( isExternalName name, ppr name )
- ( extendOccEnv env (nameOccName name) name
- , addOneToNameSet ns name
- )
+ LRE { lre_env = extendOccEnv env (nameOccName name) name
+ , lre_in_scope = addOneToNameSet ns name }
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
-extendLocalRdrEnvList (env, ns) names
+extendLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) names
= WARN( any isExternalName names, ppr names )
- ( extendOccEnvList env [(nameOccName n, n) | n <- names]
- , addListToNameSet ns names
- )
+ LRE { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
+ , lre_in_scope = addListToNameSet ns names }
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
-lookupLocalRdrEnv _ _ = Nothing
+lookupLocalRdrEnv (LRE { lre_env = env }) (Unqual occ) = lookupOccEnv env occ
+lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
-lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
-elemLocalRdrEnv rdr_name (env, _)
- | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
- | otherwise = False
+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })
+ = case rdr_name of
+ Unqual occ -> occ `elemOccEnv` env
+ Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names]
+ Qual {} -> False
+ Orig {} -> False
localRdrEnvElts :: LocalRdrEnv -> [Name]
-localRdrEnvElts (env, _) = occEnvElts env
+localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
-- This is the point of the NameSet
-inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
-delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
+delLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) occs
+ = LRE { lre_env = delListFromOccEnv env occs
+ , lre_in_scope = ns }
\end{code}
+Note [Local bindings with Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Template Haskell we can make local bindings that have Exact Names.
+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
+does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult
+the in-scope-name-set.
+
+
%************************************************************************
%* *
GlobalRdrEnv
diff --git a/testsuite/tests/indexed-types/should_fail/T9160.hs b/testsuite/tests/indexed-types/should_fail/T9160.hs
new file mode 100644
index 0000000..64ae3b9
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9160.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE FlexibleInstances, TemplateHaskell, PolyKinds, TypeFamilies #-}
+
+module T9160 where
+import Language.Haskell.TH
+
+$( do { cls_nm <- newName "C"
+ ; a_nm <- newName "a"
+ ; k_nm <- newName "k"
+ ; f_nm <- newName "F"
+ ; return [ClassD [] cls_nm [KindedTV a_nm (VarT k_nm)] []
+ [FamilyD TypeFam f_nm [] (Just (VarT k_nm))]] } )
+
+-- Splices in:
+-- class C (a :: k) where
+-- type F :: k
+
+instance C (a :: *) where
+ type F = Maybe -- Should be illegal
+
diff --git a/testsuite/tests/indexed-types/should_fail/T9160.stderr b/testsuite/tests/indexed-types/should_fail/T9160.stderr
new file mode 100644
index 0000000..7a476d4
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9160.stderr
@@ -0,0 +1,11 @@
+Loading package ghc-prim ... linking ... done.
+Loading package integer-gmp ... linking ... done.
+Loading package base ... linking ... done.
+Loading package pretty-1.1.1.1 ... linking ... done.
+Loading package template-haskell ... linking ... done.
+
+T9160.hs:18:8:
+ Type indexes must match class instance head
+ Found ‘* -> *’ but expected ‘*’
+ In the type instance declaration for ‘F’
+ In the instance declaration for ‘C (a :: *)’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 9d3f851..2c5ae68 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -123,3 +123,4 @@ test('T9036', normal, compile_fail, [''])
test('T9167', normal, compile_fail, [''])
test('T9171', normal, compile_fail, [''])
test('T9097', normal, compile_fail, [''])
+test('T9160', normal, compile_fail, [''])
More information about the ghc-commits
mailing list