Commit 3db75724 authored by Simon Marlow's avatar Simon Marlow

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.
parent 9de6f19e
...@@ -5,4 +5,6 @@ import Name( Name ) ...@@ -5,4 +5,6 @@ import Name( Name )
data DataCon data DataCon
dataConName :: DataCon -> Name dataConName :: DataCon -> Name
isVanillaDataCon :: DataCon -> Bool isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
instance Ord DataCon
\end{code} \end{code}
...@@ -435,17 +435,17 @@ instance OutputableBndr Name where ...@@ -435,17 +435,17 @@ instance OutputableBndr Name where
pprBndr _ name = pprName name pprBndr _ name = pprName name
pprName :: Name -> SDoc 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 -> = getPprStyle $ \ sty ->
case sort of case sort of
WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin WiredIn mod _ builtin -> pprExternal sty uniq mod occ n True builtin
External mod -> pprExternal sty uniq mod occ False UserSyntax External mod -> pprExternal sty uniq mod occ n False UserSyntax
System -> pprSystem sty uniq occ System -> pprSystem sty uniq occ
Internal -> pprInternal sty uniq occ Internal -> pprInternal sty uniq occ
where uniq = mkUniqueGrimily (iBox u) where uniq = mkUniqueGrimily (iBox u)
pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc
pprExternal sty uniq mod occ is_wired is_builtin pprExternal sty uniq mod occ name is_wired is_builtin
| codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
-- In code style, always qualify -- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified -- ToDo: maybe we could print all wired-in things unqualified
...@@ -455,7 +455,7 @@ pprExternal sty uniq mod occ is_wired is_builtin ...@@ -455,7 +455,7 @@ pprExternal sty uniq mod occ is_wired is_builtin
pprNameSpaceBrief (occNameSpace occ), pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq]) pprUnique uniq])
| BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax | 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 where
pp_mod | opt_SuppressModulePrefixes = empty pp_mod | opt_SuppressModulePrefixes = empty
| otherwise = ppr mod <> dot | otherwise = ppr mod <> dot
...@@ -482,14 +482,14 @@ pprSystem sty uniq occ ...@@ -482,14 +482,14 @@ pprSystem sty uniq occ
-- so print the unique -- 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 -- Print the "M." part of a name, based on whether it's in scope or not
-- See Note [Printing original names] in HscTypes -- See Note [Printing original names] in HscTypes
pprModulePrefix sty mod occ pprModulePrefix sty mod name
| opt_SuppressModulePrefixes = empty | opt_SuppressModulePrefixes = empty
| otherwise | 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 NameQual modname -> ppr modname <> dot -- Name is in scope
NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope
NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in
......
\begin{code} \begin{code}
module Name where module Name where
import {-# SOURCE #-} Module
data Name data Name
nameModule :: Name -> Module
\end{code} \end{code}
...@@ -66,6 +66,7 @@ import Maybes ...@@ -66,6 +66,7 @@ import Maybes
import SrcLoc import SrcLoc
import FastString import FastString
import Outputable import Outputable
import Unique
import Util import Util
import StaticFlags( opt_PprStyle_Debug ) import StaticFlags( opt_PprStyle_Debug )
...@@ -247,7 +248,9 @@ instance Outputable RdrName where ...@@ -247,7 +248,9 @@ instance Outputable RdrName where
ppr (Exact name) = ppr name ppr (Exact name) = ppr name
ppr (Unqual occ) = ppr occ ppr (Unqual occ) = ppr occ
ppr (Qual mod occ) = ppr mod <> dot <> 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 instance OutputableBndr RdrName where
pprBndr _ n pprBndr _ n
......
...@@ -56,24 +56,26 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) ...@@ -56,24 +56,26 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
deSugar hsc_env deSugar hsc_env
mod_loc mod_loc
tcg_env@(TcGblEnv { tcg_mod = mod, tcg_env@(TcGblEnv { tcg_mod = mod,
tcg_src = hsc_src, tcg_src = hsc_src,
tcg_type_env = type_env, tcg_type_env = type_env,
tcg_imports = imports, tcg_imports = imports,
tcg_exports = exports, tcg_exports = exports,
tcg_keep = keep_var, tcg_keep = keep_var,
tcg_th_splice_used = tc_splice_used, tcg_th_splice_used = tc_splice_used,
tcg_rdr_env = rdr_env, tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env, tcg_fix_env = fix_env,
tcg_inst_env = inst_env, tcg_inst_env = inst_env,
tcg_fam_inst_env = fam_inst_env, tcg_fam_inst_env = fam_inst_env,
tcg_warns = warns, tcg_warns = warns,
tcg_anns = anns, tcg_anns = anns,
tcg_binds = binds, tcg_binds = binds,
tcg_imp_specs = imp_specs, tcg_imp_specs = imp_specs,
tcg_ev_binds = ev_binds, tcg_ev_binds = ev_binds,
tcg_fords = fords, tcg_fords = fords,
tcg_rules = rules, tcg_rules = rules,
tcg_vects = vects, tcg_vects = vects,
tcg_tcs = tcs,
tcg_clss = clss,
tcg_insts = insts, tcg_insts = insts,
tcg_fam_insts = fam_insts, tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info }) tcg_hpc = other_hpc_info })
...@@ -96,8 +98,7 @@ deSugar hsc_env ...@@ -96,8 +98,7 @@ deSugar hsc_env
<- if (opt_Hpc <- if (opt_Hpc
|| target == HscInterpreted) || target == HscInterpreted)
&& (not (isHsBoot hsc_src)) && (not (isHsBoot hsc_src))
then addCoverageTicksToBinds dflags mod mod_loc then addCoverageTicksToBinds dflags mod mod_loc tcs binds
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks) else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do initDs hsc_env mod rdr_env type_env $ do
do { ds_ev_binds <- dsEvBinds ev_binds do { ds_ev_binds <- dsEvBinds ev_binds
...@@ -151,26 +152,27 @@ deSugar hsc_env ...@@ -151,26 +152,27 @@ deSugar hsc_env
; used_th <- readIORef tc_splice_used ; used_th <- readIORef tc_splice_used
; let mod_guts = ModGuts { ; let mod_guts = ModGuts {
mg_module = mod, mg_module = mod,
mg_boot = isHsBoot hsc_src, mg_boot = isHsBoot hsc_src,
mg_exports = exports, mg_exports = exports,
mg_deps = deps, mg_deps = deps,
mg_used_names = used_names, mg_used_names = used_names,
mg_used_th = used_th, mg_used_th = used_th,
mg_dir_imps = imp_mods imports, mg_dir_imps = imp_mods imports,
mg_rdr_env = rdr_env, mg_rdr_env = rdr_env,
mg_fix_env = fix_env, mg_fix_env = fix_env,
mg_warns = warns, mg_warns = warns,
mg_anns = anns, mg_anns = anns,
mg_types = type_env, mg_tcs = tcs,
mg_insts = insts, mg_clss = clss,
mg_fam_insts = fam_insts, mg_insts = insts,
mg_inst_env = inst_env, mg_fam_insts = fam_insts,
mg_fam_inst_env = fam_inst_env, mg_inst_env = inst_env,
mg_rules = ds_rules_for_imps, mg_fam_inst_env = fam_inst_env,
mg_binds = ds_binds, mg_rules = ds_rules_for_imps,
mg_foreign = ds_fords, mg_binds = ds_binds,
mg_hpc_info = ds_hpc_info, mg_foreign = ds_fords,
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks, mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects, mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo, mg_vect_info = noVectInfo,
......
...@@ -254,7 +254,7 @@ lookupIE ie con_nm ...@@ -254,7 +254,7 @@ lookupIE ie con_nm
linkFail :: String -> String -> IO a linkFail :: String -> String -> IO a
linkFail who what linkFail who what
= ghcError (ProgramError $ = ghcError (ProgramError $
unlines [ "" unlines [ "",who
, "During interactive linking, GHCi couldn't find the following symbol:" , "During interactive linking, GHCi couldn't find the following symbol:"
, ' ' : ' ' : what , ' ' : ' ' : what
, "This may be due to you not asking GHCi to load extra object files," , "This may be due to you not asking GHCi to load extra object files,"
......
...@@ -87,7 +87,7 @@ pprintClosureCommand bindThings force str = do ...@@ -87,7 +87,7 @@ pprintClosureCommand bindThings force str = do
tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars :: GhcMonad m => Term -> m Term
tidyTermTyVars t = tidyTermTyVars t =
withSession $ \hsc_env -> do 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 my_tvs = termTyVars t
tvs = env_tvs `minusVarSet` my_tvs tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName tyvarOccName = nameOccName . tyVarName
...@@ -110,7 +110,7 @@ bindSuspensions t = do ...@@ -110,7 +110,7 @@ bindSuspensions t = do
let (names, tys, hvals) = unzip3 stuff let (names, tys, hvals) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys] | (name,ty) <- zip names tys]
new_ic = extendInteractiveContext ictxt ids new_ic = extendInteractiveContext ictxt (map AnId ids)
liftIO $ extendLinkEnv (zip names hvals) liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic } modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t' return t'
...@@ -187,10 +187,8 @@ showTerm term = do ...@@ -187,10 +187,8 @@ showTerm term = do
bindToFreshName hsc_env ty userName = do bindToFreshName hsc_env ty userName = do
name <- newGrimName userName name <- newGrimName userName
let ictxt = hsc_IC hsc_env let id = AnId $ mkVanillaGlobal name ty
tmp_ids = ic_tmp_ids ictxt new_ic = extendInteractiveContext (hsc_IC hsc_env) [id]
id = mkVanillaGlobal name ty
new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name) return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names -- Create new uniques and give them sequentially numbered names
...@@ -202,20 +200,19 @@ newGrimName userName = do ...@@ -202,20 +200,19 @@ newGrimName userName = do
name = mkInternalName unique occname noSrcSpan name = mkInternalName unique occname noSrcSpan
return name return name
pprTypeAndContents :: GhcMonad m => [Id] -> m SDoc pprTypeAndContents :: GhcMonad m => Id -> m SDoc
pprTypeAndContents ids = do pprTypeAndContents id = do
dflags <- GHC.getSessionDynFlags dflags <- GHC.getSessionDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags let pefas = dopt Opt_PrintExplicitForalls dflags
pcontents = dopt Opt_PrintBindContents dflags pcontents = dopt Opt_PrintBindContents dflags
pprdId = (pprTyThing pefas . AnId) id
if pcontents if pcontents
then do then do
let depthBound = 100 let depthBound = 100
terms <- mapM (GHC.obtainTermFromId depthBound False) ids term <- GHC.obtainTermFromId depthBound False id
docs_terms <- mapM showTerm terms docs_term <- showTerm term
return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) return $ pprdId <+> equals <+> docs_term
(map (pprTyThing pefas . AnId) ids) else return pprdId
docs_terms
else return $ vcat $ map (pprTyThing pefas . AnId) ids
-------------------------------------------------------------- --------------------------------------------------------------
-- Utils -- Utils
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
-- -fno-cse is needed for GLOBAL_VAR's to behave properly -- -fno-cse is needed for GLOBAL_VAR's to behave properly
module Linker ( HValue, getHValue, showLinkerState, module Linker ( HValue, getHValue, showLinkerState,
linkExpr, unload, withExtendedLinkEnv, linkExpr, linkDecls, unload, withExtendedLinkEnv,
extendLinkEnv, deleteFromLinkEnv, extendLinkEnv, deleteFromLinkEnv,
extendLoadedPkgs, extendLoadedPkgs,
linkPackages,initDynLinker,linkModule, linkPackages,initDynLinker,linkModule,
...@@ -52,6 +52,7 @@ import UniqSet ...@@ -52,6 +52,7 @@ import UniqSet
import FastString import FastString
import Config import Config
import SysTools import SysTools
import PrelNames
-- Standard libraries -- Standard libraries
import Control.Monad import Control.Monad
...@@ -427,9 +428,9 @@ linkExpr hsc_env span root_ul_bco ...@@ -427,9 +428,9 @@ linkExpr hsc_env span root_ul_bco
needed_mods :: [Module] needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names, needed_mods = [ nameModule n | n <- free_names,
isExternalName n, -- Names from other modules isExternalName n, -- Names from other modules
not (isWiredInName n) -- Exclude wired-in names not (isWiredInName n) -- Exclude wired-in names
] -- (see note below) ] -- (see note below)
-- Exclude wired-in names because we may not have read -- Exclude wired-in names because we may not have read
-- their interface files, so getLinkDeps will fail -- their interface files, so getLinkDeps will fail
-- All wired-in names are in the base package, which we link -- 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,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 -- Find all the packages and linkables that a set of modules depends on
= do { = do {
-- 1. Find the dependent home-pkg-modules/packages from each iface -- 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 { let {
-- 2. Exclude ones already linked -- 2. Exclude ones already linked
...@@ -488,7 +491,6 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods ...@@ -488,7 +491,6 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
(objs_loaded pls ++ bcos_loaded pls) (objs_loaded pls ++ bcos_loaded pls)
} ; } ;
-- putStrLn (showSDoc (ppr mods_s)) ;
-- 3. For each dependent module, find its linkable -- 3. For each dependent module, find its linkable
-- This will either be in the HPT or (in the case of one-shot -- This will either be in the HPT or (in the case of one-shot
-- compilation) we may need to use maybe_getFileLinkable -- compilation) we may need to use maybe_getFileLinkable
...@@ -594,6 +596,53 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods ...@@ -594,6 +596,53 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
adjust_ul _ _ = panic "adjust_ul" adjust_ul _ _ = panic "adjust_ul"
\end{code} \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 Loading a single module
......
...@@ -71,39 +71,49 @@ allocateGlobalBinder ...@@ -71,39 +71,49 @@ allocateGlobalBinder
-> (NameCache, Name) -> (NameCache, Name)
allocateGlobalBinder name_supply mod occ loc allocateGlobalBinder name_supply mod occ loc
= case lookupOrigNameCache (nsNames name_supply) mod occ of = case lookupOrigNameCache (nsNames name_supply) mod occ of
-- A hit in the cache! We are at the binding site of the name. -- A hit in the cache! We are at the binding site of the name.
-- This is the moment when we know the SrcLoc -- This is the moment when we know the SrcLoc
-- of the Name, so we set this field in the Name we return. -- of the Name, so we set this field in the Name we return.
-- --
-- Then (bogus) multiple bindings of the same Name -- Then (bogus) multiple bindings of the same Name
-- get different SrcLocs can can be reported as such. -- get different SrcLocs can can be reported as such.
-- --
-- Possible other reason: it might be in the cache because we -- Possible other reason: it might be in the cache because we
-- encountered an occurrence before the binding site for an -- encountered an occurrence before the binding site for an
-- implicitly-imported Name. Perhaps the current SrcLoc is -- implicitly-imported Name. Perhaps the current SrcLoc is
-- better... but not really: it'll still just say 'imported' -- better... but not really: it'll still just say 'imported'
-- --
-- IMPORTANT: Don't mess with wired-in names. -- IMPORTANT: Don't mess with wired-in names.
-- Their wired-in-ness is in their NameSort -- Their wired-in-ness is in their NameSort
-- and their Module is correct. -- and their Module is correct.
Just name | isWiredInName name -> (name_supply, name) Just name | isWiredInName name -> (name_supply, name)
| otherwise -> (new_name_supply, name') | mod /= iNTERACTIVE -> (new_name_supply, name')
where -- Note [interactive name cache]
uniq = nameUnique name where
name' = mkExternalName uniq mod occ loc uniq = nameUnique name
new_cache = extendNameCache (nsNames name_supply) mod occ name' name' = mkExternalName uniq mod occ loc
new_name_supply = name_supply {nsNames = new_cache} 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 -- Miss in the cache!
Nothing -> (new_name_supply, name) -- Build a completely new Name, and put it in the cache
where _ -> (new_name_supply, name)
(uniq, us') = takeUniqFromSupply (nsUniqs name_supply) where
name = mkExternalName uniq mod occ loc (uniq, us') = takeUniqFromSupply (nsUniqs name_supply)
new_cache = extendNameCache (nsNames name_supply) mod occ name name = mkExternalName uniq mod occ loc
new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} 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 newImplicitBinder :: Name -- Base name
-> (OccName -> OccName) -- Occurrence name modifier -> (OccName -> OccName) -- Occurrence name modifier
......
...@@ -80,7 +80,7 @@ module GHC ( ...@@ -80,7 +80,7 @@ module GHC (
PrintUnqualified, alwaysQualify, PrintUnqualified, alwaysQualify,
-- * Interactive evaluation -- * Interactive evaluation
getBindings, getPrintUnqual, getBindings, getInsts, getPrintUnqual,
findModule, findModule,
lookupModule, lookupModule,
#ifdef GHCI #ifdef GHCI
...@@ -94,7 +94,7 @@ module GHC ( ...@@ -94,7 +94,7 @@ module GHC (
typeKind, typeKind,
parseName, parseName,
RunResult(..), RunResult(..),
runStmt, runStmtWithLocation, runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
parseImportDecl, SingleStep(..), parseImportDecl, SingleStep(..),
resume, resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
...@@ -166,7 +166,9 @@ module GHC ( ...@@ -166,7 +166,9 @@ module GHC (
-- ** Instances -- ** Instances
Instance, Instance,
instanceDFunId, pprInstance, pprInstanceHdr, instanceDFunId,
pprInstance, pprInstanceHdr,
pprFamInst, pprFamInstHdr,
-- ** Types and Kinds -- ** Types and Kinds
Type, splitForAllTys, funResultTy, Type, splitForAllTys, funResultTy,
...@@ -264,8 +266,9 @@ import Class ...@@ -264,8 +266,9 @@ import Class
import DataCon import DataCon
import Name hiding ( varName ) import Name hiding ( varName )
import InstEnv import InstEnv
import FamInstEnv
import SrcLoc import SrcLoc
import CoreSyn ( CoreBind ) import CoreSyn
import TidyPgm import TidyPgm
import DriverPhases ( Phase(..), isHaskellSrcFilename ) import DriverPhases ( Phase(..), isHaskellSrcFilename )
import Finder import Finder
...@@ -864,11 +867,15 @@ compileCore simplify fn = do ...@@ -864,11 +867,15 @@ compileCore simplify fn = do
-- we just have a ModGuts. -- we just have a ModGuts.
gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule (Left (cg, md)) = 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 cm_binds = cg_binds cg
} }
gutsToCoreModule (Right mg) = CoreModule { 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 cm_binds = mg_binds mg
} }
...@@ -899,13 +906,12 @@ isLoaded m = withSession $ \hsc_env -> ...@@ -899,13 +906,12 @@ isLoaded m = withSession $ \hsc_env ->
-- | Return the bindings for the current interactive session. -- | Return the bindings for the current interactive session.
getBindings :: GhcMonad m => m [TyThing] getBindings :: GhcMonad m => m [TyThing]
getBindings = withSession $ \hsc_env -> getBindings = withSession $ \hsc_env ->
-- we have to implement the shadowing behaviour of ic_tmp_ids here return $ icInScopeTTs $ hsc_IC hsc_env
-- (see InteractiveContext) and the quickest way is to use an OccEnv.
let -- | Return the instances for the current interactive session.
occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) getInsts :: GhcMonad m => m ([Instance], [FamInst])
| id <- ic_tmp_ids (hsc_IC hsc_env) ] getInsts = withSession $ \hsc_env ->
in return $ ic_instances (hsc_IC hsc_env)
return (occEnvElts occ_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env -> getPrintUnqual = withSession $ \hsc_env ->
......