Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
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...
commit 3db757241ce7fb99c096c30481aefa86bb9855a1 1 parent 9de6f19
@simonmar simonmar authored
Showing with 1,255 additions and 642 deletions.
  1. +2 −0  compiler/basicTypes/DataCon.lhs-boot
  2. +9 −9 compiler/basicTypes/Name.lhs
  3. +4 −0 compiler/basicTypes/Name.lhs-boot
  4. +4 −1 compiler/basicTypes/RdrName.lhs
  5. +34 −32 compiler/deSugar/Desugar.lhs
  6. +1 −1  compiler/ghci/ByteCodeLink.lhs
  7. +11 −14 compiler/ghci/Debugger.hs
  8. +55 −6 compiler/ghci/Linker.lhs
  9. +43 −33 compiler/iface/IfaceEnv.lhs
  10. +19 −13 compiler/main/GHC.hs
  11. +103 −17 compiler/main/HscMain.lhs
  12. +222 −65 compiler/main/HscTypes.lhs
  13. +48 −28 compiler/main/InteractiveEval.hs
  14. +70 −72 compiler/main/TidyPgm.lhs
  15. +4 −8 compiler/prelude/PrelNames.lhs
  16. +13 −24 compiler/rename/RnNames.lhs
  17. +2 −1  compiler/rename/RnSource.lhs
  18. +19 −13 compiler/typecheck/FamInst.lhs
  19. +64 −46 compiler/typecheck/Inst.lhs
  20. +20 −2 compiler/typecheck/TcEnv.lhs
  21. +4 −3 compiler/typecheck/TcInstDcls.lhs
  22. +185 −99 compiler/typecheck/TcRnDriver.lhs
  23. +4 −15 compiler/typecheck/TcRnMonad.lhs
  24. +3 −0  compiler/typecheck/TcRnTypes.lhs
  25. +10 −9 compiler/typecheck/TcTyClsDecls.lhs
  26. +110 −12 compiler/types/FamInstEnv.lhs
  27. +86 −53 compiler/types/InstEnv.lhs
  28. +2 −0  compiler/types/TypeRep.lhs
  29. +6 −6 compiler/utils/Outputable.lhs
  30. +10 −8 compiler/vectorise/Vectorise.hs
  31. +6 −5 compiler/vectorise/Vectorise/Env.hs
  32. +6 −2 compiler/vectorise/Vectorise/Monad.hs
  33. +9 −15 compiler/vectorise/Vectorise/Type/Env.hs
  34. +15 −4 ghc/GhciMonad.hs
  35. +52 −26 ghc/InteractiveUI.hs
View
2  compiler/basicTypes/DataCon.lhs-boot
@@ -5,4 +5,6 @@ import Name( Name )
data DataCon
dataConName :: DataCon -> Name
isVanillaDataCon :: DataCon -> Bool
+instance Eq DataCon
+instance Ord DataCon
\end{code}
View
18 compiler/basicTypes/Name.lhs
@@ -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
View
4 compiler/basicTypes/Name.lhs-boot
@@ -1,5 +1,9 @@
\begin{code}
module Name where
+import {-# SOURCE #-} Module
+
data Name
+
+nameModule :: Name -> Module
\end{code}
View
5 compiler/basicTypes/RdrName.lhs
@@ -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
View
66 compiler/deSugar/Desugar.lhs
@@ -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,
View
2  compiler/ghci/ByteCodeLink.lhs
@@ -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,"
View
25 compiler/ghci/Debugger.hs
@@ -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
View
61 compiler/ghci/Linker.lhs
@@ -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
View
76 compiler/iface/IfaceEnv.lhs
@@ -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
View
32 compiler/main/GHC.hs
@@ -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 ->
View
120 compiler/main/HscMain.lhs
@@ -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 ()
View
287 compiler/main/HscTypes.lhs
@@ -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
View
76 compiler/main/InteractiveEval.hs
@@ -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
View
142 compiler/main/TidyPgm.lhs
@@ -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}
View
12 compiler/prelude/PrelNames.lhs
@@ -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}
View
37 compiler/rename/RnNames.lhs
@@ -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
View
3  compiler/rename/RnSource.lhs
@@ -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 };
} ;
View
32 compiler/typecheck/FamInst.lhs
@@ -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
View
110 compiler/typecheck/Inst.lhs
@@ -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
View
22 compiler/typecheck/TcEnv.lhs
@@ -12,7 +12,7 @@ module TcEnv(
InstBindings(..),
-- Global environment
- tcExtendGlobalEnv, setGlobalTypeEnv,
+ tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocate