Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
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
simonmar committed Sep 21, 2011
1 parent 9de6f19 commit 3db7572
Show file tree
Hide file tree
Showing 35 changed files with 1,255 additions and 642 deletions.
2 changes: 2 additions & 0 deletions compiler/basicTypes/DataCon.lhs-boot
Expand Up @@ -5,4 +5,6 @@ import Name( Name )
data DataCon
dataConName :: DataCon -> Name
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
instance Ord DataCon
\end{code}
18 changes: 9 additions & 9 deletions compiler/basicTypes/Name.lhs
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
4 changes: 4 additions & 0 deletions compiler/basicTypes/Name.lhs-boot
@@ -1,5 +1,9 @@
\begin{code}
module Name where

import {-# SOURCE #-} Module

data Name

nameModule :: Name -> Module
\end{code}
5 changes: 4 additions & 1 deletion compiler/basicTypes/RdrName.lhs
Expand Up @@ -66,6 +66,7 @@ import Maybes
import SrcLoc
import FastString
import Outputable
import Unique
import Util
import StaticFlags( opt_PprStyle_Debug )
Expand Down Expand Up @@ -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
Expand Down
66 changes: 34 additions & 32 deletions compiler/deSugar/Desugar.lhs
Expand Up @@ -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 })
Expand All @@ -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
Expand Down Expand Up @@ -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,
Expand Down
2 changes: 1 addition & 1 deletion compiler/ghci/ByteCodeLink.lhs
Expand Up @@ -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,"
Expand Down
25 changes: 11 additions & 14 deletions compiler/ghci/Debugger.hs
Expand Up @@ -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
Expand All @@ -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'
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
61 changes: 55 additions & 6 deletions compiler/ghci/Linker.lhs
Expand Up @@ -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,
Expand Down Expand Up @@ -52,6 +52,7 @@ import UniqSet
import FastString
import Config
import SysTools
import PrelNames
-- Standard libraries
import Control.Monad
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 3db7572

Please sign in to comment.