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.
ghc · 3db757241ce7fb99c096c30481aefa86bb9855a1 · Sep 16, 2011
commit 3db757241ce7fb99c096c30481aefa86bb9855a1
1 parent 9de6f19
@@ -5,4 +5,6 @@ import Name( Name )
 data DataCon
 dataConName      :: DataCon -> Name
 isVanillaDataCon :: DataCon -> Bool
+instance Eq DataCon
+instance Ord DataCon
 \end{code}
@@ -435,17 +435,17 @@ instance OutputableBndr Name where
     pprBndr _ name = pprName name
 
 pprName :: Name -> SDoc
-pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
+pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})
   = getPprStyle $ \ sty ->
     case sort of
-      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin
-      External mod  	      -> pprExternal sty uniq mod occ False UserSyntax
+      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ n True  builtin
+      External mod            -> pprExternal sty uniq mod occ n False UserSyntax
       System   		      -> pprSystem sty uniq occ
       Internal    	      -> pprInternal sty uniq occ
   where uniq = mkUniqueGrimily (iBox u)
 
-pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
-pprExternal sty uniq mod occ is_wired is_builtin
+pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc
+pprExternal sty uniq mod occ name is_wired is_builtin
   | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
 	-- In code style, always qualify
 	-- ToDo: maybe we could print all wired-in things unqualified
@@ -455,7 +455,7 @@ pprExternal sty uniq mod occ is_wired is_builtin
 				      pprNameSpaceBrief (occNameSpace occ), 
 		 		      pprUnique uniq])
   | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax
-  | otherwise		        = pprModulePrefix sty mod occ <> ppr_occ_name occ
+  | otherwise                   = pprModulePrefix sty mod name <> ppr_occ_name occ
   where
     pp_mod | opt_SuppressModulePrefixes = empty
            | otherwise                  = ppr mod <> dot 
@@ -482,14 +482,14 @@ pprSystem sty uniq occ
 				-- so print the unique
 
 
-pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
+pprModulePrefix :: PprStyle -> Module -> Name -> SDoc
 -- Print the "M." part of a name, based on whether it's in scope or not
 -- See Note [Printing original names] in HscTypes
-pprModulePrefix sty mod occ
+pprModulePrefix sty mod name
   | opt_SuppressModulePrefixes = empty
   
   | otherwise
-  = case qualName sty mod occ of	           -- See Outputable.QualifyName:
+  = case qualName sty name of              -- See Outputable.QualifyName:
       NameQual modname -> ppr modname <> dot       -- Name is in scope       
       NameNotInScope1  -> ppr mod <> dot           -- Not in scope
       NameNotInScope2  -> ppr (modulePackageId mod) <> colon     -- Module not in
@@ -1,5 +1,9 @@
 \begin{code}
 module Name where
 
+import {-# SOURCE #-} Module
+
 data Name
+
+nameModule :: Name -> Module
 \end{code}
@@ -66,6 +66,7 @@ import Maybes
 import SrcLoc
 import FastString
 import Outputable
+import Unique
 import Util
 import StaticFlags( opt_PprStyle_Debug )
 
@@ -247,7 +248,9 @@ instance Outputable RdrName where
     ppr (Exact name)   = ppr name
     ppr (Unqual occ)   = ppr occ
     ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
-    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)
+    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod name <> ppr occ)
+       where name = mkExternalName (mkUniqueGrimily 0) mod occ noSrcSpan
+         -- Note [Outputable Orig RdrName] in HscTypes
 
 instance OutputableBndr RdrName where
     pprBndr _ n 
@@ -56,24 +56,26 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
 deSugar hsc_env 
         mod_loc
         tcg_env@(TcGblEnv { tcg_mod          = mod,
-			    tcg_src	     = hsc_src,
-		    	    tcg_type_env     = type_env,
-		    	    tcg_imports      = imports,
-		    	    tcg_exports      = exports,
-			    tcg_keep	     = keep_var,
+                            tcg_src          = hsc_src,
+                            tcg_type_env     = type_env,
+                            tcg_imports      = imports,
+                            tcg_exports      = exports,
+                            tcg_keep	     = keep_var,
                             tcg_th_splice_used = tc_splice_used,
                             tcg_rdr_env      = rdr_env,
-		    	    tcg_fix_env      = fix_env,
-		    	    tcg_inst_env     = inst_env,
-		    	    tcg_fam_inst_env = fam_inst_env,
-	    	    	    tcg_warns        = warns,
-	    	    	    tcg_anns         = anns,
-			    tcg_binds        = binds,
-		    	    tcg_imp_specs    = imp_specs,
+                            tcg_fix_env      = fix_env,
+                            tcg_inst_env     = inst_env,
+                            tcg_fam_inst_env = fam_inst_env,
+                            tcg_warns        = warns,
+                            tcg_anns         = anns,
+                            tcg_binds        = binds,
+                            tcg_imp_specs    = imp_specs,
                             tcg_ev_binds     = ev_binds,
                             tcg_fords        = fords,
                             tcg_rules        = rules,
                             tcg_vects        = vects,
+                            tcg_tcs          = tcs,
+                            tcg_clss         = clss,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
                             tcg_hpc          = other_hpc_info })
@@ -96,8 +98,7 @@ deSugar hsc_env
 			 <- if (opt_Hpc
 				  || target == HscInterpreted)
 			       && (not (isHsBoot hsc_src))
-                              then addCoverageTicksToBinds dflags mod mod_loc
-                                                           (typeEnvTyCons type_env) binds 
+                              then addCoverageTicksToBinds dflags mod mod_loc tcs binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do
                        do { ds_ev_binds <- dsEvBinds ev_binds
@@ -151,26 +152,27 @@ deSugar hsc_env
         ; used_th <- readIORef tc_splice_used
 
         ; let mod_guts = ModGuts {
-		mg_module    	= mod,
-		mg_boot	     	= isHsBoot hsc_src,
-		mg_exports   	= exports,
-		mg_deps	     	= deps,
-		mg_used_names   = used_names,
+                mg_module       = mod,
+                mg_boot	        = isHsBoot hsc_src,
+                mg_exports      = exports,
+                mg_deps	        = deps,
+                mg_used_names   = used_names,
                 mg_used_th      = used_th,
                 mg_dir_imps     = imp_mods imports,
-	        mg_rdr_env   	= rdr_env,
-		mg_fix_env   	= fix_env,
-		mg_warns   	= warns,
-		mg_anns      	= anns,
-		mg_types     	= type_env,
-		mg_insts     	= insts,
-		mg_fam_insts 	= fam_insts,
-		mg_inst_env     = inst_env,
-		mg_fam_inst_env = fam_inst_env,
-	        mg_rules     	= ds_rules_for_imps,
-		mg_binds     	= ds_binds,
-		mg_foreign   	= ds_fords,
-		mg_hpc_info  	= ds_hpc_info,
+                mg_rdr_env      = rdr_env,
+                mg_fix_env      = fix_env,
+                mg_warns        = warns,
+                mg_anns         = anns,
+                mg_tcs          = tcs,
+                mg_clss         = clss,
+                mg_insts        = insts,
+                mg_fam_insts    = fam_insts,
+                mg_inst_env     = inst_env,
+                mg_fam_inst_env = fam_inst_env,
+                mg_rules        = ds_rules_for_imps,
+                mg_binds        = ds_binds,
+                mg_foreign      = ds_fords,
+                mg_hpc_info     = ds_hpc_info,
                 mg_modBreaks    = modBreaks,
                 mg_vect_decls   = ds_vects,
                 mg_vect_info    = noVectInfo,
@@ -254,7 +254,7 @@ lookupIE ie con_nm
 linkFail :: String -> String -> IO a
 linkFail who what
    = ghcError (ProgramError $
-        unlines [ ""
+        unlines [ "",who
 	        , "During interactive linking, GHCi couldn't find the following symbol:"
 		, ' ' : ' ' : what 
 		, "This may be due to you not asking GHCi to load extra object files,"
@@ -87,7 +87,7 @@ pprintClosureCommand bindThings force str = do
    tidyTermTyVars :: GhcMonad m => Term -> m Term
    tidyTermTyVars t =
      withSession $ \hsc_env -> do
-     let env_tvs      = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env)))
+     let env_tvs      = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
          my_tvs       = termTyVars t
          tvs          = env_tvs `minusVarSet` my_tvs
          tyvarOccName = nameOccName . tyVarName
@@ -110,7 +110,7 @@ bindSuspensions t = do
       let (names, tys, hvals) = unzip3 stuff
       let ids = [ mkVanillaGlobal name ty 
                 | (name,ty) <- zip names tys]
-          new_ic = extendInteractiveContext ictxt ids
+          new_ic = extendInteractiveContext ictxt (map AnId ids)
       liftIO $ extendLinkEnv (zip names hvals)
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
       return t'
@@ -187,10 +187,8 @@ showTerm term = do
 
   bindToFreshName hsc_env ty userName = do
     name <- newGrimName userName
-    let ictxt    = hsc_IC hsc_env
-        tmp_ids  = ic_tmp_ids ictxt
-        id       = mkVanillaGlobal name ty 
-        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
+    let id       = AnId $ mkVanillaGlobal name ty 
+        new_ic   = extendInteractiveContext (hsc_IC hsc_env) [id]
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names
@@ -202,20 +200,19 @@ newGrimName userName  = do
         name    = mkInternalName unique occname noSrcSpan
     return name
 
-pprTypeAndContents :: GhcMonad m => [Id] -> m SDoc
-pprTypeAndContents ids = do
+pprTypeAndContents :: GhcMonad m => Id -> m SDoc
+pprTypeAndContents id = do
   dflags  <- GHC.getSessionDynFlags
   let pefas     = dopt Opt_PrintExplicitForalls dflags
       pcontents = dopt Opt_PrintBindContents dflags
+      pprdId    = (pprTyThing pefas . AnId) id
   if pcontents 
     then do
       let depthBound = 100
-      terms      <- mapM (GHC.obtainTermFromId depthBound False) ids
-      docs_terms <- mapM showTerm terms
-      return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
-                             (map (pprTyThing pefas . AnId) ids)
-                             docs_terms
-    else return $  vcat $ map (pprTyThing pefas . AnId) ids
+      term      <- GHC.obtainTermFromId depthBound False id
+      docs_term <- showTerm term
+      return $ pprdId <+> equals <+> docs_term
+    else return pprdId
 
 --------------------------------------------------------------
 -- Utils 
@@ -12,7 +12,7 @@
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
 module Linker ( HValue, getHValue, showLinkerState,
-		linkExpr, unload, withExtendedLinkEnv,
+		linkExpr, linkDecls, unload, withExtendedLinkEnv,
                 extendLinkEnv, deleteFromLinkEnv,
                 extendLoadedPkgs, 
 		linkPackages,initDynLinker,linkModule,
@@ -52,6 +52,7 @@ import UniqSet
 import FastString
 import Config
 import SysTools
+import PrelNames
 
 -- Standard libraries
 import Control.Monad
@@ -427,9 +428,9 @@ linkExpr hsc_env span root_ul_bco
 
      needed_mods :: [Module]
      needed_mods = [ nameModule n | n <- free_names, 
-				    isExternalName n,	 	-- Names from other modules
-				    not (isWiredInName n)	-- Exclude wired-in names
-		   ]						-- (see note below)
+                     isExternalName n,      -- Names from other modules
+                     not (isWiredInName n)  -- Exclude wired-in names
+                   ]                        -- (see note below)
 	-- Exclude wired-in names because we may not have read
 	-- their interface files, so getLinkDeps will fail
 	-- 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
 -- Find all the packages and linkables that a set of modules depends on
  = do {
 	-- 1.  Find the dependent home-pkg-modules/packages from each iface
-        (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
+        -- (omitting iINTERACTIVE, which is already linked)
+        (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods)
+                                        emptyUniqSet emptyUniqSet;
 
 	let {
 	-- 2.  Exclude ones already linked
@@ -488,7 +491,6 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
                                 (objs_loaded pls ++ bcos_loaded pls)
 	} ;
 	
---        putStrLn (showSDoc (ppr mods_s)) ;
 	-- 3.  For each dependent module, find its linkable
 	--     This will either be in the HPT or (in the case of one-shot
 	--     compilation) we may need to use maybe_getFileLinkable
@@ -594,6 +596,53 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
 	    adjust_ul _ _ = panic "adjust_ul"
 \end{code}
 
+
+%************************************************************************
+%*									*
+              Loading a Decls statement
+%*									*
+%************************************************************************
+\begin{code}
+linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
+linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
+    -- Initialise the linker (if it's not been done already)
+    let dflags = hsc_dflags hsc_env
+    initDynLinker dflags
+
+    -- Take lock for the actual work.
+    modifyPLS $ \pls0 -> do
+
+    -- Link the packages and modules required
+    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
+    if failed ok
+      then ghcError (ProgramError "")
+      else do
+
+    -- Link the expression itself
+    let ie = plusNameEnv (itbl_env pls) itblEnv
+        ce = closure_env pls
+
+    -- Link the necessary packages and linkables
+    (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs
+    let pls2 = pls { closure_env = final_gce,
+                     itbl_env    = ie }
+    return (pls2, ()) --hvals)
+  where
+    free_names =  concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs
+
+    needed_mods :: [Module]
+    needed_mods = [ nameModule n | n <- free_names, 
+                    isExternalName n,       -- Names from other modules
+                    not (isWiredInName n)   -- Exclude wired-in names
+                  ]                         -- (see note below)
+    -- Exclude wired-in names because we may not have read
+    -- their interface files, so getLinkDeps will fail
+    -- All wired-in names are in the base package, which we link
+    -- by default, so we can safely ignore them here.
+\end{code}
+
+
+
 %************************************************************************
 %*									*
               Loading a single module
@@ -71,39 +71,49 @@ allocateGlobalBinder
   -> (NameCache, Name)
 allocateGlobalBinder name_supply mod occ loc
   = case lookupOrigNameCache (nsNames name_supply) mod occ of
-	-- A hit in the cache!  We are at the binding site of the name.
-	-- This is the moment when we know the SrcLoc
-	-- of the Name, so we set this field in the Name we return.
-	--
-	-- Then (bogus) multiple bindings of the same Name
-	-- get different SrcLocs can can be reported as such.
-	--
-	-- Possible other reason: it might be in the cache because we
-	-- 	encountered an occurrence before the binding site for an
-	--	implicitly-imported Name.  Perhaps the current SrcLoc is
-	--	better... but not really: it'll still just say 'imported'
-	--
-	-- IMPORTANT: Don't mess with wired-in names.  
-	-- 	      Their wired-in-ness is in their NameSort
-	--	      and their Module is correct.
-
-	Just name | isWiredInName name -> (name_supply, name)
-		  | otherwise -> (new_name_supply, name')
-		  where
-		    uniq      = nameUnique name
-		    name'     = mkExternalName uniq mod occ loc
-		    new_cache = extendNameCache (nsNames name_supply) mod occ name'
-		    new_name_supply = name_supply {nsNames = new_cache}		     
-
-	-- Miss in the cache!
-	-- Build a completely new Name, and put it in the cache
-	Nothing -> (new_name_supply, name)
-		where
-		  (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
-		  name            = mkExternalName uniq mod occ loc
-		  new_cache       = extendNameCache (nsNames name_supply) mod occ name
-		  new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
-
+        -- A hit in the cache!  We are at the binding site of the name.
+        -- This is the moment when we know the SrcLoc
+        -- of the Name, so we set this field in the Name we return.
+        --
+        -- Then (bogus) multiple bindings of the same Name
+        -- get different SrcLocs can can be reported as such.
+        --
+        -- Possible other reason: it might be in the cache because we
+        -- 	encountered an occurrence before the binding site for an
+        --	implicitly-imported Name.  Perhaps the current SrcLoc is
+        --	better... but not really: it'll still just say 'imported'
+        --
+        -- IMPORTANT: Don't mess with wired-in names.
+        -- 	      Their wired-in-ness is in their NameSort
+        --	      and their Module is correct.
+
+        Just name | isWiredInName name -> (name_supply, name)
+                  | mod /= iNTERACTIVE -> (new_name_supply, name')
+                     -- Note [interactive name cache]
+                  where
+                    uniq            = nameUnique name
+                    name'           = mkExternalName uniq mod occ loc
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'
+                    new_name_supply = name_supply {nsNames = new_cache}
+
+        -- Miss in the cache!
+        -- Build a completely new Name, and put it in the cache
+        _ -> (new_name_supply, name)
+                  where
+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
+                    name            = mkExternalName uniq mod occ loc
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+{- Note [interactive name cache]
+
+In GHCi we always create Names with the same Module, ":Interactive".
+However, we want to be able to shadow older declarations with newer
+ones, and we don't want the Name cache giving us back the same Unique
+for the new Name as for the old, hence this special case.
+
+See also Note [Outputable Orig RdrName] in HscTypes.
+-}
 
 newImplicitBinder :: Name			-- Base name
 	          -> (OccName -> OccName) 	-- Occurrence name modifier
@@ -80,7 +80,7 @@ module GHC (
 	PrintUnqualified, alwaysQualify,
 
 	-- * Interactive evaluation
-	getBindings, getPrintUnqual,
+	getBindings, getInsts, getPrintUnqual,
         findModule,
         lookupModule,
 #ifdef GHCI
@@ -94,7 +94,7 @@ module GHC (
 	typeKind,
 	parseName,
 	RunResult(..),  
-	runStmt, runStmtWithLocation,
+	runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
         parseImportDecl, SingleStep(..),
         resume,
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
@@ -166,7 +166,9 @@ module GHC (
 
 	-- ** Instances
 	Instance, 
-	instanceDFunId, pprInstance, pprInstanceHdr,
+	instanceDFunId, 
+        pprInstance, pprInstanceHdr,
+        pprFamInst, pprFamInstHdr,
 
 	-- ** Types and Kinds
 	Type, splitForAllTys, funResultTy, 
@@ -264,8 +266,9 @@ import Class
 import DataCon
 import Name             hiding ( varName )
 import InstEnv
+import FamInstEnv
 import SrcLoc
-import CoreSyn          ( CoreBind )
+import CoreSyn
 import TidyPgm
 import DriverPhases     ( Phase(..), isHaskellSrcFilename )
 import Finder
@@ -864,11 +867,15 @@ compileCore simplify fn = do
         -- we just have a ModGuts.
         gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
         gutsToCoreModule (Left (cg, md))  = CoreModule {
-          cm_module = cg_module cg,    cm_types = md_types md,
+          cm_module = cg_module cg,
+          cm_types = md_types md,
           cm_binds = cg_binds cg
         }
         gutsToCoreModule (Right mg) = CoreModule {
-          cm_module  = mg_module mg,                   cm_types   = mg_types mg,
+          cm_module  = mg_module mg,
+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
+                                           (mg_tcs mg) (mg_clss mg)
+                                           (mg_fam_insts mg),
           cm_binds   = mg_binds mg
          }
 
@@ -899,13 +906,12 @@ isLoaded m = withSession $ \hsc_env ->
 -- | Return the bindings for the current interactive session.
 getBindings :: GhcMonad m => m [TyThing]
 getBindings = withSession $ \hsc_env ->
-   -- we have to implement the shadowing behaviour of ic_tmp_ids here
-   -- (see InteractiveContext) and the quickest way is to use an OccEnv.
-   let 
-       occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) 
-                          | id <- ic_tmp_ids (hsc_IC hsc_env) ]
-   in
-   return (occEnvElts occ_env)
+    return $ icInScopeTTs $ hsc_IC hsc_env
+
+-- | Return the instances for the current interactive session.
+getInsts :: GhcMonad m => m ([Instance], [FamInst])
+getInsts = withSession $ \hsc_env ->
+    return $ ic_instances (hsc_IC hsc_env)
 
 getPrintUnqual :: GhcMonad m => m PrintUnqualified
 getPrintUnqual = withSession $ \hsc_env ->
@@ -63,6 +63,7 @@ module HscMain
     , hscRnImportDecls
     , hscTcRnLookupRdrName
     , hscStmt, hscStmtWithLocation
+    , hscDecls, hscDeclsWithLocation
     , hscTcExpr, hscImport, hscKcType
     , hscCompileCoreExpr
 #endif
@@ -71,13 +72,11 @@ module HscMain
 
 #ifdef GHCI
 import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
-import Linker		( HValue, linkExpr )
+import Linker
 import CoreTidy		( tidyExpr )
 import Type		( Type )
-import TcType           ( tyVarsOfTypes )
-import PrelNames	( iNTERACTIVE )
+import PrelNames
 import {- Kind parts of -} Type		( Kind )
-import Id      	     	( idType )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
 import VarSet
@@ -85,7 +84,7 @@ import VarEnv		( emptyTidyEnv )
 import Panic
 #endif
 
-import Id		( Id )
+import Id
 import Module
 import Packages
 import RdrName
@@ -100,7 +99,7 @@ import TcIface		( typecheckIface )
 import TcRnMonad
 import IfaceEnv		( initNameCache )
 import LoadIface	( ifaceStats, initExternalPackageState )
-import PrelInfo		( wiredInThings, basicKnownKeyNames )
+import PrelInfo
 import MkIface
 import Desugar
 import SimplCore
@@ -111,8 +110,9 @@ import qualified StgCmm	( codeGen )
 import StgSyn
 import CostCentre
 import ProfInit
-import TyCon            ( TyCon, isDataTyCon )
-import Name		( Name, NamedThing(..) )
+import TyCon
+import Class
+import Name
 import SimplStg		( stg2stg )
 import CodeGen		( codeGen )
 import OldCmm as Old    ( CmmGroup )
@@ -127,7 +127,7 @@ import CodeOutput
 import NameEnv          ( emptyNameEnv )
 import NameSet          ( emptyNameSet )
 import InstEnv
-import FamInstEnv       ( emptyFamInstEnv )
+import FamInstEnv
 import Fingerprint      ( Fingerprint )
 
 import DynFlags
@@ -1287,8 +1287,8 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
                             tcRnStmt hsc_env icontext parsed_stmt
 	    -- Desugar it
 	let rdr_env  = ic_rn_gbl_env icontext
-	    type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
-	ds_expr <- ioMsgMaybe $
+            type_env = mkTypeEnvWithImplicits (ic_tythings icontext)
+        ds_expr <- ioMsgMaybe $
                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
         handleWarnings
 
@@ -1297,7 +1297,90 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
         hsc_env <- getHscEnv
 	hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
 
-	return $ Just (ids, hval)
+        return $ Just (ids, hval)
+
+hscDecls                -- Compile a decls
+  :: HscEnv
+  -> String             -- The statement
+  -> IO ([TyThing], InteractiveContext)
+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
+
+hscDeclsWithLocation    -- Compile a decls
+  :: HscEnv
+  -> String             -- The statement
+  -> String             -- the source
+  -> Int                -- ^ starting line
+  -> IO ([TyThing], InteractiveContext)
+hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do 
+    L _ (HsModule{hsmodDecls=decls}) <-
+        hscParseThingWithLocation source linenumber parseModule str
+    
+    -- Rename and typecheck it
+    let icontext = hsc_IC hsc_env
+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
+
+    -- Grab the new instances
+    -- We grab the whole environment because of the overlapping that may have 
+    -- been done.  See the notes at the definition of InteractiveContext
+    -- (ic_instances) for more details.
+    let finsts  = famInstEnvElts $ tcg_fam_inst_env tc_gblenv
+        insts   = instEnvElts $ tcg_inst_env tc_gblenv
+
+	-- Desugar it
+    -- We use a basically null location for iNTERACTIVE
+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
+                                      ml_hi_file   = undefined,
+                                      ml_obj_file  = undefined}
+    ds_result <- ioMsgMaybe $ deSugar hsc_env iNTERACTIVELoc tc_gblenv
+    handleWarnings
+
+        -- Simplify
+    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
+
+        -- Tidy
+    (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
+
+    let dflags = hsc_dflags hsc_env
+        CgGuts{ cg_binds     = core_binds,
+                cg_tycons    = tycons,
+                cg_modBreaks = mod_breaks } = tidy_cg
+        data_tycons = filter isDataTyCon tycons
+
+	-------------------
+	-- PREPARE FOR CODE GENERATION
+	-- Do saturation and convert to A-normal form
+    prepd_binds <- {-# SCC "CorePrep" #-}
+                    liftIO $ corePrepPgm dflags core_binds data_tycons
+
+    -----------------  Generate byte code ------------------
+    cbc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks
+
+    let src_span = srcLocSpan interactiveSrcLoc
+    hsc_env <- getHscEnv
+    liftIO $ linkDecls hsc_env src_span cbc
+
+    -- pprTrace "te" (ppr te) $ return ()
+
+    let
+        tcs     = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg
+        clss    = mg_clss simpl_mg
+        tythings = map ATyCon tcs ++ map (ATyCon . classTyCon) clss
+        sys_vars = filter (isExternalName . idName) $
+                      bindersOfBinds (cg_binds tidy_cg)
+                   -- we only need to keep around the external bindings
+                   -- (as decided by TidyPgm), since those are the only ones
+                   -- that might be referenced elsewhere.
+
+    -- pprTrace "new tycons"  (ppr tcs) $ return ()
+    -- pprTrace "new classes" (ppr clss) $ return ()
+    -- pprTrace "new sys Ids" (ppr sys_vars) $ return ()
+
+    let ictxt1 = extendInteractiveContext icontext tythings
+        ictxt = ictxt1 {
+            ic_sys_vars   = sys_vars ++ ic_sys_vars ictxt1,
+            ic_instances  = (insts, finsts) }
+    
+    return $ (tythings, ictxt)
 
 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
 hscImport hsc_env str = runHsc hsc_env $ do
@@ -1311,7 +1394,7 @@ hscImport hsc_env str = runHsc hsc_env $ do
 
 hscTcExpr	-- Typecheck an expression (but don't run it)
   :: HscEnv
-  -> String			-- The expression
+  -> String                     -- The expression
   -> IO Type
 
 hscTcExpr hsc_env expr = runHsc hsc_env $ do
@@ -1326,7 +1409,7 @@ hscTcExpr hsc_env expr = runHsc hsc_env $ do
 -- | Find the kind of a type
 hscKcType
   :: HscEnv
-  -> String			-- ^ The type
+  -> String                     -- ^ The type
   -> IO Kind
 
 hscKcType hsc_env str = runHsc hsc_env $ do
@@ -1414,7 +1497,8 @@ mkModGuts mod binds = ModGuts {
   mg_used_th = False,
   mg_rdr_env = emptyGlobalRdrEnv,
   mg_fix_env = emptyFixityEnv,
-  mg_types = emptyTypeEnv,
+  mg_tcs   = [],
+  mg_clss  = [],
   mg_insts = [],
   mg_fam_insts = [],
   mg_rules = [],
@@ -1463,9 +1547,11 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
   	-- ToDo: improve SrcLoc
     when lint_on $
        let ictxt = hsc_IC hsc_env
-           tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
+           te     = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
+           tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
+           vars   = typeEnvIds te
        in
-           case lintUnfolding noSrcLoc tyvars prepd_expr of
+           case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
   	      Just err -> pprPanic "hscCompileCoreExpr" err
   	      Nothing  -> return ()
 
@@ -41,10 +41,10 @@ module HscTypes (
         prepareAnnotations,
 
         -- * Interactive context
-	InteractiveContext(..), emptyInteractiveContext, 
-        InteractiveImport(..),
-	icPrintUnqual, extendInteractiveContext,
-        substInteractiveContext,
+        InteractiveContext(..), emptyInteractiveContext, 
+        icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv,
+        extendInteractiveContext, substInteractiveContext,
+        InteractiveImport(..), 
         mkPrintUnqualified, pprModulePrefix,
 
 	-- * Interfaces
@@ -55,15 +55,17 @@ module HscTypes (
 	FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
 
         -- * TyThings and type environments
-	TyThing(..),
+        TyThing(..),  tyThingAvailInfo,
 	tyThingTyCon, tyThingDataCon,
-        tyThingId, tyThingCoAxiom, tyThingParent_maybe,
-	implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
+        tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars,
+        implicitTyThings, implicitTyConThings, implicitClassThings,
+        isImplicitTyThing,
 	
 	TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
+        typeEnvFromEntities, mkTypeEnvWithImplicits,
 	extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
 	typeEnvElts, typeEnvTyCons, typeEnvIds,
-	typeEnvDataCons, typeEnvCoAxioms,
+        typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
 
         -- * MonadThings
         MonadThings(..),
@@ -73,8 +75,8 @@ module HscTypes (
 	Dependencies(..), noDependencies,
 	NameCache(..), OrigNameCache, OrigIParamCache,
 	Avails, availsToNameSet, availsToNameEnv, availName, availNames,
-	AvailInfo(..),
-	IfaceExport, stableAvailCmp, 
+        AvailInfo(..), gresFromAvails, gresFromAvail,
+        IfaceExport, stableAvailCmp,
 
 	-- * Warnings
 	Warnings(..), WarningTxt(..), plusWarns,
@@ -118,7 +120,7 @@ import NameEnv
 import NameSet  
 import Module
 import InstEnv          ( InstEnv, Instance )
-import FamInstEnv       ( FamInstEnv, FamInst )
+import FamInstEnv
 import Rules            ( RuleBase )
 import CoreSyn          ( CoreBind )
 import VarEnv
@@ -129,23 +131,24 @@ import IdInfo		( IdDetails(..) )
 import Type             
 
 import Annotations
-import Class		( Class, classAllSelIds, classATs, classTyCon )
+import Class
 import TyCon
-import DataCon		( DataCon, dataConImplicitIds, dataConWrapId, dataConTyCon )
+import DataCon
 import PrelNames	( gHC_PRIM )
 import Packages hiding ( Version(..) )
 import DynFlags
-import DriverPhases	( HscSource(..), isHsBoot, hscSourceString, Phase )
-import BasicTypes	( IPName, defaultFixity, WarningTxt(..) )
+import DriverPhases
+import BasicTypes
 import OptimizationFuel	( OptFuelState )
 import IfaceSyn
 import CoreSyn		( CoreRule, CoreVect )
-import Maybes		( orElse, expectJust, catMaybes )
+import Maybes
 import Outputable
 import BreakArray
 import SrcLoc
-import UniqFM		( lookupUFM, eltsUFM, emptyUFM )
-import UniqSupply	( UniqSupply )
+import Unique
+import UniqFM
+import UniqSupply
 import FastString
 import StringBuffer	( StringBuffer )
 import Fingerprint
@@ -159,7 +162,6 @@ import System.Time	( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
 import Data.Map         ( Map )
-import Data.List
 import Data.Word
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
@@ -747,7 +749,8 @@ data ModGuts
 	-- These fields all describe the things **declared in this module**
 	mg_fix_env   :: !FixityEnv,	 -- ^ Fixities declared in this module
 	                                 -- TODO: I'm unconvinced this is actually used anywhere
-	mg_types     :: !TypeEnv,        -- ^ Types declared in this module
+        mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
+        mg_clss      :: ![Class],        -- ^ Classes declared in this module
 	mg_insts     :: ![Instance],	 -- ^ Class instances declared in this module
 	mg_fam_insts :: ![FamInst],	 -- ^ Family instances declared in this module
         mg_rules     :: ![CoreRule],	 -- ^ Before the core pipeline starts, contains 
@@ -895,70 +898,130 @@ data InteractiveContext
              -- ^ The GHCi context is extended with these imports
 
          ic_rn_gbl_env :: GlobalRdrEnv,
-             -- ^ The contexts' cached 'GlobalRdrEnv', built by
-             -- 'InteractiveEval.setContext'
+             -- ^ The cached 'GlobalRdrEnv', built by
+             -- 'InteractiveEval.setContext' and updated regularly
 
-         ic_tmp_ids :: [Id],
-             -- ^ Names bound during interaction with the user.  Later
-             -- Ids shadow earlier ones with the same OccName
-             -- Expressions are typed with these Ids in the envt For
-             -- runtime-debugging, these Ids may have free TcTyVars of
-             -- RuntimUnkSkol flavour, but no free TyVars (because the
-             -- typechecker doesn't expect that)
+         ic_tythings :: [TyThing],
+             -- ^ TyThings defined by the user, in reverse order of
+             -- definition.
+
+         ic_sys_vars  :: [Id],
+             -- ^ Variables defined automatically by the system (e.g.
+             -- record field selectors).  See Notes [ic_sys_vars]
+
+         ic_instances :: ([Instance], [FamInst]),
+             -- ^ All instances and family instances created during
+             -- this session.  These are grabbed en masse after each
+             -- update to be sure that proper overlapping is retained.
+             -- That is, rather than re-check the overlapping each
+             -- time we update the context, we just take the results
+             -- from the instance code that already does that.
 
 #ifdef GHCI
-         ic_resume :: [Resume],
+          ic_resume :: [Resume],
              -- ^ The stack of breakpoint contexts
 #endif
 
-         ic_cwd :: Maybe FilePath
+          ic_cwd :: Maybe FilePath
              -- virtual CWD of the program
     }
 
-data InteractiveImport 
-  = IIDecl (ImportDecl RdrName)	-- Bring the exports of a particular module
-    	   	       		-- (filtered by an import decl) into scope
+{-
+Note [ic_sys_vars]
 
-  | IIModule Module	-- Bring into scope the entire top-level envt of
-    	     		-- of this module, including the things imported
-			-- into it.
- 
+This list constains any Ids that arise from TyCons, Classes or
+instances defined interactively, but that are not given by
+'implicitTyThings'.  This includes record selectors, default methods,
+and dfuns.
+
+We *could* get rid of this list and generate these Ids from
+ic_tythings:
+
+   - dfuns come from Instances
+   - record selectors from TyCons
+   - default methods from Classes
+
+For record selectors the TyCon gives the Name, but in order to make an
+Id we would have to construct the type ourselves.  Similarly for
+default methods.  So for now we collect the Ids after tidying (see
+hscDeclsWithLocation) and save them in ic_sys_vars.
+-}
+
+-- | Constructs an empty InteractiveContext.
 emptyInteractiveContext :: InteractiveContext
-emptyInteractiveContext
-  = InteractiveContext { ic_imports = [],
-			 ic_rn_gbl_env = emptyGlobalRdrEnv,
-			 ic_tmp_ids = []
+emptyInteractiveContext = InteractiveContext {
+    ic_imports      = [],
+    ic_rn_gbl_env   = emptyGlobalRdrEnv,
+    ic_tythings     = [],
+    ic_sys_vars     = [],
+    ic_instances    = ([],[]),
 #ifdef GHCI
-                         , ic_resume = []
+    ic_resume       = [],
 #endif
-                         , ic_cwd = Nothing
-                       }
-
-icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
-icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt)
+    ic_cwd          = Nothing }
 
+-- | This function returns the list of visible TyThings (useful for
+-- e.g. showBindings)
+icInScopeTTs :: InteractiveContext -> [TyThing]
+icInScopeTTs = ic_tythings
 
+-- | Get the PrintUnqualified function based on the flags and this InteractiveContext
+icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
+icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = 
+    mkPrintUnqualified dflags grenv
+
+-- | This function is called with new TyThings recently defined to update the 
+-- InteractiveContext to include them.  Ids are easily removed when shadowed,
+-- but Classes and TyCons are not.  Some work could be done to determine 
+-- whether they are entirely shadowed, but as you could still have references 
+-- 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]
+        -> [TyThing]
         -> InteractiveContext
-extendInteractiveContext ictxt ids
-  = ictxt { ic_tmp_ids =  snub ((ic_tmp_ids ictxt \\ ids) ++ ids)
-                          -- NB. must be this way around, because we want
-                          -- new ids to shadow existing bindings.
+extendInteractiveContext ictxt new_tythings
+  = ictxt { ic_tythings = new_tythings ++ old_tythings
+          , ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt
           }
-    where snub = map head . group . sort
+  where
+    old_tythings = filter (not . shadowed) (ic_tythings ictxt)
+
+    shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id
+    shadowed _ = False
+
+    new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
+
+    -- XXX should not add Ids to the gbl env here
+
+-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list
+-- shadowing later ones, and shadowing existing entries in the
+-- GlobalRdrEnv.
+icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
+icPlusGblRdrEnv tythings env = extendOccEnvList env list
+  where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
+        list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
 
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
 substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
-substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst 
-  = ictxt { ic_tmp_ids = map subst_ty ids }
+substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst 
+  = ictxt { ic_tythings = map subst_ty tts }
   where
-   subst_ty id = id `setIdType` substTy subst (idType id)
+   subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
+   subst_ty tt = tt
+
+data InteractiveImport
+  = IIDecl (ImportDecl RdrName)	-- Bring the exports of a particular module
+                                -- (filtered by an import decl) into scope
+
+  | IIModule Module	-- Bring into scope the entire top-level envt of
+                    -- of this module, including the things imported
+                    -- into it.
 
 instance Outputable InteractiveImport where
   ppr (IIModule m) = char '*' <> ppr m
   ppr (IIDecl d)   = ppr d
+
 \end{code}
 
 %************************************************************************
@@ -1003,7 +1066,7 @@ the (ppr mod) of case (3), in Name.pprModulePrefix
 mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
 mkPrintUnqualified dflags env = (qual_name, qual_mod)
   where
-  qual_name mod occ	-- The (mod,occ) pair is the original name of the thing
+  qual_name name
         | [gre] <- unqual_gres, right_name gre = NameUnqual
 		-- If there's a unique entity that's in scope unqualified with 'occ'
 		-- 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)
 
 	| otherwise = panic "mkPrintUnqualified"
       where
-	right_name gre = nameModule_maybe (gre_name gre) == Just mod
+        mod = nameModule name
+        occ = nameOccName name
+
+        is_rdr_orig = nameUnique name == mkUniqueGrimily 0
+         -- Note [Outputable Orig RdrName]
+
+        right_name gre
+          | is_rdr_orig = nameModule_maybe (gre_name gre) == Just mod
+          | otherwise   = gre_name gre == name
 
         unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
         qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)
@@ -1041,6 +1112,25 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
 
      | otherwise = True
      where lookup = lookupModuleInAllPackages dflags (moduleName mod)
+
+-- Note [Outputable Orig RdrName]
+--
+-- This is a Grotesque Hack.  The Outputable instance for RdrEnv wants
+-- to print Orig names, which are just pairs of (Module,OccName).  But
+-- we want to use full Names here, because in GHCi we might have Ids
+-- that have the same (Module,OccName) pair but a different Unique
+-- (this happens when you shadow a TyCon or Class in GHCi).
+--
+-- So in Outputable RdrName we just use a dummy Unique (0), and check
+-- for it here.
+--
+-- Arguably GHCi is invalidating the assumption that (Module,OccName)
+-- uniquely identifies an entity.  But we do want to be able to shadow
+-- old declarations with new ones in GHCi, and it would be hard to
+-- delete all references to the old declaration when that happened.
+-- See also Note [interactive name cache] in IfaceEnv for somewhere
+-- else that this broken assumption bites.
+--
 \end{code}
 
 
@@ -1090,6 +1180,8 @@ implicitTyConThings tc
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
     concatMap (extras_plus . ADataCon) (tyConDataCons tc)
+      -- NB. record selectors are *not* implicit, they have fully-fledged
+      -- bindings that pass through the compilation pipeline as normal.
   where
     class_stuff = case tyConClass_maybe tc of
         Nothing -> []
@@ -1121,26 +1213,49 @@ isImplicitTyThing (AnId id)     = isImplicitId id
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
 isImplicitTyThing (ACoAxiom {}) = True
 
-extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
-extendTypeEnvWithIds env ids
-  = extendNameEnvList env [(getName id, AnId id) | id <- ids]
-
 tyThingParent_maybe :: TyThing -> Maybe TyThing
 -- (tyThingParent_maybe x) returns (Just p)
 -- when pprTyThingInContext sould print a declaration for p
 -- (albeit with some "..." in it) when asked to show x
 -- It returns the *immediate* parent.  So a datacon returns its tycon
--- but the tycon could be the assocated type of a class, so it in turn
+-- but the tycon could be the associated type of a class, so it in turn
 -- might have a parent.
 tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
 tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
                                       Just cls -> Just (ATyCon (classTyCon cls))
                                       Nothing  -> Nothing
 tyThingParent_maybe (AnId id)     = case idDetails id of
-      				      	 RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
+                                         RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
       				      	 ClassOpId cls               -> Just (ATyCon (classTyCon cls))
                                       	 _other                      -> Nothing
 tyThingParent_maybe _other = Nothing
+
+tyThingsTyVars :: [TyThing] -> TyVarSet
+tyThingsTyVars tts =
+    unionVarSets $ map ttToVarSet tts
+    where
+        ttToVarSet (AnId id)     = tyVarsOfType $ idType id
+        ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc
+        ttToVarSet (ATyCon tc)
+          = case tyConClass_maybe tc of
+              Just cls -> (mkVarSet . fst . classTvsFds) cls
+              Nothing  -> tyVarsOfType $ tyConKind tc
+        ttToVarSet _             = emptyVarSet
+
+-- | The Names that a TyThing should bring into scope.  Used to build
+-- the GlobalRdrEnv for the InteractiveContext.
+tyThingAvailInfo :: TyThing -> AvailInfo
+tyThingAvailInfo (ATyCon t)
+   = case tyConClass_maybe t of
+        Just c  -> AvailTC n (n : map getName (classMethods c)
+                  ++ map getName (classATs c))
+             where n = getName c
+        Nothing -> AvailTC n (n : map getName dcs ++
+                                   concatMap dataConFieldLabels dcs)
+             where n = getName t
+                   dcs = tyConDataCons t
+tyThingAvailInfo t
+   = Avail (getName t)
 \end{code}
 
 %************************************************************************
@@ -1160,6 +1275,7 @@ typeEnvTyCons   :: TypeEnv -> [TyCon]
 typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
 typeEnvIds      :: TypeEnv -> [Id]
 typeEnvDataCons :: TypeEnv -> [DataCon]
+typeEnvClasses  :: TypeEnv -> [Class]
 lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing
 
 emptyTypeEnv 	    = emptyNameEnv
@@ -1168,10 +1284,27 @@ typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env]
 typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] 
 typeEnvIds      env = [id | AnId id     <- typeEnvElts env] 
 typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] 
+typeEnvClasses  env = [cl | tc <- typeEnvTyCons env,
+                            Just cl <- [tyConClass_maybe tc]]
 
 mkTypeEnv :: [TyThing] -> TypeEnv
 mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
 		
+mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv
+mkTypeEnvWithImplicits things = 
+  mkTypeEnv things
+    `plusNameEnv`
+  mkTypeEnv (concatMap implicitTyThings things)
+
+typeEnvFromEntities :: [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
+typeEnvFromEntities ids tcs clss faminsts =
+  mkTypeEnv (   map AnId ids
+             ++ map ATyCon all_tcs
+             ++ concatMap implicitTyConThings all_tcs
+            )
+ where
+  all_tcs = tcs ++ map classTyCon clss ++ map famInstTyCon faminsts
+
 lookupTypeEnv = lookupNameEnv
 
 -- Extend the type environment
@@ -1180,6 +1313,11 @@ extendTypeEnv env thing = extendNameEnv env (getName thing) thing
 
 extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
 extendTypeEnvList env things = foldl extendTypeEnv env things
+
+extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
+extendTypeEnvWithIds env ids
+  = extendNameEnvList env [(getName id, AnId id) | id <- ids]
+
 \end{code}
 
 \begin{code}
@@ -1377,6 +1515,25 @@ availNames :: AvailInfo -> [Name]
 availNames (Avail n)      = [n]
 availNames (AvailTC _ ns) = ns
 
+-- | make a 'GlobalRdrEnv' where all the elements point to the same
+-- import declaration (useful for "hiding" imports, or imports with
+-- no details).
+gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
+gresFromAvails prov avails
+  = concatMap (gresFromAvail (const prov)) avails
+
+gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
+gresFromAvail prov_fn avail
+  = [ GRE {gre_name = n,
+           gre_par = parent n avail,
+           gre_prov = prov_fn n}
+    | n <- availNames avail ]
+  where
+    parent _ (Avail _)                 = NoParent
+    parent n (AvailTC m _) | n == m    = NoParent
+                           | otherwise = ParentIs m
+
+
 instance Outputable AvailInfo where
    ppr = pprAvail
 
@@ -9,7 +9,7 @@
 module InteractiveEval (
 #ifdef GHCI
         RunResult(..), Status(..), Resume(..), History(..),
-	runStmt, runStmtWithLocation,
+	runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
         parseImportDecl, SingleStep(..),
         resume,
         abandon, abandonAll,
@@ -42,7 +42,6 @@ import GhcMonad
 import HscMain
 import HsSyn
 import HscTypes
-import RnNames          (gresFromAvails)
 import InstEnv
 import Type     hiding( typeKind )
 import TcType		hiding( typeKind )
@@ -93,8 +92,7 @@ import System.IO.Unsafe
 
 data RunResult
   = RunOk [Name] 		-- ^ names bound by this evaluation
-  | RunFailed	 		-- ^ statement failed compilation
-  | RunException SomeException	-- ^ statement raised an exception
+  | RunException SomeException  -- ^ statement raised an exception
   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
@@ -109,7 +107,7 @@ data Resume
        resumeThreadId  :: ThreadId,     -- thread running the computation
        resumeBreakMVar :: MVar (),   
        resumeStatMVar  :: MVar Status,
-       resumeBindings  :: [Id],
+       resumeBindings  :: ([TyThing], GlobalRdrEnv),
        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
        resumeApStack   :: HValue,       -- The object from which we can get
                                         -- value of the free variables.
@@ -203,9 +201,9 @@ runStmtWithLocation source linenumber expr step =
     r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
 
     case r of
-      Nothing -> return RunFailed -- empty statement / comment
+      Nothing -> return (RunOk []) -- empty statement / comment
 
-      Just (ids, hval) -> do
+      Just (tyThings, hval) -> do
         status <-
           withVirtualCWD $
             withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
@@ -213,16 +211,38 @@ runStmtWithLocation source linenumber expr step =
                 liftIO $ sandboxIO dflags' statusMVar thing_to_run
               
         let ic = hsc_IC hsc_env
-            bindings = ic_tmp_ids ic
+            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
 
         case step of
           RunAndLogSteps ->
-              traceRunStatus expr bindings ids
+              traceRunStatus expr bindings tyThings
                              breakMVar statusMVar status emptyHistory
           _other ->
-              handleRunStatus expr bindings ids
+              handleRunStatus expr bindings tyThings
                                breakMVar statusMVar status emptyHistory
 
+runDecls :: GhcMonad m => String -> m [Name]
+runDecls = runDeclsWithLocation "<interactive>" 1
+
+runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation source linenumber expr =
+  do
+    hsc_env <- getSession
+
+    -- Turn off -fwarn-unused-bindings when running a statement, to hide
+    -- warnings about the implicit bindings we introduce.
+    let dflags'  = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
+        hsc_env' = hsc_env{ hsc_dflags = dflags' }
+
+    (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber
+    
+    setSession $ hsc_env { hsc_IC = ic }
+    hsc_env <- getSession
+    hsc_env' <- liftIO $ rttiEnvironment hsc_env
+    modifySession (\_ -> hsc_env')
+    return (map getName tyThings)
+
+
 withVirtualCWD :: GhcMonad m => m a -> m a
 withVirtualCWD m = do
   hsc_env <- getSession
@@ -251,7 +271,7 @@ emptyHistory :: BoundedList History
 emptyHistory = nilBL 50 -- keep a log of length 50
 
 handleRunStatus :: GhcMonad m =>
-                   String-> [Id] -> [Id]
+                   String-> ([TyThing],GlobalRdrEnv) -> [Id]
                 -> MVar () -> MVar Status -> Status -> BoundedList History
                 -> m RunResult
 handleRunStatus expr bindings final_ids breakMVar statusMVar status
@@ -280,15 +300,16 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
 	    Left e -> return (RunException e)
 	    Right hvals -> do
                 hsc_env <- getSession
-                let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids 
-                    final_names = map idName final_ids
+                let final_ic = extendInteractiveContext (hsc_IC hsc_env)
+                                                        (map AnId final_ids)
+                    final_names = map getName final_ids
                 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
                 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
                 modifySession (\_ -> hsc_env')
                 return (RunOk final_names)
 
 traceRunStatus :: GhcMonad m =>
-                  String -> [Id] -> [Id]
+                  String -> ([TyThing], GlobalRdrEnv) -> [Id]
                -> MVar () -> MVar Status -> Status -> BoundedList History
                -> m RunResult
 traceRunStatus expr bindings final_ids
@@ -448,15 +469,16 @@ resume canLogSpan step
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
         -- InteractiveContext.
-        let resume_tmp_ids = resumeBindings r
-            ic' = ic { ic_tmp_ids  = resume_tmp_ids,
+        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
+            ic' = ic { ic_tythings = resume_tmp_te,
+                       ic_rn_gbl_env = resume_rdr_env,
                        ic_resume   = rs }
         modifySession (\_ -> hsc_env{ hsc_IC = ic' })
         
         -- remove any bindings created since the breakpoint from the 
         -- linker's environment
-        let new_names = map idName (filter (`notElem` resume_tmp_ids)
-                                           (ic_tmp_ids ic))
+        let new_names = map getName (filter (`notElem` resume_tmp_te)
+                                           (ic_tythings ic))
         liftIO $ Linker.deleteFromLinkEnv new_names
         
         when (isStep step) $ liftIO setStepFlag
@@ -555,7 +577,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
        e_fs      = fsLit "e"
        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
        e_tyvar   = mkRuntimeUnkTyVar e_name liftedTypeKind
-       exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
+       exn_id    = AnId $ Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
 
        ictxt0 = hsc_IC hsc_env
        ictxt1 = extendInteractiveContext ictxt0 [exn_id]
@@ -627,7 +649,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
        final_ids = zipWith setIdType all_ids tidy_tys
        ictxt0 = hsc_IC hsc_env
-       ictxt1 = extendInteractiveContext ictxt0 final_ids
+       ictxt1 = extendInteractiveContext ictxt0 (map AnId final_ids)
 
    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
    when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
@@ -656,7 +678,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 
 rttiEnvironment :: HscEnv -> IO HscEnv 
 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
-   let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+   let tmp_ids = [id | AnId id <- ic_tythings ic]
        incompletelyTypedIds = 
            [id | id <- tmp_ids
                , not $ noSkolems id
@@ -666,7 +688,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
     where
      noSkolems = isEmptyVarSet . tyVarsOfType . idType
      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
-      let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+      let tmp_ids = [id | AnId id <- ic_tythings ic]
           Just id = find (\i -> idName i == name) tmp_ids
       if noSkolems id
          then return hsc_env
@@ -783,9 +805,10 @@ setContext imports
   = do { hsc_env <- getSession
        ; let old_ic = hsc_IC hsc_env
        ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports
+       ; let final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
        ; modifySession $ \_ ->
          hsc_env{ hsc_IC = old_ic { ic_imports      = imports
-                                  , ic_rn_gbl_env   = all_env }}}
+                                  , ic_rn_gbl_env   = final_rdr_env }}}
 
 findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv
 -- Compute the GlobalRdrEnv for the interactive context
@@ -880,11 +903,8 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
   let 
       ic = hsc_IC hsc_env
       gbl_rdrenv = ic_rn_gbl_env ic
-      ids = ic_tmp_ids ic
-      gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
-      lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
-  --
-  return (gbl_names ++ lcl_names)
+      gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv
+  return gbl_names
 
 
 -- ToDo: move to RdrName
@@ -4,13 +4,13 @@
 \section{Tidying up Core}
 
 \begin{code}
-module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, 
-       		tidyProgram, globaliseAndTidyId ) where
+module TidyPgm (
+       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
+   ) where
 
 #include "HsVersions.h"
 
 import TcRnTypes
-import FamInstEnv
 import DynFlags
 import CoreSyn
 import CoreUnfold
@@ -20,13 +20,13 @@ import CoreMonad
 import CoreUtils
 import Rules
 import CoreArity	( exprArity, exprBotStrictness_maybe )
-import Class		( classAllSelIds )
 import VarEnv
 import VarSet
 import Var
 import Id
 import IdInfo
 import InstEnv
+import FamInstEnv
 import Demand
 import BasicTypes
 import Name hiding (varName)
@@ -36,6 +36,7 @@ import NameEnv
 import TcType
 import DataCon
 import TyCon
+import Class
 import Module
 import Packages( isDllName )
 import HscTypes
@@ -117,30 +118,19 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small
 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
 mkBootModDetailsTc hsc_env 
         TcGblEnv{ tcg_exports   = exports,
-                  tcg_type_env  = type_env,
+                  tcg_type_env  = type_env, -- just for the Ids
+                  tcg_tcs       = tcs,
+                  tcg_clss      = clss,
                   tcg_insts     = insts,
                   tcg_fam_insts = fam_insts
                 }
-  = mkBootModDetails hsc_env exports type_env insts fam_insts
-
-mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails
-mkBootModDetailsDs hsc_env 
-        ModGuts{ mg_exports   = exports,
-                 mg_types     = type_env,
-                 mg_insts     = insts,
-                 mg_fam_insts = fam_insts
-                }
-  = mkBootModDetails hsc_env exports type_env insts fam_insts
-  
-mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
-                 -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
-mkBootModDetails hsc_env exports type_env insts fam_insts
-  = do	{ let dflags = hsc_dflags hsc_env 
+  = do  { let dflags = hsc_dflags hsc_env
 	; showPass dflags CoreTidy
 
 	; let { insts'     = tidyInstances globaliseAndTidyId insts
 	      ; dfun_ids   = map instanceDFunId insts'
-	      ; type_env1  = tidyBootTypeEnv (availsToNameSet exports) type_env
+              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
+                                (typeEnvIds type_env) tcs clss fam_insts
 	      ; type_env'  = extendTypeEnvWithIds type_env1 dfun_ids
 	      }
 	; return (ModDetails { md_types     = type_env'
@@ -154,21 +144,26 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
 	}
   where
 
-tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
-tidyBootTypeEnv exports type_env 
-  = tidyTypeEnv True False exports type_env final_ids
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
+mkBootTypeEnv exports ids tcs clss fam_insts
+  = tidyTypeEnv True False exports $
+       typeEnvFromEntities final_ids tcs clss fam_insts
   where
-	-- Find the LocalIds in the type env that are exported
+        -- Find the LocalIds in the type env that are exported
 	-- Make them into GlobalIds, and tidy their types
 	--
 	-- It's very important to remove the non-exported ones
 	-- because we don't tidy the OccNames, and if we don't remove
 	-- the non-exported ones we'll get many things with the
 	-- same name in the interface file, giving chaos.
-    final_ids = [ globaliseAndTidyId id
-		| id <- typeEnvIds type_env
-		, isLocalId id
-		, keep_it id ]
+        --
+        -- Do make sure that we keep Ids that are already Global.
+        -- When typechecking an .hs-boot file, the Ids come through as
+        -- GlobalIds.
+    final_ids = [ if isLocalId id then globaliseAndTidyId id
+                                  else id
+                | id <- ids
+                , keep_it id ]
 
         -- default methods have their export flag set, but everything
         -- else doesn't (yet), because this is pre-desugaring, so we
@@ -289,7 +284,8 @@ RHSs, so that they print nicely in interfaces.
 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
 tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_exports   = exports
-                              , mg_types     = type_env
+                              , mg_tcs       = tcs
+                              , mg_clss      = clss
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
                               , mg_binds     = binds
@@ -309,12 +305,16 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               }
         ; showPass dflags CoreTidy
 
-        ; let { implicit_binds = getImplicitBinds type_env }
+        ; let { type_env = typeEnvFromEntities [] tcs clss fam_insts
+
+              ; implicit_binds
+                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
+                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
+              }
 
         ; (unfold_env, tidy_occ_env)
               <- chooseExternalIds hsc_env mod omit_prags expose_all 
                                    binds implicit_binds imp_rules (vectInfoVar vect_info)
-
         ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
                 -- Glom together imp_rules and rules currently attached to binders
                 -- Then pick just the ones we need to expose
@@ -326,9 +326,11 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 	; let { export_set = availsToNameSet exports
 	      ; final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
 				    isExternalName (idName id)]
+
               ; tidy_type_env = tidyTypeEnv omit_prags th export_set
-					    type_env final_ids
-	      ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
+                                      (extendTypeEnvWithIds type_env final_ids)
+
+              ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
 		-- A DFunId will have a binding in tidy_binds, and so
 		-- will now be in final_env, replete with IdInfo
 		-- Its name will be unchanged since it was born, but
@@ -345,12 +347,21 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               -- See Note [Injecting implicit bindings]
               ; all_tidy_binds = implicit_binds ++ tidy_binds
 
+              -- get the TyCons to generate code for.  Careful!  We must use
+              -- the untidied TypeEnv here, because we need
+              --  (a) implicit TyCons arising from types and classes defined
+              --      in this module
+              --  (b) wired-in TyCons, which are normally removed from the
+              --      TypeEnv we put in the ModDetails
+              --  (c) Constructors even if they are not exported (the
+              --      tidied TypeEnv has trimmed these away)
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
 
         ; endPass dflags CoreTidy all_tidy_binds tidy_rules
 
-	  -- If the endPass didn't print the rules, but ddump-rules is on, print now
+          -- If the endPass didn't print the rules, but ddump-rules is
+          -- on, print now
 	; dumpIfSet (dopt Opt_D_dump_rules dflags 
                      && (not (dopt Opt_D_dump_simpl dflags))) 
 		    CoreTidy
@@ -374,7 +385,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                            cg_hpc_info = hpc_info,
                            cg_modBreaks = modBreaks }, 
 
-		   ModDetails { md_types     = tidy_type_env,
+                   ModDetails { md_types     = tidy_type_env,
 				md_rules     = tidy_rules,
 				md_insts     = tidy_insts,
                                 md_vect_info = tidy_vect_info,
@@ -391,40 +402,29 @@ lookup_dfun type_env dfun_id
 	_other -> pprPanic "lookup_dfun" (ppr dfun_id)
 
 --------------------------
-tidyTypeEnv :: Bool 	-- Compiling without -O, so omit prags
-	    -> Bool	-- Template Haskell is on
-	    -> NameSet -> TypeEnv -> [Id] -> TypeEnv
+tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
+            -> Bool       -- Template Haskell is on
+            -> NameSet -> TypeEnv -> TypeEnv
 
 -- The competed type environment is gotten from
---	Dropping any wired-in things, and then
--- 	a) keeping the types and classes
---	b) removing all Ids, 
---	c) adding Ids with correct IdInfo, including unfoldings,
+--      a) the types and classes defined here (plus implicit things)
+--      b) adding Ids with correct IdInfo, including unfoldings,
 --		gotten from the bindings
--- From (c) we keep only those Ids with External names;
+-- From (b) we keep only those Ids with External names;
 --	    the CoreTidy pass makes sure these are all and only
 --	    the externally-accessible ones
 -- This truncates the type environment to include only the 
 -- exported Ids and things needed from them, which saves space
 
-tidyTypeEnv omit_prags th exports type_env final_ids
- = let  type_env1 = filterNameEnv keep_it type_env
-	type_env2 = extendTypeEnvWithIds type_env1 final_ids
-	type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2
-		  | otherwise  = type_env2
-    in 
-    type_env3
-  where
-   	-- We keep GlobalIds, because they won't appear 
-	-- in the bindings from which final_ids are derived!
-	-- (The bindings bind LocalIds.)
-    keep_it thing | isWiredInThing thing = False
-    keep_it (AnId id) = isGlobalId id	-- Keep GlobalIds (e.g. class ops)
-    keep_it _other    = True		-- Keep all TyCons, DataCons, and Classes
-
---------------------------
-isWiredInThing :: TyThing -> Bool
-isWiredInThing thing = isWiredInName (getName thing)
+tidyTypeEnv omit_prags th exports type_env
+ = let
+        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
+          -- (1) remove wired-in things
+        type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1
+                  | otherwise  = type_env1
+          -- (2) trimmed if necessary
+    in
+    type_env2
 
 --------------------------
 trimThing :: Bool -> NameSet -> TyThing -> TyThing
@@ -576,16 +576,14 @@ really just a code generation trick.... binding itself makes no sense.
 See CorePrep Note [Data constructor workers].
 
 \begin{code}
-getImplicitBinds :: TypeEnv -> [CoreBind]
-getImplicitBinds type_env
-  = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
-  where
-    implicit_ids (ATyCon tc)  = class_ids ++ mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-      where class_ids = maybe [] classAllSelIds (tyConClass_maybe tc)
-    implicit_ids _            = []
-    
-    get_defn :: Id -> CoreBind
-    get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
+getTyConImplicitBinds :: TyCon -> [CoreBind]
+getTyConImplicitBinds tc = map get_defn (mapCatMaybes dataConWrapId_maybe (tyConDataCons tc))
+
+getClassImplicitBinds :: Class -> [CoreBind]
+getClassImplicitBinds cls = map get_defn (classAllSelIds cls)
+
+get_defn :: Id -> CoreBind
+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
 \end{code}
 
 
@@ -51,14 +51,10 @@ module PrelNames (
 
 import Module
 import OccName
-import RdrName    ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual )
-import Unique     ( Unique, Uniquable(..), hasKey,
-                    mkPreludeMiscIdUnique, mkPreludeDataConUnique,
-                    mkPreludeTyConUnique, mkPreludeClassUnique,
-                    mkTupleTyConUnique
-                  )
-import BasicTypes ( TupleSort(..), Arity )
-import Name       ( Name, mkInternalName, mkExternalName, mkSystemVarName )
+import RdrName
+import Unique
+import BasicTypes
+import Name
 import SrcLoc
 import FastString
 \end{code}
@@ -397,6 +397,7 @@ extendGlobalRdrEnvRn :: [AvailInfo]
 extendGlobalRdrEnvRn avails new_fixities
   = do  { (gbl_env, lcl_env) <- getEnvs
         ; stage <- getStage
+        ; isGHCi <- getIsGHCi
         ; let rdr_env = tcg_rdr_env gbl_env
               fix_env = tcg_fix_env gbl_env
 
@@ -406,10 +407,12 @@ extendGlobalRdrEnvRn avails new_fixities
               -- See Note [Top-level Names in Template Haskell decl quotes]
               shadowP  = isBrackStage stage
               new_occs = map (nameOccName . gre_name) gres
-              rdr_env1 = transformGREs qual_gre new_occs rdr_env
+              rdr_env_TH = transformGREs qual_gre new_occs rdr_env
+              rdr_env_GHCi = delListFromOccEnv rdr_env new_occs
               lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs }
-              (rdr_env2, lcl_env2) | shadowP   = (rdr_env1, lcl_env1)
-                                   | otherwise = (rdr_env,  lcl_env)
+              (rdr_env2, lcl_env2) | shadowP   = (rdr_env_TH,   lcl_env1)
+                                   | isGHCi    = (rdr_env_GHCi, lcl_env1)
+                                   | otherwise = (rdr_env,      lcl_env)
 
               rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres
               fix_env' = foldl extend_fix_env     fix_env  gres
@@ -802,20 +805,6 @@ catMaybeErr ms =  [ a | Succeeded a <- ms ]
 %************************************************************************
 
 \begin{code}
--- | make a 'GlobalRdrEnv' where all the elements point to the same
--- import declaration (useful for "hiding" imports, or imports with
--- no details).
-gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
-gresFromAvails prov avails
-  = concatMap (gresFromAvail (const prov)) avails
-
-gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
-gresFromAvail prov_fn avail
-  = [ GRE {gre_name = n,
-           gre_par = availParent n avail,
-           gre_prov = prov_fn n}
-    | n <- availNames avail ]
-
 greExportAvail :: GlobalRdrElt -> AvailInfo
 greExportAvail gre 
   = case gre_par gre of
@@ -840,11 +829,6 @@ plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
        (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 
-availParent :: Name -> AvailInfo -> Parent
-availParent _ (Avail _)                 = NoParent
-availParent n (AvailTC m _) | n == m    = NoParent
-                            | otherwise = ParentIs m
-
 trimAvail :: AvailInfo -> Name -> AvailInfo
 trimAvail (Avail n)      _ = Avail n
 trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
@@ -1734,8 +1718,13 @@ addDupDeclErr []
 addDupDeclErr names@(name : _)
   = addErrAt (getSrcSpan (last sorted_names)) $
     -- Report the error at the later location
-    vcat [ptext (sLit "Multiple declarations of") <+> quotes (ppr name),
-          ptext (sLit "Declared at:") <+> vcat (map (ppr . nameSrcLoc) sorted_names)]
+    vcat [ptext (sLit "Multiple declarations of") <+>
+             quotes (ppr (nameOccName name)),
+             -- NB. print the OccName, not the Name, because the
+             -- latter might not be in scope in the RdrEnv and so will
+             -- be printed qualified.
+          ptext (sLit "Declared at:") <+>
+                   vcat (map (ppr . nameSrcLoc) sorted_names)]
   where
     sorted_names = sortWith nameSrcLoc names
 
@@ -163,6 +163,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
+    last_tcg_env <- getGblEnv ;
    -- (I) Compute the results and return
    let {rn_group = HsGroup { hs_valds  	= rn_val_decls,
 			     hs_tyclds 	= rn_tycl_decls,
@@ -189,7 +190,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 		-- Instance decls may have occurrences of things bound in bind_dus
 		-- so we must put other_fvs last
 
-        final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
+        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
                         in -- we return the deprecs in the env, not in the HsGroup above
                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
        } ;
@@ -147,18 +147,25 @@ tcExtendLocalFamInstEnv fam_insts thing_inside
 -- Check that the proposed new instance is OK, 
 -- and then add it to the home inst env
 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
-addLocalFamInst home_fie famInst
-  = do {       -- Load imported instances, so that we report
-	       -- overlaps correctly
-       ; eps <- getEps
-       ; let inst_envs = (eps_fam_inst_env eps, home_fie)
-
-	       -- Check for conflicting instance decls
-       ; checkForConflicts inst_envs famInst
-
-	       -- OK, now extend the envt
-       ; return (extendFamInstEnv home_fie famInst) 
-       }
+addLocalFamInst home_fie famInst = do
+        -- Load imported instances, so that we report
+        -- overlaps correctly
+    eps <- getEps
+    let inst_envs = (eps_fam_inst_env eps, home_fie)
+
+        -- Check for conflicting instance decls
+    skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
+    let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
+    -- If there are any conflicts, we should probably error
+    -- But, if we're allowed to overwrite and the conflict is in the home FIE,
+    -- then overwrite instead of error.
+    isGHCi <- getIsGHCi
+    case conflicts of
+        dup : _ ->  case (isGHCi, home_conflicts) of
+                        (True, _ : _) -> return (overwriteFamInstEnv home_fie famInst)
+                        (_, _)        -> conflictInstErr famInst (fst dup) >> return (extendFamInstEnv home_fie famInst)
+                    where home_conflicts = lookupFamInstEnvConflicts' home_fie famInst skol_tvs
+        []      ->  return (extendFamInstEnv home_fie famInst)
 \end{code}
 
 %************************************************************************
@@ -186,7 +193,6 @@ checkForConflicts inst_envs famInst
        ; unless (null conflicts) $
 	   conflictInstErr famInst (fst (head conflicts))
        }
-  where
 
 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 conflictInstErr famInst conflictingFamInst
@@ -399,52 +399,65 @@ tcExtendLocalInstEnv dfuns thing_inside
 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 -- Check that the proposed new instance is OK, 
 -- and then add it to the home inst env
-addLocalInst home_ie ispec
-  = do	{ 	-- Instantiate the dfun type so that we extend the instance
-		-- envt with completely fresh template variables
-		-- This is important because the template variables must
-		-- not overlap with anything in the things being looked up
-		-- (since we do unification).  
-                --
-                -- We use tcInstSkolType because we don't want to allocate fresh
-                --  *meta* type variables.
-                --
-                -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
-                -- these variables must be bindable by tcUnifyTys.  See
-                -- the call to tcUnifyTys in InstEnv, and the special
-                -- treatment that instanceBindFun gives to isOverlappableTyVar
-                -- This is absurdly delicate.
-
-	  let dfun = instanceDFunId ispec
-        ; (tvs', theta', tau') <- tcInstSkolType (idType dfun)
-	; let	(cls, tys') = tcSplitDFunHead tau'
-		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
-	  	ispec'      = setInstanceDFunId ispec dfun'
-
-		-- Load imported instances, so that we report
-		-- duplicates correctly
-	; eps <- getEps
-	; let inst_envs = (eps_inst_env eps, home_ie)
-
-		-- Check functional dependencies
-	; case checkFunDeps inst_envs ispec' of
-		Just specs -> funDepErr ispec' specs
-		Nothing    -> return ()
-
-		-- Check for duplicate instance decls
-	; let { (matches, _, _) = lookupInstEnv inst_envs cls tys'
-	      ;	dup_ispecs = [ dup_ispec 
-			     | (dup_ispec, _) <- matches
-			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
-			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-		-- Find memebers of the match list which ispec itself matches.
-		-- If the match is 2-way, it's a duplicate
-	; case dup_ispecs of
-	    dup_ispec : _ -> dupInstErr ispec' dup_ispec
-	    []            -> return ()
-
-		-- OK, now extend the envt
-	; return (extendInstEnv home_ie ispec') }
+-- If overwrite_inst, then we can overwrite a direct match
+addLocalInst home_ie ispec = do
+    -- Instantiate the dfun type so that we extend the instance
+    -- envt with completely fresh template variables
+    -- This is important because the template variables must
+    -- not overlap with anything in the things being looked up
+    -- (since we do unification).  
+        --
+        -- We use tcInstSkolType because we don't want to allocate fresh
+        --  *meta* type variables.
+        --
+        -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
+        -- these variables must be bindable by tcUnifyTys.  See
+        -- the call to tcUnifyTys in InstEnv, and the special
+        -- treatment that instanceBindFun gives to isOverlappableTyVar
+        -- This is absurdly delicate.
+
+    let dfun = instanceDFunId ispec
+    (tvs', theta', tau') <- tcInstSkolType (idType dfun)
+    let (cls, tys') = tcSplitDFunHead tau'
+        dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
+        ispec'      = setInstanceDFunId ispec dfun'
+
+        -- Load imported instances, so that we report
+        -- duplicates correctly
+    eps <- getEps
+    let inst_envs = (eps_inst_env eps, home_ie)
+
+        -- Check functional dependencies
+    case checkFunDeps inst_envs ispec' of
+        Just specs -> funDepErr ispec' specs
+        Nothing    -> return ()
+
+        -- Check for duplicate instance decls
+    let (matches, unifs, _) = lookupInstEnv inst_envs cls tys'
+        dup_ispecs = [ dup_ispec 
+                        | (dup_ispec, _) <- matches
+                        , let (_,_,_,dup_tys) = instanceHead dup_ispec
+                        , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)]
+                        
+        -- Find memebers of the match list which ispec itself matches.
+        -- If the match is 2-way, it's a duplicate
+        -- If it's a duplicate, but we can overwrite home package dups, then overwrite
+    isGHCi <- getIsGHCi
+    overlapFlag <- getOverlapFlag
+    case isGHCi of
+        False -> case dup_ispecs of
+            dup : _ -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec')
+            []      -> return (extendInstEnv home_ie ispec')
+        True  -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of
+            (_, _:_, _, _)      -> return (overwriteInstEnv home_ie ispec')
+            (dup:_, [], _, _)   -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec')
+            ([], _, u:_, NoOverlap _)    -> overlappingInstErr ispec' u >> return (extendInstEnv home_ie ispec')
+            _                   -> return (extendInstEnv home_ie ispec')
+          where (homematches, _) = lookupInstEnv' home_ie cls tys'
+                home_ie_matches = [ dup_ispec 
+                    | (dup_ispec, _) <- homematches
+                    , let (_,_,_,dup_tys) = instanceHead dup_ispec
+                    , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)]
 
 traceDFuns :: [Instance] -> TcRn ()
 traceDFuns ispecs
@@ -463,6 +476,11 @@ dupInstErr ispec dup_ispec
   = addDictLoc ispec $
     addErr (hang (ptext (sLit "Duplicate instance declarations:"))
 	       2 (pprInstances [ispec, dup_ispec]))
+overlappingInstErr :: Instance -> Instance -> TcRn ()
+overlappingInstErr ispec dup_ispec
+  = addDictLoc ispec $
+    addErr (hang (ptext (sLit "Overlapping instance declarations:"))
+	       2 (pprInstances [ispec, dup_ispec]))
 
 addDictLoc :: Instance -> TcRn a -> TcRn a
 addDictLoc ispec thing_inside
@@ -12,7 +12,7 @@ module TcEnv(
 	InstBindings(..),
 
 	-- Global environment
-	tcExtendGlobalEnv, setGlobalTypeEnv,
+        tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
 	tcExtendGlobalValEnv,
 	tcLookupLocatedGlobal,	tcLookupGlobal, 
 	tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
@@ -274,10 +274,28 @@ setGlobalTypeEnv tcg_env new_type_env
     	   writeMutVar (tcg_type_env_var tcg_env) new_type_env
 	 ; return (tcg_env { tcg_type_env = new_type_env }) }
 
+
 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-  -- Given a mixture of Ids, TyCons, Classes, all from the
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
   -- module being compiled, extend the global environment
 tcExtendGlobalEnv things thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs  = [ tc | ATyCon tc <- things,
+                                            not (isClassTyCon tc)]
+                                      ++ tcg_tcs env
+                        , tcg_clss = [ cl | ATyCon tc <- things,
+                                            Just cl <- [tyConClass_maybe tc]]
+                                      ++ tcg_clss env }
+       ; setGblEnv env' $
+            tcExtendGlobalEnvImplicit things thing_inside
+       }
+
+tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
+  -- Extend the global environment with some TyThings that can be obtained
+  -- via implicitTyThings from other entities in the environment.  Examples
+  -- are dfuns, famInstTyCons, data cons, etc.
+  -- These TyThings are not added to tcg_tcs or tcg_clss.
+tcExtendGlobalEnvImplicit things thing_inside
    = do	{ tcg_env <- getGblEnv
 	; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
 	; tcg_env' <- setGlobalTypeEnv tcg_env ge'
@@ -361,7 +361,7 @@ tcInstDecls1    -- Deal with both source-code and imported instance decls
                                 -- contains all dfuns for this module
            HsValBinds Name)     -- Supporting bindings for derived instances
 
-tcInstDecls1 tycl_decls inst_decls deriv_decls
+tcInstDecls1 tycl_decls inst_decls deriv_decls 
   = checkNoErrs $
     do {        -- Stop if addInstInfos etc discovers any errors
                 -- (they recover, so that we get more than one error each
@@ -380,7 +380,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 
                 -- (2) Add the tycons of indexed types and their implicit
                 --     tythings to the global environment
-       ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
+       ; tcExtendGlobalEnvImplicit
+             (map ATyCon at_idx_tycons ++ implicit_things) $ do {
 
 
                 -- Next, construct the instance environment so far, consisting
@@ -405,7 +406,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        -- the generic representation
        ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
        ; gbl_env <- tcExtendGlobalEnv all_tycons $
-                    tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+                    tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
                     addFamInsts deriv_ty_insts $
                     addInsts deriv_inst_info getGblEnv
 
@@ -10,6 +10,7 @@ module TcRnDriver (
 	tcRnStmt, tcRnExpr, tcRnType,
 	tcRnLookupRdrName,
 	getModuleInterface,
+	tcRnDeclsi,
 #endif
 	tcRnImports,
 	tcRnLookupName,
@@ -336,36 +337,34 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 	my_exports = map (Avail . idName) bndrs ;
 		-- ToDo: export the data types also?
 
-	final_type_env = 
-             extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
-
         mod_guts = ModGuts {    mg_module    = this_mod,
-				mg_boot	     = False,
-				mg_used_names = emptyNameSet, -- ToDo: compute usage
+                                mg_boot	     = False,
+                                mg_used_names = emptyNameSet, -- ToDo: compute usage
                                 mg_used_th   = False,
                                 mg_dir_imps  = emptyModuleEnv, -- ??
-				mg_deps      = noDependencies,	-- ??
-				mg_exports   = my_exports,
-				mg_types     = final_type_env,
-				mg_insts     = tcg_insts tcg_env,
-				mg_fam_insts = tcg_fam_insts tcg_env,
-				mg_inst_env  = tcg_inst_env tcg_env,
-				mg_fam_inst_env = tcg_fam_inst_env tcg_env,
-				mg_rules     = [],
-				mg_vect_decls = [],
-				mg_anns      = [],
-				mg_binds     = core_binds,
-
-				-- Stubs
-				mg_rdr_env   = emptyGlobalRdrEnv,
-				mg_fix_env   = emptyFixityEnv,
-				mg_warns     = NoWarnings,
-				mg_foreign   = NoStubs,
-				mg_hpc_info  = emptyHpcInfo False,
+                                mg_deps      = noDependencies,	-- ??
+                                mg_exports   = my_exports,
+                                mg_tcs       = tcg_tcs tcg_env,
+                                mg_clss      = tcg_clss tcg_env,
+                                mg_insts     = tcg_insts tcg_env,
+                                mg_fam_insts = tcg_fam_insts tcg_env,
+                                mg_inst_env  = tcg_inst_env tcg_env,
+                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
+                                mg_rules     = [],
+                                mg_vect_decls = [],
+                                mg_anns      = [],