Permalink
Browse files

Add support for all top-level declarations to GHCi

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

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

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

Tests are in testsuite/tests/ghci/scripts/ghci039--ghci054.
Documentation to follow.
  • Loading branch information...
1 parent 9de6f19 commit 3db757241ce7fb99c096c30481aefa86bb9855a1 @simonmar simonmar committed Sep 16, 2011
@@ -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
Oops, something went wrong. Retry.

0 comments on commit 3db7572

Please sign in to comment.