GHCi: fix scoping for record selectors
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 15 Jun 2015 12:32:48 +0000 (13:32 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 15 Jun 2015 12:35:34 +0000 (13:35 +0100)
This fixes Trac #10520.  See the "Ugh" note about
record selectors in HscTypes.icExtendGblRdrEnv.

compiler/main/HscMain.hs
compiler/main/HscTypes.hs
testsuite/tests/ghci/scripts/T10520.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T10520.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T

index 2708396..94896b0 100644 (file)
@@ -1513,16 +1513,15 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
                        , not (isDFunId id || isImplicitId id) ]
             -- We only need to keep around the external bindings
             -- (as decided by TidyPgm), since those are the only ones
-            -- that might be referenced elsewhere.
-            -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes
-            -- Implicit Ids are implicit in tcs
-
-        tythings =  map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
-
-    let icontext = hsc_IC hsc_env
-        ictxt    = extendInteractiveContext icontext ext_ids tcs
-                                            cls_insts fam_insts defaults patsyns
-    return (tythings, ictxt)
+            -- that might later be looked up by name.  But we can exclude
+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
+            --    - Implicit Ids, which are implicit in tcs
+            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
+
+        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
+        ictxt        = hsc_IC hsc_env
+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts fam_insts defaults
+    return (new_tythings, new_ictxt)
 
 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
index 67b0694..c2a5153 100644 (file)
@@ -1402,12 +1402,11 @@ icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =
 -- to them (e.g. instances for classes or values of the type for TyCons), it's
 -- not clear whether removing them is even the appropriate behavior.
 extendInteractiveContext :: InteractiveContext
-                         -> [Id] -> [TyCon]
+                         -> [TyThing]
                          -> [ClsInst] -> [FamInst]
                          -> Maybe [Type]
-                         -> [PatSyn]
                          -> InteractiveContext
-extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_patsyns
+extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults
   = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
                             -- Always bump this; even instances should create
                             -- a new mod_index (Trac #9426)
@@ -1417,8 +1416,8 @@ extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_
                             , new_fam_insts ++ old_fam_insts )
           , ic_default    = defaults }
   where
-    new_tythings = map AnId ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) new_patsyns
-    old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
+    new_ids = [id | AnId id <- new_tythings]
+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)
 
     -- Discard old instances that have been fully overrridden
     -- See Note [Override identical instances in GHCi]
@@ -1427,14 +1426,15 @@ extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_
     old_fam_insts = filterOut (\i -> any (identicalFamInstHead i) new_fam_insts) fam_insts
 
 extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
-extendInteractiveContextWithIds ictxt ids
-  | null ids  = ictxt
-  | otherwise = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
-                      , ic_tythings   = new_tythings ++ old_tythings
-                      , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }
+-- Just a specialised version
+extendInteractiveContextWithIds ictxt new_ids
+  | null new_ids = ictxt
+  | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
+                         , ic_tythings   = new_tythings ++ old_tythings
+                         , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }
   where
-    new_tythings = map AnId ids
-    old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
+    new_tythings = map AnId new_ids
+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)
 
 shadowed_by :: [Id] -> TyThing -> Bool
 shadowed_by ids = shadowed
@@ -1460,11 +1460,26 @@ icExtendGblRdrEnv env tythings
                             -- the list shadow things at the back
   where
     -- One at a time, to ensure each shadows the previous ones
-    add thing env = foldl extendGlobalRdrEnv env1 (localGREsFromAvail avail)
+    add thing env
+       | is_sub_bndr thing
+       = env
+       | otherwise
+       = foldl extendGlobalRdrEnv env1 (localGREsFromAvail avail)
        where
           env1  = shadowNames env (availNames avail)
           avail = tyThingAvailInfo thing
 
+    -- Ugh! The new_tythings may include record selectors, since they
+    -- are not implicit-ids, and must appear in the TypeEnv.  But they
+    -- will also be brought into scope by the corresponding (ATyCon
+    -- tc).  And we want the latter, because that has the correct
+    -- parent (Trac #10520)
+    is_sub_bndr (AnId f) = case idDetails f of
+                             RecSelId {}  -> True
+                             ClassOpId {} -> True
+                             _            -> False
+    is_sub_bndr _ = False
+
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
 substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
   | isEmptyTvSubst subst = ictxt
diff --git a/testsuite/tests/ghci/scripts/T10520.script b/testsuite/tests/ghci/scripts/T10520.script
new file mode 100644 (file)
index 0000000..d72491c
--- /dev/null
@@ -0,0 +1,3 @@
+:set -XRecordWildCards
+data Foo = Bar { baz :: Integer } deriving Show
+Bar { baz = 42 }
diff --git a/testsuite/tests/ghci/scripts/T10520.stdout b/testsuite/tests/ghci/scripts/T10520.stdout
new file mode 100644 (file)
index 0000000..8fe2823
--- /dev/null
@@ -0,0 +1 @@
+Bar {baz = 42}
index c2c75ec..4094a9e 100755 (executable)
@@ -222,3 +222,4 @@ test('T10322', normal, ghci_script, ['T10322.script'])
 test('T10466', normal, ghci_script, ['T10466.script'])
 test('T10501', normal, ghci_script, ['T10501.script'])
 test('T10508', normal, ghci_script, ['T10508.script'])
+test('T10520', normal, ghci_script, ['T10520.script'])