Commit 67a0cab6 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix GHCi/GHC-API tidying and modules (Trac #9424, #9426)

There were two related bugs here

Trac #9426
   We must increment the ic_mod_index field of the InteractiveContext
   if we have new instances, because we maek DFunIds that should be
   distinct from previous ones.  Previously we were only incrementing
   when defining new user-visible Ids.

   The main change is in HscTypes.extendInteractiveContext, which now
   alwyas bumps the ic_mod_index.  I also added a specialised
   extendInteractiveContextWithIds for the case where we are *only*
   adding new user-visible Ids.

Trac #9424
   In HscMain.hscDeclsWithLocations we were failing to use the
   *tidied* ClsInsts; but the un-tidied ones are LocalIds which
   causes a later ASSERT error.

   On the way I realised that, to behave consistently, the tcg_insts
   and tcg_fam_insts field of TcGblEnv should really only contain
   instances from the current GHCi command, not all the ones to date.
   That in turn meant I had to move the code for deleting replacement
   instances from addLocalInst, addLocalFamInst to
   HscTypes.extendInteractiveContext
parent c4365372
......@@ -116,7 +116,7 @@ bindSuspensions t = do
let (names, tys, hvals) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContext ictxt (map AnId ids)
new_ic = extendInteractiveContextWithIds ictxt ids
liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t'
......@@ -193,8 +193,8 @@ showTerm term = do
bindToFreshName hsc_env ty userName = do
name <- newGrimName userName
let id = AnId $ mkVanillaGlobal name ty
new_ic = extendInteractiveContext (hsc_IC hsc_env) [id]
let id = mkVanillaGlobal name ty
new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
......
......@@ -1465,9 +1465,6 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
-- 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 = tcg_fam_insts tc_gblenv
insts = tcg_insts tc_gblenv
let defaults = tcg_default tc_gblenv
{- Desugar it -}
......@@ -1481,13 +1478,18 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
{- Tidy -}
(tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
(tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
let dflags = hsc_dflags hsc_env
!CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_modBreaks = mod_breaks } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
-- Get the *tidied* cls_insts and fam_insts
data_tycons = filter isDataTyCon tycons
{- Prepare For Code Generation -}
......@@ -1510,16 +1512,14 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
-- We only need to keep around the external bindings
-- (as decided by TidyPgm), since those are the only ones
-- that might be referenced elsewhere.
-- The DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
-- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes
-- Implicit Ids are implicit in tcs
tythings = map AnId ext_ids ++ map ATyCon tcs
let icontext = hsc_IC hsc_env
ictxt1 = extendInteractiveContext icontext tythings
ictxt = ictxt1 { ic_instances = (insts, finsts)
, ic_default = defaults }
ictxt = extendInteractiveContext icontext ext_ids tcs
cls_insts fam_insts defaults
return (tythings, ictxt)
hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
......
......@@ -52,7 +52,8 @@ module HscTypes (
-- * Interactive context
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,
extendInteractiveContext, substInteractiveContext,
extendInteractiveContext, extendInteractiveContextWithIds,
substInteractiveContext,
setInteractivePrintName, icInteractiveModule,
InteractiveImport(..), setInteractivePackage,
mkPrintUnqualified, pprModulePrefix,
......@@ -131,7 +132,7 @@ import HsSyn
import RdrName
import Avail
import Module
import InstEnv ( InstEnv, ClsInst )
import InstEnv ( InstEnv, ClsInst, identicalClsInstHead )
import FamInstEnv
import Rules ( RuleBase )
import CoreSyn ( CoreProgram )
......@@ -1160,13 +1161,22 @@ The details are a bit tricky though:
The 'thisPackage' field stays as 'main' (or whatever -this-package-key says.
* The main trickiness is that the type environment (tcg_type_env and
fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts)
now contains entities from all the interactive-package modules
(Ghci1, Ghci2, ...) together, rather than just a single module as
is usually the case. So you can't use "nameIsLocalOrFrom" to
decide whether to look in the TcGblEnv vs the HPT/PTE. This is a
change, but not a problem provided you know.
* The main trickiness is that the type environment (tcg_type_env) and
fixity envt (tcg_fix_env), now contain entities from all the
interactive-package modules (Ghci1, Ghci2, ...) together, rather
than just a single module as is usually the case. So you can't use
"nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs
the HPT/PTE. This is a change, but not a problem provided you
know.
* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields
of the TcGblEnv, which collect "things defined in this module", all
refer to stuff define in a single GHCi command, *not* all the commands
so far.
In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from
all GhciN modules, which makes sense -- they are all "home package"
modules.
Note [Interactively-bound Ids in GHCi]
......@@ -1214,6 +1224,16 @@ It does *not* contain
* CoAxioms (ditto)
See also Note [Interactively-bound Ids in GHCi]
Note [Override identical instances in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you declare a new instance in GHCi that is identical to a previous one,
we simply override the previous one; we don't regard it as overlapping.
e.g. Prelude> data T = A | B
Prelude> instance Eq T where ...
Prelude> instance Eq T where ... -- This one overrides
It's exactly the same for type-family instances. See Trac #7102
-}
-- | Interactive context, recording information about the state of the
......@@ -1325,28 +1345,50 @@ 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
-- | extendInteractiveContext 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 -> [TyThing] -> InteractiveContext
extendInteractiveContext ictxt new_tythings
| null new_tythings
= ictxt
| otherwise
extendInteractiveContext :: InteractiveContext
-> [Id] -> [TyCon]
-> [ClsInst] -> [FamInst]
-> Maybe [Type]
-> InteractiveContext
extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults
= ictxt { ic_mod_index = ic_mod_index ictxt + 1
-- Always bump this; even instances should create
-- a new mod_index (Trac #9426)
, ic_tythings = new_tythings ++ old_tythings
, ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings
}
, ic_instances = (new_cls_insts ++ old_cls_insts, new_fam_insts ++ old_fam_insts)
, ic_default = defaults }
where
old_tythings = filter (not . shadowed) (ic_tythings ictxt)
shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id
shadowed _ = False
new_tythings = map AnId ids ++ map ATyCon tcs
old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
-- Discard old instances that have been fully overrridden
-- See Note [Override identical instances in GHCi]
(cls_insts, fam_insts) = ic_instances ictxt
old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts
old_fam_insts = filterOut (\i -> any (identicalFamInstHead i) new_fam_insts) fam_insts
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds ictxt ids
| null ids = ictxt
| otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1
, ic_tythings = new_tythings ++ old_tythings
, ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }
where
new_tythings = map AnId ids
old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
shadowed_by :: [Id] -> TyThing -> Bool
shadowed_by ids = shadowed
where
shadowed id = getOccName id `elemOccSet` new_occs
new_occs = mkOccSet (map getOccName ids)
setInteractivePackage :: HscEnv -> HscEnv
-- Set the 'thisPackage' DynFlag to 'interactive'
......
......@@ -306,8 +306,7 @@ handleRunStatus step expr bindings final_ids
-- Completed successfully
| Complete (Right hvals) <- status
= do hsc_env <- getSession
let final_ic = extendInteractiveContext (hsc_IC hsc_env)
(map AnId final_ids)
let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) 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}
......@@ -580,10 +579,10 @@ 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 = AnId $ Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id]
ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
span = mkGeneralSrcSpan (fsLit "<exception thrown>")
--
......@@ -652,7 +651,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 (map AnId final_ids)
ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
......@@ -711,8 +710,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
printInfoForUser dflags alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
let ic' = extendInteractiveContext
(substInteractiveContext ic subst) []
let ic' = substInteractiveContext ic subst
return hsc_env{hsc_IC=ic'}
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
......
......@@ -303,7 +303,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_exports = exports
, mg_rdr_env = rdr_env
, mg_tcs = tcs
, mg_insts = insts
, mg_insts = cls_insts
, mg_fam_insts = fam_insts
, mg_binds = binds
, mg_patsyns = patsyns
......@@ -343,11 +343,11 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
isExternalName (idName id)]
; type_env1 = extendTypeEnvWithIds type_env final_ids
; tidy_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) insts
; tidy_cls_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) cls_insts
-- A DFunId will have a binding in tidy_binds, and so will now be in
-- tidy_type_env, replete with IdInfo. Its name will be unchanged since
-- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
-- tidy_insts. Similarly the Ids inside a PatSyn.
-- tidy_cls_insts. Similarly the Ids inside a PatSyn.
; tidy_rules = tidyRules tidy_env trimmed_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
......@@ -408,7 +408,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_insts,
md_insts = tidy_cls_insts,
md_vect_info = tidy_vect_info,
md_fam_insts = fam_insts,
md_exports = exports,
......
......@@ -328,11 +328,10 @@ addLocalFamInst (home_fie, my_fis) fam_inst
-- In GHCi, we *override* any identical instances
-- that are also defined in the interactive context
-- Trac #7102
; let (home_fie', my_fis')
| isGHCi = ( deleteFromFamInstEnv home_fie fam_inst
, filterOut (identicalFamInst fam_inst) my_fis)
| otherwise = (home_fie, my_fis)
-- See Note [Override identical instances in GHCi] in HscTypes
; let home_fie'
| isGHCi = deleteFromFamInstEnv home_fie fam_inst
| otherwise = home_fie
-- Load imported instances, so that we report
-- overlaps correctly
......@@ -343,7 +342,7 @@ addLocalFamInst (home_fie, my_fis) fam_inst
-- Check for conflicting instance decls
; no_conflict <- checkForConflicts inst_envs fam_inst
; if no_conflict then
return (home_fie'', fam_inst : my_fis')
return (home_fie'', fam_inst : my_fis)
else
return (home_fie, my_fis) }
......
......@@ -464,12 +464,13 @@ addLocalInst (home_ie, my_insts) ispec
; isGHCi <- getIsGHCi
; eps <- getEps
; tcg_env <- getGblEnv
; let (home_ie', my_insts')
| isGHCi = ( deleteFromInstEnv home_ie ispec
, filterOut (identicalInstHead ispec) my_insts)
| otherwise = (home_ie, my_insts)
-- If there is a home-package duplicate instance,
-- silently delete it
-- In GHCi, we *override* any identical instances
-- that are also defined in the interactive context
-- See Note [Override identical instances in GHCi]
; let home_ie'
| isGHCi = deleteFromInstEnv home_ie ispec
| otherwise = home_ie
(_tvs, cls, tys) = instanceHead ispec
-- If we're compiling sig-of and there's an external duplicate
......@@ -484,7 +485,7 @@ addLocalInst (home_ie, my_insts) ispec
, ie_local = home_ie'
, ie_visible = tcg_visible_orphan_mods tcg_env }
(matches, _, _) = lookupInstEnv inst_envs cls tys
dups = filter (identicalInstHead ispec) (map fst matches)
dups = filter (identicalClsInstHead ispec) (map fst matches)
-- Check functional dependencies
; case checkFunDeps inst_envs ispec of
......@@ -495,7 +496,7 @@ addLocalInst (home_ie, my_insts) ispec
; unless (null dups) $
dupInstErr ispec (head dups)
; return (extendInstEnv home_ie' ispec, ispec:my_insts') }
; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
{-
Note [Signature files and type class instances]
......
......@@ -1413,8 +1413,6 @@ runTcInteractive hsc_env thing_inside
; let gbl_env' = gbl_env {
tcg_rdr_env = ic_rn_gbl_env icxt
, tcg_type_env = type_env
, tcg_insts = ic_insts
, tcg_fam_insts = ic_finsts
, tcg_inst_env = extendInstEnvList
(extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
home_insts
......
......@@ -456,8 +456,9 @@ data TcGblEnv
tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings
-- Things defined in this module, or (in GHCi) in the interactive package
-- For the latter, see Note [The interactive package] in HscTypes
-- Things defined in this module, or (in GHCi)
-- in the declarations for a single GHCi command.
-- For the latter, see Note [The interactive package] in HscTypes
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids
......
......@@ -12,7 +12,7 @@ module FamInstEnv (
FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList,
identicalFamInst, famInstEnvElts, familyInstances, orphNamesOfFamInst,
identicalFamInstHead, famInstEnvElts, familyInstances, orphNamesOfFamInst,
-- * CoAxioms
mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,
......@@ -369,12 +369,12 @@ deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm})
where
adjust :: FamilyInstEnv -> FamilyInstEnv
adjust (FamIE items)
= FamIE (filterOut (identicalFamInst fam_inst) items)
= FamIE (filterOut (identicalFamInstHead fam_inst) items)
identicalFamInst :: FamInst -> FamInst -> Bool
-- Same LHS, *and* both instances are on the interactive command line
identicalFamInstHead :: FamInst -> FamInst -> Bool
-- ^ True when the LHSs are identical
-- Used for overriding in GHCi
identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 })
identicalFamInstHead (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 })
= coAxiomTyCon ax1 == coAxiomTyCon ax2
&& brListLength brs1 == brListLength brs2
&& and (brListZipWith identical_branch brs1 brs2)
......
......@@ -20,7 +20,7 @@ module InstEnv (
IsOrphan(..), isOrphan, notOrphan,
InstEnvs(..), VisibleOrphanModules, InstEnv,
emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead,
emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead,
extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
memberInstEnv, instIsVisible,
classInstances, orphNamesOfClsInst, instanceBindFun,
......@@ -490,7 +490,7 @@ orphNamesOfClsInst = orphNamesOfDFunHead . idType . instanceDFunId
-- We use this when we do signature checking in TcRnDriver
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =
maybe False (\(ClsIE items) -> any (identicalInstHead ins_item) items)
maybe False (\(ClsIE items) -> any (identicalClsInstHead ins_item) items)
(lookupUFM inst_env cls_nm)
extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
......@@ -506,14 +506,15 @@ deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
= adjustUFM adjust inst_env cls_nm
where
adjust (ClsIE items) = ClsIE (filterOut (identicalInstHead ins_item) items)
adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)
identicalInstHead :: ClsInst -> ClsInst -> Bool
identicalClsInstHead :: ClsInst -> ClsInst -> Bool
-- ^ True when when the instance heads are the same
-- e.g. both are Eq [(a,b)]
-- Used for overriding in GHCi
-- Obviously should be insenstive to alpha-renaming
identicalInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tvs = tvs1, is_tys = tys1 })
(ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tvs = tvs2, is_tys = tys2 })
identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tvs = tvs1, is_tys = tys1 })
(ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tvs = tvs2, is_tys = tys2 })
= cls_nm1 == cls_nm2
&& not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields
&& isJust (tcMatchTys (mkVarSet tvs1) tys1 tys2)
......
......@@ -667,9 +667,10 @@ Prelude>
an attempt to distinguish it from the new <literal>T</literal>,
which is displayed as simply <literal>T</literal>.</para>
<para>Class and type-family instance declarations are simply added to the list of available instances, with one
exception. Since type-family instances are not permitted to overlap, but you might want to re-define one,
a type-family instance <emphasis>replaces</emphasis> any earlier type instance with an identical left hand side.
<para>Class and type-family instance declarations are simply added to the list of available instances,
with one exception. Since you might want to re-define one,
a class or type-family instance <emphasis>replaces</emphasis> any earlier instance with
an identical head or left hand side (respectively).
(See <xref linkend="type-families"/>.)</para>
</sect2>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment