Fix elemLocalRdrEnv (Trac #9160)
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Jun 2014 15:42:37 +0000 (16:42 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Jun 2014 15:42:37 +0000 (16:42 +0100)
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.

compiler/basicTypes/RdrName.lhs
testsuite/tests/indexed-types/should_fail/T9160.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T9160.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/all.T

index ceab808..ebfb71a 100644 (file)
@@ -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 (file)
index 0000000..64ae3b9
--- /dev/null
@@ -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 (file)
index 0000000..7a476d4
--- /dev/null
@@ -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 :: *)’
index 9d3f851..2c5ae68 100644 (file)
@@ -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, [''])