Skip to content
Sign up
This repository

public / ghc Octocat-spinner-32 mirrored from http://git.haskell.org/ghc.git

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add support for all top-level declarations to GHCi 

  This is work mostly done by Daniel Winograd-Cort during his
  internship at MSR Cambridge, with some further refactoring by me.

This commit adds support to GHCi for most top-level declarations that
can be used in Haskell source files.  Class, data, newtype, type,
instance are all supported, as are Type Family-related declarations.

The current set of declarations are shown by :show bindings.  As with
variable bindings, entities bound by newer declarations shadow earlier
ones.

Tests are in testsuite/tests/ghci/scripts/ghci039--ghci054.
Documentation to follow.
  • Loading branch information...
commit 3db757241ce7fb99c096c30481aefa86bb9855a1 1 parent 9de6f19
Simon Marlow authored

Showing 35 changed files with 1,255 additions and 642 deletions. Show Diff Stats Hide Diff Stats

  1. 2  compiler/basicTypes/DataCon.lhs-boot
  2. 18  compiler/basicTypes/Name.lhs
  3. 4  compiler/basicTypes/Name.lhs-boot
  4. 5  compiler/basicTypes/RdrName.lhs
  5. 66  compiler/deSugar/Desugar.lhs
  6. 2  compiler/ghci/ByteCodeLink.lhs
  7. 25  compiler/ghci/Debugger.hs
  8. 61  compiler/ghci/Linker.lhs
  9. 76  compiler/iface/IfaceEnv.lhs
  10. 32  compiler/main/GHC.hs
  11. 120  compiler/main/HscMain.lhs
  12. 287  compiler/main/HscTypes.lhs
  13. 76  compiler/main/InteractiveEval.hs
  14. 142  compiler/main/TidyPgm.lhs
  15. 12  compiler/prelude/PrelNames.lhs
  16. 37  compiler/rename/RnNames.lhs
  17. 3  compiler/rename/RnSource.lhs
  18. 32  compiler/typecheck/FamInst.lhs
  19. 110  compiler/typecheck/Inst.lhs
  20. 22  compiler/typecheck/TcEnv.lhs
  21. 7  compiler/typecheck/TcInstDcls.lhs
  22. 284  compiler/typecheck/TcRnDriver.lhs
  23. 19  compiler/typecheck/TcRnMonad.lhs
  24. 3  compiler/typecheck/TcRnTypes.lhs
  25. 19  compiler/typecheck/TcTyClsDecls.lhs
  26. 122  compiler/types/FamInstEnv.lhs
  27. 139  compiler/types/InstEnv.lhs
  28. 2  compiler/types/TypeRep.lhs
  29. 12  compiler/utils/Outputable.lhs
  30. 18  compiler/vectorise/Vectorise.hs
  31. 11  compiler/vectorise/Vectorise/Env.hs
  32. 8  compiler/vectorise/Vectorise/Monad.hs
  33. 24  compiler/vectorise/Vectorise/Type/Env.hs
  34. 19  ghc/GhciMonad.hs
  35. 78  ghc/InteractiveUI.hs
2  compiler/basicTypes/DataCon.lhs-boot
View 
@@ -5,4 +5,6 @@ import Name( Name )
5 5 
 data DataCon
6 6 
 dataConName      :: DataCon -> Name
7 7 
 isVanillaDataCon :: DataCon -> Bool
  8 
+instance Eq DataCon
  9 
+instance Ord DataCon
8 10 
 \end{code}
18  compiler/basicTypes/Name.lhs
Source Rendered
View 
@@ -435,17 +435,17 @@ instance OutputableBndr Name where
435 435 
     pprBndr _ name = pprName name
436 436
437 437 
 pprName :: Name -> SDoc
438   
-pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
  438 
+pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})
439 439 
   = getPprStyle $ \ sty ->
440 440 
     case sort of
441   
-      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin
442   
-      External mod  	      -> pprExternal sty uniq mod occ False UserSyntax
  441 
+      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ n True  builtin
  442 
+      External mod            -> pprExternal sty uniq mod occ n False UserSyntax
443 443 
       System   		      -> pprSystem sty uniq occ
444 444 
       Internal    	      -> pprInternal sty uniq occ
445 445 
   where uniq = mkUniqueGrimily (iBox u)
446 446
447   
-pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
448   
-pprExternal sty uniq mod occ is_wired is_builtin
  447 
+pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc
  448 
+pprExternal sty uniq mod occ name is_wired is_builtin
449 449 
   | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
450 450 
 	-- In code style, always qualify
451 451 
 	-- ToDo: maybe we could print all wired-in things unqualified
 
@@ -455,7 +455,7 @@ pprExternal sty uniq mod occ is_wired is_builtin
455 455 
 				      pprNameSpaceBrief (occNameSpace occ),
456 456 
 		 		      pprUnique uniq])
457 457 
   | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax
458   
-  | otherwise		        = pprModulePrefix sty mod occ <> ppr_occ_name occ
  458 
+  | otherwise                   = pprModulePrefix sty mod name <> ppr_occ_name occ
459 459 
   where
460 460 
     pp_mod | opt_SuppressModulePrefixes = empty
461 461 
            | otherwise                  = ppr mod <> dot 
@@ -482,14 +482,14 @@ pprSystem sty uniq occ
482 482 
 				-- so print the unique
483 483
484 484
485   
-pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
  485 
+pprModulePrefix :: PprStyle -> Module -> Name -> SDoc
486 486 
 -- Print the "M." part of a name, based on whether it's in scope or not
487 487 
 -- See Note [Printing original names] in HscTypes
488   
-pprModulePrefix sty mod occ
  488 
+pprModulePrefix sty mod name
489 489 
   | opt_SuppressModulePrefixes = empty
490 490
491 491 
   | otherwise
492   
-  = case qualName sty mod occ of	           -- See Outputable.QualifyName:
  492 
+  = case qualName sty name of              -- See Outputable.QualifyName:
493 493 
       NameQual modname -> ppr modname <> dot       -- Name is in scope
494 494 
       NameNotInScope1  -> ppr mod <> dot           -- Not in scope
495 495 
       NameNotInScope2  -> ppr (modulePackageId mod) <> colon     -- Module not in
4  compiler/basicTypes/Name.lhs-boot
View
... ... 
@@ -1,5 +1,9 @@
1 1 
 \begin{code}
2 2 
 module Name where
3 3
  4 
+import {-# SOURCE #-} Module
  5 
+
4 6 
 data Name
  7 
+
  8 
+nameModule :: Name -> Module
5 9 
 \end{code}
5  compiler/basicTypes/RdrName.lhs
Source Rendered
View 
@@ -66,6 +66,7 @@ import Maybes
66 66 
 import SrcLoc
67 67 
 import FastString
68 68 
 import Outputable
  69 
+import Unique
69 70 
 import Util
70 71 
 import StaticFlags( opt_PprStyle_Debug )
71 72 
 
@@ -247,7 +248,9 @@ instance Outputable RdrName where
247 248 
     ppr (Exact name)   = ppr name
248 249 
     ppr (Unqual occ)   = ppr occ
249 250 
     ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
250   
-    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)
  251 
+    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod name <> ppr occ)
  252 
+       where name = mkExternalName (mkUniqueGrimily 0) mod occ noSrcSpan
  253 
+         -- Note [Outputable Orig RdrName] in HscTypes
251 254
252 255 
 instance OutputableBndr RdrName where
253 256 
     pprBndr _ n
66  compiler/deSugar/Desugar.lhs
Source Rendered
View 
@@ -56,24 +56,26 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
56 56 
 deSugar hsc_env
57 57 
         mod_loc
58 58 
         tcg_env@(TcGblEnv { tcg_mod          = mod,
59   
-			    tcg_src	     = hsc_src,
60   
-		    	    tcg_type_env     = type_env,
61   
-		    	    tcg_imports      = imports,
62   
-		    	    tcg_exports      = exports,
63   
-			    tcg_keep	     = keep_var,
  59 
+                            tcg_src          = hsc_src,
  60 
+                            tcg_type_env     = type_env,
  61 
+                            tcg_imports      = imports,
  62 
+                            tcg_exports      = exports,
  63 
+                            tcg_keep	     = keep_var,
64 64 
                             tcg_th_splice_used = tc_splice_used,
65 65 
                             tcg_rdr_env      = rdr_env,
66   
-		    	    tcg_fix_env      = fix_env,
67   
-		    	    tcg_inst_env     = inst_env,
68   
-		    	    tcg_fam_inst_env = fam_inst_env,
69   
-	    	    	    tcg_warns        = warns,
70   
-	    	    	    tcg_anns         = anns,
71   
-			    tcg_binds        = binds,
72   
-		    	    tcg_imp_specs    = imp_specs,
  66 
+                            tcg_fix_env      = fix_env,
  67 
+                            tcg_inst_env     = inst_env,
  68 
+                            tcg_fam_inst_env = fam_inst_env,
  69 
+                            tcg_warns        = warns,
  70 
+                            tcg_anns         = anns,
  71 
+                            tcg_binds        = binds,
  72 
+                            tcg_imp_specs    = imp_specs,
73 73 
                             tcg_ev_binds     = ev_binds,
74 74 
                             tcg_fords        = fords,
75 75 
                             tcg_rules        = rules,
76 76 
                             tcg_vects        = vects,
  77 
+                            tcg_tcs          = tcs,
  78 
+                            tcg_clss         = clss,
77 79 
                             tcg_insts        = insts,
78 80 
                             tcg_fam_insts    = fam_insts,
79 81 
                             tcg_hpc          = other_hpc_info })
 
@@ -96,8 +98,7 @@ deSugar hsc_env
96 98 
 			 <- if (opt_Hpc
97 99 
 				  || target == HscInterpreted)
98 100 
 			       && (not (isHsBoot hsc_src))
99   
-                              then addCoverageTicksToBinds dflags mod mod_loc
100   
-                                                           (typeEnvTyCons type_env) binds
  101 
+                              then addCoverageTicksToBinds dflags mod mod_loc tcs binds
101 102 
                               else return (binds, hpcInfo, emptyModBreaks)
102 103 
                      initDs hsc_env mod rdr_env type_env $ do
103 104 
                        do { ds_ev_binds <- dsEvBinds ev_binds
 
@@ -151,26 +152,27 @@ deSugar hsc_env
151 152 
         ; used_th <- readIORef tc_splice_used
152 153
153 154 
         ; let mod_guts = ModGuts {
154   
-		mg_module    	= mod,
155   
-		mg_boot	     	= isHsBoot hsc_src,
156   
-		mg_exports   	= exports,
157   
-		mg_deps	     	= deps,
158   
-		mg_used_names   = used_names,
  155 
+                mg_module       = mod,
  156 
+                mg_boot	        = isHsBoot hsc_src,
  157 
+                mg_exports      = exports,
  158 
+                mg_deps	        = deps,
  159 
+                mg_used_names   = used_names,
159 160 
                 mg_used_th      = used_th,
160 161 
                 mg_dir_imps     = imp_mods imports,
161   
-	        mg_rdr_env   	= rdr_env,
162   
-		mg_fix_env   	= fix_env,
163   
-		mg_warns   	= warns,
164   
-		mg_anns      	= anns,
165   
-		mg_types     	= type_env,
166   
-		mg_insts     	= insts,
167   
-		mg_fam_insts 	= fam_insts,
168   
-		mg_inst_env     = inst_env,
169   
-		mg_fam_inst_env = fam_inst_env,
170   
-	        mg_rules     	= ds_rules_for_imps,
171   
-		mg_binds     	= ds_binds,
172   
-		mg_foreign   	= ds_fords,
173   
-		mg_hpc_info  	= ds_hpc_info,
  162 
+                mg_rdr_env      = rdr_env,
  163 
+                mg_fix_env      = fix_env,
  164 
+                mg_warns        = warns,
  165 
+                mg_anns         = anns,
  166 
+                mg_tcs          = tcs,
  167 
+                mg_clss         = clss,
  168 
+                mg_insts        = insts,
  169 
+                mg_fam_insts    = fam_insts,
  170 
+                mg_inst_env     = inst_env,
  171 
+                mg_fam_inst_env = fam_inst_env,
  172 
+                mg_rules        = ds_rules_for_imps,
  173 
+                mg_binds        = ds_binds,
  174 
+                mg_foreign      = ds_fords,
  175 
+                mg_hpc_info     = ds_hpc_info,
174 176 
                 mg_modBreaks    = modBreaks,
175 177 
                 mg_vect_decls   = ds_vects,
176 178 
                 mg_vect_info    = noVectInfo,
2  compiler/ghci/ByteCodeLink.lhs
Source Rendered
View 
@@ -254,7 +254,7 @@ lookupIE ie con_nm
254 254 
 linkFail :: String -> String -> IO a
255 255 
 linkFail who what
256 256 
    = ghcError (ProgramError $
258 258 
 	        , "During interactive linking, GHCi couldn't find the following symbol:"
259 259 
 		, ' ' : ' ' : what
260 260 
 		, "This may be due to you not asking GHCi to load extra object files,"
25  compiler/ghci/Debugger.hs
View 
@@ -87,7 +87,7 @@ pprintClosureCommand bindThings force str = do
87 87 
    tidyTermTyVars :: GhcMonad m => Term -> m Term
88 88 
    tidyTermTyVars t =
89 89 
      withSession $ \hsc_env -> do
90   
-     let env_tvs      = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env)))
  90 
+     let env_tvs      = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
91 91 
          my_tvs       = termTyVars t
92 92 
          tvs          = env_tvs `minusVarSet` my_tvs
93 93 
          tyvarOccName = nameOccName . tyVarName
 
@@ -110,7 +110,7 @@ bindSuspensions t = do
110 110 
       let (names, tys, hvals) = unzip3 stuff
111 111 
       let ids = [ mkVanillaGlobal name ty
112 112 
                 | (name,ty) <- zip names tys]
113   
-          new_ic = extendInteractiveContext ictxt ids
  113 
+          new_ic = extendInteractiveContext ictxt (map AnId ids)
114 114 
       liftIO $ extendLinkEnv (zip names hvals)
115 115 
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
116 116 
       return t'
 
@@ -187,10 +187,8 @@ showTerm term = do
187 187
188 188 
   bindToFreshName hsc_env ty userName = do
189 189 
     name <- newGrimName userName
190   
-    let ictxt    = hsc_IC hsc_env
191   
-        tmp_ids  = ic_tmp_ids ictxt
192   
-        id       = mkVanillaGlobal name ty
193   
-        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
  190 
+    let id       = AnId $ mkVanillaGlobal name ty
  191 
+        new_ic   = extendInteractiveContext (hsc_IC hsc_env) [id]
194 192 
     return (hsc_env {hsc_IC = new_ic }, name)
195 193
196 194 
 --    Create new uniques and give them sequentially numbered names
 
@@ -202,20 +200,19 @@ newGrimName userName  = do
202 200 
         name    = mkInternalName unique occname noSrcSpan
203 201 
     return name
204 202
205   
-pprTypeAndContents :: GhcMonad m => [Id] -> m SDoc
206   
-pprTypeAndContents ids = do
  203 
+pprTypeAndContents :: GhcMonad m => Id -> m SDoc
  204 
+pprTypeAndContents id = do
207 205 
   dflags  <- GHC.getSessionDynFlags
208 206 
   let pefas     = dopt Opt_PrintExplicitForalls dflags
209 207 
       pcontents = dopt Opt_PrintBindContents dflags
  208 
+      pprdId    = (pprTyThing pefas . AnId) id
210 209 
   if pcontents
211 210 
     then do
212 211 
       let depthBound = 100
213   
-      terms      <- mapM (GHC.obtainTermFromId depthBound False) ids
214   
-      docs_terms <- mapM showTerm terms
215   
-      return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
216   
-                             (map (pprTyThing pefas . AnId) ids)
217   
-                             docs_terms
218   
-    else return $  vcat $ map (pprTyThing pefas . AnId) ids
  212 
+      term      <- GHC.obtainTermFromId depthBound False id
  213 
+      docs_term <- showTerm term
  214 
+      return $ pprdId <+> equals <+> docs_term
  215 
+    else return pprdId
219 216
220 217 
 --------------------------------------------------------------
221 218 
 -- Utils
61  compiler/ghci/Linker.lhs
Source Rendered
View 
@@ -12,7 +12,7 @@
12 12 
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
13 13
14 14 
 module Linker ( HValue, getHValue, showLinkerState,
15   
-		linkExpr, unload, withExtendedLinkEnv,
  15 
+		linkExpr, linkDecls, unload, withExtendedLinkEnv,
16 16 
                 extendLinkEnv, deleteFromLinkEnv,
17 17 
                 extendLoadedPkgs,
18 18 
 		linkPackages,initDynLinker,linkModule,
 
@@ -52,6 +52,7 @@ import UniqSet
52 52 
 import FastString
53 53 
 import Config
54 54 
 import SysTools
  55 
+import PrelNames
55 56
56 57 
 -- Standard libraries
57 58 
 import Control.Monad
 
@@ -427,9 +428,9 @@ linkExpr hsc_env span root_ul_bco
427 428
428 429 
      needed_mods :: [Module]
429 430 
      needed_mods = [ nameModule n | n <- free_names,
430   
-				    isExternalName n,	 	-- Names from other modules
431   
-				    not (isWiredInName n)	-- Exclude wired-in names
432   
-		   ]						-- (see note below)
  431 
+                     isExternalName n,      -- Names from other modules
  432 
+                     not (isWiredInName n)  -- Exclude wired-in names
  433 
+                   ]                        -- (see note below)
433 434 
 	-- Exclude wired-in names because we may not have read
434 435 
 	-- their interface files, so getLinkDeps will fail
435 436 
 	-- All wired-in names are in the base package, which we link
 
@@ -476,7 +477,9 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
476 477 
 -- Find all the packages and linkables that a set of modules depends on
477 478 
  = do {
478 479 
 	-- 1.  Find the dependent home-pkg-modules/packages from each iface
479   
-        (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
  480 
+        -- (omitting iINTERACTIVE, which is already linked)
  481 
+        (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods)
  482 
+                                        emptyUniqSet emptyUniqSet;
480 483
481 484 
 	let {
482 485 
 	-- 2.  Exclude ones already linked
 
@@ -488,7 +491,6 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
488 491 
                                 (objs_loaded pls ++ bcos_loaded pls)
489 492 
 	} ;
490 493
491   
---        putStrLn (showSDoc (ppr mods_s)) ;
492 494 
 	-- 3.  For each dependent module, find its linkable
493 495 
 	--     This will either be in the HPT or (in the case of one-shot
494 496 
 	--     compilation) we may need to use maybe_getFileLinkable
 
@@ -594,6 +596,53 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
594 596 
 	    adjust_ul _ _ = panic "adjust_ul"
595 597 
 \end{code}
596 598
  599 
+
  600 
+%************************************************************************
  601 
+%*									*
  602 
+              Loading a Decls statement
  603 
+%*									*
  604 
+%************************************************************************
  605 
+\begin{code}
  606 
+linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
  607 
+linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
  608 
+    -- Initialise the linker (if it's not been done already)
  609 
+    let dflags = hsc_dflags hsc_env
  610 
+    initDynLinker dflags
  611 
+
  612 
+    -- Take lock for the actual work.
  613 
+    modifyPLS $ \pls0 -> do
  614 
+
  615 
+    -- Link the packages and modules required
  616 
+    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
  617 
+    if failed ok
  618 
+      then ghcError (ProgramError "")
  619 
+      else do
  620 
+
  621 
+    -- Link the expression itself
  622 
+    let ie = plusNameEnv (itbl_env pls) itblEnv
  623 
+        ce = closure_env pls
  624 
+
  625 
+    -- Link the necessary packages and linkables
  626 
+    (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs
  627 
+    let pls2 = pls { closure_env = final_gce,
  628 
+                     itbl_env    = ie }
  629 
+    return (pls2, ()) --hvals)
  630 
+  where
  631 
+    free_names =  concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs
  632 
+
  633 
+    needed_mods :: [Module]
  634 
+    needed_mods = [ nameModule n | n <- free_names,
  635 
+                    isExternalName n,       -- Names from other modules
  636 
+                    not (isWiredInName n)   -- Exclude wired-in names
  637 
+                  ]                         -- (see note below)
  638 
+    -- Exclude wired-in names because we may not have read
  639 
+    -- their interface files, so getLinkDeps will fail
  640 
+    -- All wired-in names are in the base package, which we link
  641 
+    -- by default, so we can safely ignore them here.
  642 
+\end{code}
  643 
+
  644 
+
  645 
+
597 646 
 %************************************************************************
598 647 
 %*									*
599 648 
               Loading a single module
76  compiler/iface/IfaceEnv.lhs
Source Rendered
View 
@@ -71,39 +71,49 @@ allocateGlobalBinder
71 71 
   -> (NameCache, Name)
72 72 
 allocateGlobalBinder name_supply mod occ loc
73 73 
   = case lookupOrigNameCache (nsNames name_supply) mod occ of
74   
-	-- A hit in the cache!  We are at the binding site of the name.
75   
-	-- This is the moment when we know the SrcLoc
76   
-	-- of the Name, so we set this field in the Name we return.
77   
-	--
78   
-	-- Then (bogus) multiple bindings of the same Name
79   
-	-- get different SrcLocs can can be reported as such.
80   
-	--
81   
-	-- Possible other reason: it might be in the cache because we
82   
-	-- 	encountered an occurrence before the binding site for an
83   
-	--	implicitly-imported Name.  Perhaps the current SrcLoc is
84   
-	--	better... but not really: it'll still just say 'imported'
85   
-	--
86   
-	-- IMPORTANT: Don't mess with wired-in names.
87   
-	-- 	      Their wired-in-ness is in their NameSort
88   
-	--	      and their Module is correct.
89   
-
90   
-	Just name | isWiredInName name -> (name_supply, name)
91   
-		  | otherwise -> (new_name_supply, name')
92   
-		  where
93   
-		    uniq      = nameUnique name
94   
-		    name'     = mkExternalName uniq mod occ loc
95   
-		    new_cache = extendNameCache (nsNames name_supply) mod occ name'
96   
-		    new_name_supply = name_supply {nsNames = new_cache}
97   
-
98   
-	-- Miss in the cache!
99   
-	-- Build a completely new Name, and put it in the cache
100   
-	Nothing -> (new_name_supply, name)
101   
-		where
102   
-		  (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
103   
-		  name            = mkExternalName uniq mod occ loc
104   
-		  new_cache       = extendNameCache (nsNames name_supply) mod occ name
105   
-		  new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
106   
-
  74 
+        -- A hit in the cache!  We are at the binding site of the name.
  75 
+        -- This is the moment when we know the SrcLoc
  76 
+        -- of the Name, so we set this field in the Name we return.
  77 
+        --
  78 
+        -- Then (bogus) multiple bindings of the same Name
  79 
+        -- get different SrcLocs can can be reported as such.
  80 
+        --
  81 
+        -- Possible other reason: it might be in the cache because we
  82 
+        -- 	encountered an occurrence before the binding site for an
  83 
+        --	implicitly-imported Name.  Perhaps the current SrcLoc is
  84 
+        --	better... but not really: it'll still just say 'imported'
  85 
+        --
  86 
+        -- IMPORTANT: Don't mess with wired-in names.
  87 
+        -- 	      Their wired-in-ness is in their NameSort
  88 
+        --	      and their Module is correct.
  89 
+
  90 
+        Just name | isWiredInName name -> (name_supply, name)
  91 
+                  | mod /= iNTERACTIVE -> (new_name_supply, name')
  92 
+                     -- Note [interactive name cache]
  93 
+                  where
  94 
+                    uniq            = nameUnique name
  95 
+                    name'           = mkExternalName uniq mod occ loc
  96 
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'
  97 
+                    new_name_supply = name_supply {nsNames = new_cache}
  98 
+
  99 
+        -- Miss in the cache!
  100 
+        -- Build a completely new Name, and put it in the cache
  101 
+        _ -> (new_name_supply, name)
  102 
+                  where
  103 
+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
  104 
+                    name            = mkExternalName uniq mod occ loc
  105 
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
  106 
+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
  107 
+
  108 
+{- Note [interactive name cache]
  109 
+
  110 
+In GHCi we always create Names with the same Module, ":Interactive".
  111 
+However, we want to be able to shadow older declarations with newer
  112 
+ones, and we don't want the Name cache giving us back the same Unique
  113 
+for the new Name as for the old, hence this special case.
  114 
+
  115 
+See also Note [Outputable Orig RdrName] in HscTypes.
  116 
+-}
107 117
108 118 
 newImplicitBinder :: Name			-- Base name
109 119 
 	          -> (OccName -> OccName) 	-- Occurrence name modifier
32  compiler/main/GHC.hs
View 
@@ -80,7 +80,7 @@ module GHC (
80 80 
 	PrintUnqualified, alwaysQualify,
81 81
82 82 
 	-- * Interactive evaluation
83   
-	getBindings, getPrintUnqual,
  83 
+	getBindings, getInsts, getPrintUnqual,
84 84 
         findModule,
85 85 
         lookupModule,
86 86 
 #ifdef GHCI
 
@@ -94,7 +94,7 @@ module GHC (
94 94 
 	typeKind,
95 95 
 	parseName,
96 96 
 	RunResult(..),
97   
-	runStmt, runStmtWithLocation,
  97 
+	runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
98 98 
         parseImportDecl, SingleStep(..),
99 99 
         resume,
100 100 
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
 
@@ -166,7 +166,9 @@ module GHC (
166 166
167 167 
 	-- ** Instances
168 168 
 	Instance,
169   
-	instanceDFunId, pprInstance, pprInstanceHdr,
  169 
+	instanceDFunId,
  170 
+        pprInstance, pprInstanceHdr,
  171 
+        pprFamInst, pprFamInstHdr,
170 172
171 173 
 	-- ** Types and Kinds
172 174 
 	Type, splitForAllTys, funResultTy, 
@@ -264,8 +266,9 @@ import Class
264 266 
 import DataCon
265 267 
 import Name             hiding ( varName )
266 268 
 import InstEnv
  269 
+import FamInstEnv
267 270 
 import SrcLoc
268   
-import CoreSyn          ( CoreBind )
  271 
+import CoreSyn
269 272 
 import TidyPgm
270 273 
 import DriverPhases     ( Phase(..), isHaskellSrcFilename )
271 274 
 import Finder
 
@@ -864,11 +867,15 @@ compileCore simplify fn = do
864 867 
         -- we just have a ModGuts.
865 868 
         gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
866 869 
         gutsToCoreModule (Left (cg, md))  = CoreModule {
867   
-          cm_module = cg_module cg,    cm_types = md_types md,
  870 
+          cm_module = cg_module cg,
  871 
+          cm_types = md_types md,
868 872 
           cm_binds = cg_binds cg
869 873 
         }
870 874 
         gutsToCoreModule (Right mg) = CoreModule {
871   
-          cm_module  = mg_module mg,                   cm_types   = mg_types mg,
  875 
+          cm_module  = mg_module mg,
  876 
+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
  877 
+                                           (mg_tcs mg) (mg_clss mg)
  878 
+                                           (mg_fam_insts mg),
872 879 
           cm_binds   = mg_binds mg
873 880 
          }
874 881 
 
@@ -899,13 +906,12 @@ isLoaded m = withSession $ \hsc_env ->
899 906 
 -- | Return the bindings for the current interactive session.
900 907 
 getBindings :: GhcMonad m => m [TyThing]
901 908 
 getBindings = withSession $ \hsc_env ->
902   
-   -- we have to implement the shadowing behaviour of ic_tmp_ids here
903   
-   -- (see InteractiveContext) and the quickest way is to use an OccEnv.
904   
-   let
905   
-       occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
906   
-                          | id <- ic_tmp_ids (hsc_IC hsc_env) ]
907   
-   in
908   
-   return (occEnvElts occ_env)
  909 
+    return $ icInScopeTTs $ hsc_IC hsc_env
  910 
+
  911 
+-- | Return the instances for the current interactive session.
  912 
+getInsts :: GhcMonad m => m ([Instance], [FamInst])
  913 
+getInsts = withSession $ \hsc_env ->
  914 
+    return $ ic_instances (hsc_IC hsc_env)
909 915
910 916 
 getPrintUnqual :: GhcMonad m => m PrintUnqualified
911 917 
 getPrintUnqual = withSession $ \hsc_env ->
120  compiler/main/HscMain.lhs
Source Rendered
View 
@@ -63,6 +63,7 @@ module HscMain
63 63 
     , hscRnImportDecls
64 64 
     , hscTcRnLookupRdrName
65 65 
     , hscStmt, hscStmtWithLocation
  66 
+    , hscDecls, hscDeclsWithLocation
66 67 
     , hscTcExpr, hscImport, hscKcType
67 68 
     , hscCompileCoreExpr
68 69 
 #endif
 
@@ -71,13 +72,11 @@ module HscMain
71 72
72 73 
 #ifdef GHCI
73 74 
 import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
74   
-import Linker		( HValue, linkExpr )
  75 
+import Linker
75 76 
 import CoreTidy		( tidyExpr )
76 77 
 import Type		( Type )
77   
-import TcType           ( tyVarsOfTypes )
78   
-import PrelNames	( iNTERACTIVE )
  78 
+import PrelNames
79 79 
 import {- Kind parts of -} Type		( Kind )
80   
-import Id      	     	( idType )
81 80 
 import CoreLint		( lintUnfolding )
82 81 
 import DsMeta		( templateHaskellNames )
83 82 
 import VarSet
 
@@ -85,7 +84,7 @@ import VarEnv		( emptyTidyEnv )
85 84 
 import Panic
86 85 
 #endif
87 86
88   
-import Id		( Id )
  87 
+import Id
89 88 
 import Module
90 89 
 import Packages
91 90 
 import RdrName
 
@@ -100,7 +99,7 @@ import TcIface		( typecheckIface )
100 99 
 import TcRnMonad
101 100 
 import IfaceEnv		( initNameCache )
102 101 
 import LoadIface	( ifaceStats, initExternalPackageState )
103   
-import PrelInfo		( wiredInThings, basicKnownKeyNames )
  102 
+import PrelInfo
104 103 
 import MkIface
105 104 
 import Desugar
106 105 
 import SimplCore
 
@@ -111,8 +110,9 @@ import qualified StgCmm	( codeGen )
111 110 
 import StgSyn
112 111 
 import CostCentre
113 112 
 import ProfInit
114   
-import TyCon            ( TyCon, isDataTyCon )
115   
-import Name		( Name, NamedThing(..) )
  113 
+import TyCon
  114 
+import Class
  115 
+import Name
116 116 
 import SimplStg		( stg2stg )
117 117 
 import CodeGen		( codeGen )
118 118 
 import OldCmm as Old    ( CmmGroup )
 
@@ -127,7 +127,7 @@ import CodeOutput
127 127 
 import NameEnv          ( emptyNameEnv )
128 128 
 import NameSet          ( emptyNameSet )
129 129 
 import InstEnv
130   
-import FamInstEnv       ( emptyFamInstEnv )
  130 
+import FamInstEnv
131 131 
 import Fingerprint      ( Fingerprint )
132 132
133 133 
 import DynFlags
 
@@ -1287,8 +1287,8 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
1287 1287 
                             tcRnStmt hsc_env icontext parsed_stmt
1288 1288 
 	    -- Desugar it
1289 1289 
 	let rdr_env  = ic_rn_gbl_env icontext
1290   
-	    type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
1291   
-	ds_expr <- ioMsgMaybe $
  1290 
+            type_env = mkTypeEnvWithImplicits (ic_tythings icontext)
  1291 
+        ds_expr <- ioMsgMaybe $
1292 1292 
                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1293 1293 
         handleWarnings
1294 1294 
 
@@ -1297,7 +1297,90 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
1297 1297 
         hsc_env <- getHscEnv
1298 1298 
 	hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1299 1299
1300   
-	return $ Just (ids, hval)
  1300 
+        return $ Just (ids, hval)
  1301 
+
  1302 
+hscDecls                -- Compile a decls
  1303 
+  :: HscEnv
  1304 
+  -> String             -- The statement
  1305 
+  -> IO ([TyThing], InteractiveContext)
  1306 
+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
  1307 
+
  1308 
+hscDeclsWithLocation    -- Compile a decls
  1309 
+  :: HscEnv
  1310 
+  -> String             -- The statement
  1311 
+  -> String             -- the source
  1312 
+  -> Int                -- ^ starting line
  1313 
+  -> IO ([TyThing], InteractiveContext)
  1314 
+hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
  1315 
+    L _ (HsModule{hsmodDecls=decls}) <-
  1316 
+        hscParseThingWithLocation source linenumber parseModule str
  1317 
+
  1318 
+    -- Rename and typecheck it
  1319 
+    let icontext = hsc_IC hsc_env
  1320 
+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
  1321 
+
  1322 
+    -- Grab the new instances
  1323 
+    -- We grab the whole environment because of the overlapping that may have
  1324 
+    -- been done.  See the notes at the definition of InteractiveContext
  1325 
+    -- (ic_instances) for more details.
  1326 
+    let finsts  = famInstEnvElts $ tcg_fam_inst_env tc_gblenv
  1327 
+        insts   = instEnvElts $ tcg_inst_env tc_gblenv
  1328 
+
  1329 
+	-- Desugar it
  1330 
+    -- We use a basically null location for iNTERACTIVE
  1331 
+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
  1332 
+                                      ml_hi_file   = undefined,
  1333 
+                                      ml_obj_file  = undefined}
  1334 
+    ds_result <- ioMsgMaybe $ deSugar hsc_env iNTERACTIVELoc tc_gblenv
  1335 
+    handleWarnings
  1336 
+
  1337 
+        -- Simplify
  1338 
+    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
  1339 
+
  1340 
+        -- Tidy
  1341 
+    (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
  1342 
+
  1343 
+    let dflags = hsc_dflags hsc_env
  1344 
+        CgGuts{ cg_binds     = core_binds,
  1345 
+                cg_tycons    = tycons,
  1346 
+                cg_modBreaks = mod_breaks } = tidy_cg
  1347 
+        data_tycons = filter isDataTyCon tycons
  1348 
+
  1349 
+	-------------------
  1350 
+	-- PREPARE FOR CODE GENERATION
  1351 
+	-- Do saturation and convert to A-normal form
  1352 
+    prepd_binds <- {-# SCC "CorePrep" #-}
  1353 
+                    liftIO $ corePrepPgm dflags core_binds data_tycons
  1354 
+
  1355 
+    -----------------  Generate byte code ------------------
  1356 
+    cbc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks
  1357 
+
  1358 
+    let src_span = srcLocSpan interactiveSrcLoc
  1359 
+    hsc_env <- getHscEnv
  1360 
+    liftIO $ linkDecls hsc_env src_span cbc
  1361 
+
  1362 
+    -- pprTrace "te" (ppr te) $ return ()
  1363 
+
  1364 
+    let
  1365 
+        tcs     = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg
  1366 
+        clss    = mg_clss simpl_mg
  1367 
+        tythings = map ATyCon tcs ++ map (ATyCon . classTyCon) clss
  1368 
+        sys_vars = filter (isExternalName . idName) $
  1369 
+                      bindersOfBinds (cg_binds tidy_cg)
  1370 
+                   -- we only need to keep around the external bindings
  1371 
+                   -- (as decided by TidyPgm), since those are the only ones
  1372 
+                   -- that might be referenced elsewhere.
  1373 
+
  1374 
+    -- pprTrace "new tycons"  (ppr tcs) $ return ()
  1375 
+    -- pprTrace "new classes" (ppr clss) $ return ()
  1376 
+    -- pprTrace "new sys Ids" (ppr sys_vars) $ return ()
  1377 
+
  1378 
+    let ictxt1 = extendInteractiveContext icontext tythings
  1379 
+        ictxt = ictxt1 {
  1380 
+            ic_sys_vars   = sys_vars ++ ic_sys_vars ictxt1,
  1381 
+            ic_instances  = (insts, finsts) }
  1382 
+
  1383 
+    return $ (tythings, ictxt)
1301 1384
1302 1385 
 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1303 1386 
 hscImport hsc_env str = runHsc hsc_env $ do
 
@@ -1311,7 +1394,7 @@ hscImport hsc_env str = runHsc hsc_env $ do
1311 1394
1312 1395 
 hscTcExpr	-- Typecheck an expression (but don't run it)
1313 1396 
   :: HscEnv
1314   
-  -> String			-- The expression
  1397 
+  -> String                     -- The expression
1315 1398 
   -> IO Type
1316 1399
1317 1400 
 hscTcExpr hsc_env expr = runHsc hsc_env $ do
 
@@ -1326,7 +1409,7 @@ hscTcExpr hsc_env expr = runHsc hsc_env $ do
1326 1409 
 -- | Find the kind of a type
1327 1410 
 hscKcType
1328 1411 
   :: HscEnv
1329   
-  -> String			-- ^ The type
  1412 
+  -> String                     -- ^ The type
1330 1413 
   -> IO Kind
1331 1414
1332 1415 
 hscKcType hsc_env str = runHsc hsc_env $ do
 
@@ -1414,7 +1497,8 @@ mkModGuts mod binds = ModGuts {
1414 1497 
   mg_used_th = False,
1415 1498 
   mg_rdr_env = emptyGlobalRdrEnv,
1416 1499 
   mg_fix_env = emptyFixityEnv,
1417   
-  mg_types = emptyTypeEnv,
  1500 
+  mg_tcs   = [],
  1501 
+  mg_clss  = [],
1418 1502 
   mg_insts = [],
1419 1503 
   mg_fam_insts = [],
1420 1504 
   mg_rules = [],
 
@@ -1463,9 +1547,11 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
1463 1547 
   	-- ToDo: improve SrcLoc
1464 1548 
     when lint_on $
1465 1549 
        let ictxt = hsc_IC hsc_env
1466   
-           tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
  1550 
+           te     = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
  1551 
+           tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
  1552 
+           vars   = typeEnvIds te
1467 1553 
        in
1468   
-           case lintUnfolding noSrcLoc tyvars prepd_expr of
  1554 
+           case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
1469 1555 
   	      Just err -> pprPanic "hscCompileCoreExpr" err
1470 1556 
   	      Nothing  -> return ()
1471 1557
287  compiler/main/HscTypes.lhs
Source Rendered
View 
@@ -41,10 +41,10 @@ module HscTypes (
41 41 
         prepareAnnotations,
42 42
43 43 
         -- * Interactive context
44   
-	InteractiveContext(..), emptyInteractiveContext,
45   
-        InteractiveImport(..),
46   
-	icPrintUnqual, extendInteractiveContext,
47   
-        substInteractiveContext,
  44 
+        InteractiveContext(..), emptyInteractiveContext,
  45 
+        icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv,
  46 
+        extendInteractiveContext, substInteractiveContext,
  47 
+        InteractiveImport(..),
48 48 
         mkPrintUnqualified, pprModulePrefix,
49 49
50 50 
 	-- * Interfaces
 
@@ -55,15 +55,17 @@ module HscTypes (
55 55 
 	FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
56 56
57 57 
         -- * TyThings and type environments
58   
-	TyThing(..),
  58 
+        TyThing(..),  tyThingAvailInfo,
59 59 
 	tyThingTyCon, tyThingDataCon,
60   
-        tyThingId, tyThingCoAxiom, tyThingParent_maybe,
61   
-	implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
  60 
+        tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars,
  61 
+        implicitTyThings, implicitTyConThings, implicitClassThings,
  62 
+        isImplicitTyThing,
62 63
63 64 
 	TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
  65 
+        typeEnvFromEntities, mkTypeEnvWithImplicits,
64 66 
 	extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
65 67 
 	typeEnvElts, typeEnvTyCons, typeEnvIds,
66   
-	typeEnvDataCons, typeEnvCoAxioms,
  68 
+        typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
67 69
68 70 
         -- * MonadThings
69 71 
         MonadThings(..),
 
@@ -73,8 +75,8 @@ module HscTypes (
73 75 
 	Dependencies(..), noDependencies,
74 76 
 	NameCache(..), OrigNameCache, OrigIParamCache,
75 77 
 	Avails, availsToNameSet, availsToNameEnv, availName, availNames,
76   
-	AvailInfo(..),
77   
-	IfaceExport, stableAvailCmp,
  78 
+        AvailInfo(..), gresFromAvails, gresFromAvail,
  79 
+        IfaceExport, stableAvailCmp,
78 80
79 81 
 	-- * Warnings
80 82 
 	Warnings(..), WarningTxt(..), plusWarns,
 
@@ -118,7 +120,7 @@ import NameEnv
118 120 
 import NameSet
119 121 
 import Module
120 122 
 import InstEnv          ( InstEnv, Instance )
121   
-import FamInstEnv       ( FamInstEnv, FamInst )
  123 
+import FamInstEnv
122 124 
 import Rules            ( RuleBase )
123 125 
 import CoreSyn          ( CoreBind )
124 126 
 import VarEnv
 
@@ -129,23 +131,24 @@ import IdInfo		( IdDetails(..) )
129 131 
 import Type
130 132
131 133 
 import Annotations
132   
-import Class		( Class, classAllSelIds, classATs, classTyCon )
  134 
+import Class
133 135 
 import TyCon
134   
-import DataCon		( DataCon, dataConImplicitIds, dataConWrapId, dataConTyCon )
  136 
+import DataCon
135 137 
 import PrelNames	( gHC_PRIM )
136 138 
 import Packages hiding ( Version(..) )
137 139 
 import DynFlags
138   
-import DriverPhases	( HscSource(..), isHsBoot, hscSourceString, Phase )
139   
-import BasicTypes	( IPName, defaultFixity, WarningTxt(..) )
  140 
+import DriverPhases
  141 
+import BasicTypes
140 142 
 import OptimizationFuel	( OptFuelState )
141 143 
 import IfaceSyn
142 144 
 import CoreSyn		( CoreRule, CoreVect )
143   
-import Maybes		( orElse, expectJust, catMaybes )
  145 
+import Maybes
144 146 
 import Outputable
145 147 
 import BreakArray
146 148 
 import SrcLoc
147   
-import UniqFM		( lookupUFM, eltsUFM, emptyUFM )
148   
-import UniqSupply	( UniqSupply )
  149 
+import Unique
  150 
+import UniqFM
  151 
+import UniqSupply
149 152 
 import FastString
150 153 
 import StringBuffer	( StringBuffer )
151 154 
 import Fingerprint
 
@@ -159,7 +162,6 @@ import System.Time	( ClockTime )
159 162 
 import Data.IORef
160 163 
 import Data.Array       ( Array, array )
161 164 
 import Data.Map         ( Map )
162   
-import Data.List
163 165 
 import Data.Word
164 166 
 import Control.Monad    ( mplus, guard, liftM, when )
165 167 
 import Exception
 
@@ -747,7 +749,8 @@ data ModGuts
747 749 
 	-- These fields all describe the things **declared in this module**
748 750 
 	mg_fix_env   :: !FixityEnv,	 -- ^ Fixities declared in this module
749 751 
 	                                 -- TODO: I'm unconvinced this is actually used anywhere
750   
-	mg_types     :: !TypeEnv,        -- ^ Types declared in this module
  752 
+        mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
  753 
+        mg_clss      :: ![Class],        -- ^ Classes declared in this module
751 754 
 	mg_insts     :: ![Instance],	 -- ^ Class instances declared in this module
752 755 
 	mg_fam_insts :: ![FamInst],	 -- ^ Family instances declared in this module
753 756 
         mg_rules     :: ![CoreRule],	 -- ^ Before the core pipeline starts, contains 
@@ -895,70 +898,130 @@ data InteractiveContext
895 898 
              -- ^ The GHCi context is extended with these imports
896 899
897 900 
          ic_rn_gbl_env :: GlobalRdrEnv,
898   
-             -- ^ The contexts' cached 'GlobalRdrEnv', built by
899   
-             -- 'InteractiveEval.setContext'
  901 
+             -- ^ The cached 'GlobalRdrEnv', built by
  902 
+             -- 'InteractiveEval.setContext' and updated regularly
900 903
901   
-         ic_tmp_ids :: [Id],
902   
-             -- ^ Names bound during interaction with the user.  Later
903   
-             -- Ids shadow earlier ones with the same OccName
904   
-             -- Expressions are typed with these Ids in the envt For
905   
-             -- runtime-debugging, these Ids may have free TcTyVars of
906   
-             -- RuntimUnkSkol flavour, but no free TyVars (because the
907   
-             -- typechecker doesn't expect that)
  904 
+         ic_tythings :: [TyThing],
  905 
+             -- ^ TyThings defined by the user, in reverse order of
  906 
+             -- definition.
  907 
+
  908 
+         ic_sys_vars  :: [Id],
  909 
+             -- ^ Variables defined automatically by the system (e.g.
  910 
+             -- record field selectors).  See Notes [ic_sys_vars]
  911 
+
  912 
+         ic_instances :: ([Instance], [FamInst]),
  913 
+             -- ^ All instances and family instances created during
  914 
+             -- this session.  These are grabbed en masse after each
  915 
+             -- update to be sure that proper overlapping is retained.
  916 
+             -- That is, rather than re-check the overlapping each
  917 
+             -- time we update the context, we just take the results
  918 
+             -- from the instance code that already does that.
908 919
909 920 
 #ifdef GHCI
910   
-         ic_resume :: [Resume],
  921 
+          ic_resume :: [Resume],
911 922 
              -- ^ The stack of breakpoint contexts
912 923 
 #endif
913 924
914   
-         ic_cwd :: Maybe FilePath
  925 
+          ic_cwd :: Maybe FilePath
915 926 
              -- virtual CWD of the program
916 927 
     }
917 928
918   
-data InteractiveImport
919   
-  = IIDecl (ImportDecl RdrName)	-- Bring the exports of a particular module
920   
-    	   	       		-- (filtered by an import decl) into scope
  929 
+{-
  930 
+Note [ic_sys_vars]
921 931
922   
-  | IIModule Module	-- Bring into scope the entire top-level envt of
923   
-    	     		-- of this module, including the things imported
924   
-			-- into it.
925   
-
  932 
+This list constains any Ids that arise from TyCons, Classes or
  933 
+instances defined interactively, but that are not given by
  934 
+'implicitTyThings'.  This includes record selectors, default methods,
  935 
+and dfuns.
  936 
+
  937 
+We *could* get rid of this list and generate these Ids from
  938 
+ic_tythings:
  939 
+
  940 
+   - dfuns come from Instances
  941 
+   - record selectors from TyCons
  942 
+   - default methods from Classes
  943 
+
  944 
+For record selectors the TyCon gives the Name, but in order to make an
  945 
+Id we would have to construct the type ourselves.  Similarly for
  946 
+default methods.  So for now we collect the Ids after tidying (see
  947 
+hscDeclsWithLocation) and save them in ic_sys_vars.
  948 
+-}
  949 
+
  950 
+-- | Constructs an empty InteractiveContext.
926 951 
 emptyInteractiveContext :: InteractiveContext
927   
-emptyInteractiveContext
928   
-  = InteractiveContext { ic_imports = [],
929   
-			 ic_rn_gbl_env = emptyGlobalRdrEnv,
930   
-			 ic_tmp_ids = []
  952 
+emptyInteractiveContext = InteractiveContext {
  953 
+    ic_imports      = [],
  954 
+    ic_rn_gbl_env   = emptyGlobalRdrEnv,
  955 
+    ic_tythings     = [],
  956 
+    ic_sys_vars     = [],
  957 
+    ic_instances    = ([],[]),
931 958 
 #ifdef GHCI
932   
-                         , ic_resume = []
  959 
+    ic_resume       = [],
933 960 
 #endif
934   
-                         , ic_cwd = Nothing
935   
-                       }
936   
-
937   
-icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
938   
-icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt)
  961 
+    ic_cwd          = Nothing }
939 962
  963 
+-- | This function returns the list of visible TyThings (useful for
  964 
+-- e.g. showBindings)
  965 
+icInScopeTTs :: InteractiveContext -> [TyThing]
  966 
+icInScopeTTs = ic_tythings
940 967
  968 
+-- | Get the PrintUnqualified function based on the flags and this InteractiveContext
  969 
+icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
  970 
+icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =
  971 
+    mkPrintUnqualified dflags grenv
  972 
+
  973 
+-- | This function is called with new TyThings recently defined to update the
  974 
+-- InteractiveContext to include them.  Ids are easily removed when shadowed,
  975 
+-- but Classes and TyCons are not.  Some work could be done to determine
  976 
+-- whether they are entirely shadowed, but as you could still have references
  977 
+-- to them (e.g. instances for classes or values of the type for TyCons), it's
  978 
+-- not clear whether removing them is even the appropriate behavior.
941 979 
 extendInteractiveContext
942 980 
         :: InteractiveContext
943   
-        -> [Id]
  981 
+        -> [TyThing]
944 982 
         -> InteractiveContext
945   
-extendInteractiveContext ictxt ids
946   
-  = ictxt { ic_tmp_ids =  snub ((ic_tmp_ids ictxt \\ ids) ++ ids)
947   
-                          -- NB. must be this way around, because we want
948   
-                          -- new ids to shadow existing bindings.
  983 
+extendInteractiveContext ictxt new_tythings
  984 
+  = ictxt { ic_tythings = new_tythings ++ old_tythings
  985 
+          , ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt
949 986 
           }
950   
-    where snub = map head . group . sort
  987 
+  where
  988 
+    old_tythings = filter (not . shadowed) (ic_tythings ictxt)
  989 
+
  990 
+    shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id
  991 
+    shadowed _ = False
  992 
+
  993 
+    new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
  994 
+
  995 
+    -- XXX should not add Ids to the gbl env here
  996 
+
  997 
+-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list
  998 
+-- shadowing later ones, and shadowing existing entries in the
  999 
+-- GlobalRdrEnv.
  1000 
+icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
  1001 
+icPlusGblRdrEnv tythings env = extendOccEnvList env list
  1002 
+  where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
  1003 
+        list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
951 1004
952 1005 
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
953 1006 
 substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
954   
-substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst
955   
-  = ictxt { ic_tmp_ids = map subst_ty ids }
  1007 
+substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
  1008 
+  = ictxt { ic_tythings = map subst_ty tts }
956 1009 
   where
957   
-   subst_ty id = id `setIdType` substTy subst (idType id)
  1010 
+   subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
  1011 
+   subst_ty tt = tt
  1012 
+
  1013 
+data InteractiveImport
  1014 
+  = IIDecl (ImportDecl RdrName)	-- Bring the exports of a particular module
  1015 
+                                -- (filtered by an import decl) into scope
  1016 
+
  1017 
+  | IIModule Module	-- Bring into scope the entire top-level envt of
  1018 
+                    -- of this module, including the things imported
  1019 
+                    -- into it.
958 1020
959 1021 
 instance Outputable InteractiveImport where
960 1022 
   ppr (IIModule m) = char '*' <> ppr m
961 1023 
   ppr (IIDecl d)   = ppr d
  1024 
+
962 1025 
 \end{code}
963 1026
964 1027 
 %************************************************************************
 
@@ -1003,7 +1066,7 @@ the (ppr mod) of case (3), in Name.pprModulePrefix
1003 1066 
 mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
1004 1067 
 mkPrintUnqualified dflags env = (qual_name, qual_mod)
1005 1068 
   where
1006   
-  qual_name mod occ	-- The (mod,occ) pair is the original name of the thing
  1069 
+  qual_name name
1007 1070 
         | [gre] <- unqual_gres, right_name gre = NameUnqual
1008 1071 
 		-- If there's a unique entity that's in scope unqualified with 'occ'
1009 1072 
 		-- AND that entity is the right one, then we can use the unqualified name
 
@@ -1017,7 +1080,15 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
1017 1080
1018 1081 
 	| otherwise = panic "mkPrintUnqualified"
1019 1082 
       where
1020   
-	right_name gre = nameModule_maybe (gre_name gre) == Just mod
  1083 
+        mod = nameModule name
  1084 
+        occ = nameOccName name
  1085 
+
  1086 
+        is_rdr_orig = nameUnique name == mkUniqueGrimily 0
  1087 
+         -- Note [Outputable Orig RdrName]
  1088 
+
  1089 
+        right_name gre
  1090 
+          | is_rdr_orig = nameModule_maybe (gre_name gre) == Just mod
  1091 
+          | otherwise   = gre_name gre == name
1021 1092
1022 1093 
         unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
1023 1094 
         qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)
 
@@ -1041,6 +1112,25 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
1041 1112
1042 1113 
      | otherwise = True
1043 1114 
      where lookup = lookupModuleInAllPackages dflags (moduleName mod)
  1115 
+
  1116 
+-- Note [Outputable Orig RdrName]
  1117 
+--
  1118 
+-- This is a Grotesque Hack.  The Outputable instance for RdrEnv wants
  1119 
+-- to print Orig names, which are just pairs of (Module,OccName).  But
  1120 
+-- we want to use full Names here, because in GHCi we might have Ids
  1121 
+-- that have the same (Module,OccName) pair but a different Unique
  1122 
+-- (this happens when you shadow a TyCon or Class in GHCi).
  1123 
+--
  1124 
+-- So in Outputable RdrName we just use a dummy Unique (0), and check
  1125 
+-- for it here.
  1126 
+--
  1127 
+-- Arguably GHCi is invalidating the assumption that (Module,OccName)
  1128 
+-- uniquely identifies an entity.  But we do want to be able to shadow
  1129 
+-- old declarations with new ones in GHCi, and it would be hard to
  1130 
+-- delete all references to the old declaration when that happened.
  1131 
+-- See also Note [interactive name cache] in IfaceEnv for somewhere
  1132 
+-- else that this broken assumption bites.
  1133 
+--
1044 1134 
 \end{code}
1045 1135
1046 1136 
 
@@ -1090,6 +1180,8 @@ implicitTyConThings tc
1090 1180 
       -- for each data constructor in order,
1091 1181 
       --   the contructor, worker, and (possibly) wrapper
1092 1182 
     concatMap (extras_plus . ADataCon) (tyConDataCons tc)
  1183 
+      -- NB. record selectors are *not* implicit, they have fully-fledged
  1184 
+      -- bindings that pass through the compilation pipeline as normal.
1093 1185 
   where
1094 1186 
     class_stuff = case tyConClass_maybe tc of
1095 1187 
         Nothing -> []
 
@@ -1121,26 +1213,49 @@ isImplicitTyThing (AnId id)     = isImplicitId id
1121 1213 
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
1122 1214 
 isImplicitTyThing (ACoAxiom {}) = True
1123 1215
1124   
-extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
1125   
-extendTypeEnvWithIds env ids
1126   
-  = extendNameEnvList env [(getName id, AnId id) | id <- ids]
1127   
-
1128 1216 
 tyThingParent_maybe :: TyThing -> Maybe TyThing
1129 1217 
 -- (tyThingParent_maybe x) returns (Just p)
1130 1218 
 -- when pprTyThingInContext sould print a declaration for p
1131 1219 
 -- (albeit with some "..." in it) when asked to show x
1132 1220 
 -- It returns the *immediate* parent.  So a datacon returns its tycon
1133   
--- but the tycon could be the assocated type of a class, so it in turn
  1221 
+-- but the tycon could be the associated type of a class, so it in turn
1134 1222 
 -- might have a parent.
1135 1223 
 tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
1136 1224 
 tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
1137 1225 
                                       Just cls -> Just (ATyCon (classTyCon cls))
1138 1226 
                                       Nothing  -> Nothing
1139 1227 
 tyThingParent_maybe (AnId id)     = case idDetails id of
1140   
-      				      	 RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
  1228 
+                                         RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
1141 1229 
       				      	 ClassOpId cls               -> Just (ATyCon (classTyCon cls))
1142 1230 
                                       	 _other                      -> Nothing
1143 1231 
 tyThingParent_maybe _other = Nothing
  1232 
+
  1233 
+tyThingsTyVars :: [TyThing] -> TyVarSet
  1234 
+tyThingsTyVars tts =
  1235 
+    unionVarSets $ map ttToVarSet tts
  1236 
+    where
  1237 
+        ttToVarSet (AnId id)     = tyVarsOfType $ idType id
  1238 
+        ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc
  1239 
+        ttToVarSet (ATyCon tc)
  1240 
+          = case tyConClass_maybe tc of
  1241 
+              Just cls -> (mkVarSet . fst . classTvsFds) cls
  1242 
+              Nothing  -> tyVarsOfType $ tyConKind tc
  1243 
+        ttToVarSet _             = emptyVarSet
  1244 
+
  1245 
+-- | The Names that a TyThing should bring into scope.  Used to build
  1246 
+-- the GlobalRdrEnv for the InteractiveContext.
  1247 
+tyThingAvailInfo :: TyThing -> AvailInfo
  1248 
+tyThingAvailInfo (ATyCon t)
  1249 
+   = case tyConClass_maybe t of
  1250 
+        Just c  -> AvailTC n (n : map getName (classMethods c)
  1251 
+                  ++ map getName (classATs c))
  1252 
+             where n = getName c
  1253 
+        Nothing -> AvailTC n (n : map getName dcs ++
  1254 
+                                   concatMap dataConFieldLabels dcs)
  1255 
+             where n = getName t
  1256 
+                   dcs = tyConDataCons t
  1257 
+tyThingAvailInfo t
  1258 
+   = Avail (getName t)
1144 1259 
 \end{code}
1145 1260
1146 1261 
 %************************************************************************
 
@@ -1160,6 +1275,7 @@ typeEnvTyCons   :: TypeEnv -> [TyCon]
1160 1275 
 typeEnvCoAxioms :: TypeEnv -> [CoAxiom]