module GHC.Runtime.Context
( InteractiveContext (..)
, InteractiveImport (..)
, emptyInteractiveContext
, extendInteractiveContext
, extendInteractiveContextWithIds
, setInteractivePrintName
, substInteractiveContext
, icExtendGblRdrEnv
, icInteractiveModule
, icInScopeTTs
, icPrintUnqual
)
where
import GHC.Prelude
import GHC.Hs
import GHC.Driver.Session
import {-# SOURCE #-} GHC.Driver.Plugins
import GHC.Runtime.Eval.Types ( Resume )
import GHC.Unit
import GHC.Unit.Env
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead )
import GHC.Core.Type
import GHC.Types.Avail
import GHC.Types.Fixity.Env
import GHC.Types.Id ( isRecordSelector )
import GHC.Types.Id.Info ( IdDetails(..) )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.Var
import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule )
import GHC.Utils.Outputable
import GHC.Utils.Misc
data InteractiveContext
= InteractiveContext {
InteractiveContext -> DynFlags
ic_dflags :: DynFlags,
InteractiveContext -> Int
ic_mod_index :: Int,
InteractiveContext -> [InteractiveImport]
ic_imports :: [InteractiveImport],
InteractiveContext -> [TyThing]
ic_tythings :: [TyThing],
InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env :: GlobalRdrEnv,
InteractiveContext -> ([ClsInst], [FamInst])
ic_instances :: ([ClsInst], [FamInst]),
InteractiveContext -> FixityEnv
ic_fix_env :: FixityEnv,
InteractiveContext -> Maybe [Type]
ic_default :: Maybe [Type],
InteractiveContext -> [Resume]
ic_resume :: [Resume],
InteractiveContext -> Name
ic_monad :: Name,
InteractiveContext -> Name
ic_int_print :: Name,
InteractiveContext -> Maybe FilePath
ic_cwd :: Maybe FilePath,
InteractiveContext -> [LoadedPlugin]
ic_plugins :: ![LoadedPlugin]
}
data InteractiveImport
= IIDecl (ImportDecl GhcPs)
| IIModule ModuleName
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
= InteractiveContext {
ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags,
ic_imports :: [InteractiveImport]
ic_imports = [],
ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
emptyGlobalRdrEnv,
ic_mod_index :: Int
ic_mod_index = Int
1,
ic_tythings :: [TyThing]
ic_tythings = [],
ic_instances :: ([ClsInst], [FamInst])
ic_instances = ([],[]),
ic_fix_env :: FixityEnv
ic_fix_env = FixityEnv
forall a. NameEnv a
emptyNameEnv,
ic_monad :: Name
ic_monad = Name
ioTyConName,
ic_int_print :: Name
ic_int_print = Name
printName,
ic_default :: Maybe [Type]
ic_default = Maybe [Type]
forall a. Maybe a
Nothing,
ic_resume :: [Resume]
ic_resume = [],
ic_cwd :: Maybe FilePath
ic_cwd = Maybe FilePath
forall a. Maybe a
Nothing,
ic_plugins :: [LoadedPlugin]
ic_plugins = []
}
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule (InteractiveContext { ic_mod_index :: InteractiveContext -> Int
ic_mod_index = Int
index })
= Int -> Module
mkInteractiveModule Int
index
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs = InteractiveContext -> [TyThing]
ic_tythings
icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified
icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified
icPrintUnqual UnitEnv
unit_env InteractiveContext{ ic_rn_gbl_env :: InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
grenv } =
UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified UnitEnv
unit_env GlobalRdrEnv
grenv
extendInteractiveContext :: InteractiveContext
-> [TyThing]
-> [ClsInst] -> [FamInst]
-> Maybe [Type]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext :: InteractiveContext
-> [TyThing]
-> [ClsInst]
-> [FamInst]
-> Maybe [Type]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
new_cls_insts [FamInst]
new_fam_insts Maybe [Type]
defaults FixityEnv
fix_env
= InteractiveContext
ictxt { ic_mod_index :: Int
ic_mod_index = InteractiveContext -> Int
ic_mod_index InteractiveContext
ictxt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, ic_tythings :: [TyThing]
ic_tythings = [TyThing]
new_tythings [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ [TyThing]
old_tythings
, ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ictxt GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` [TyThing]
new_tythings
, ic_instances :: ([ClsInst], [FamInst])
ic_instances = ( [ClsInst]
new_cls_insts [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ [ClsInst]
old_cls_insts
, [FamInst]
new_fam_insts [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
fam_insts )
, ic_default :: Maybe [Type]
ic_default = Maybe [Type]
defaults
, ic_fix_env :: FixityEnv
ic_fix_env = FixityEnv
fix_env
}
where
new_ids :: [Id]
new_ids = [Id
id | AnId Id
id <- [TyThing]
new_tythings]
old_tythings :: [TyThing]
old_tythings = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id] -> TyThing -> Bool
shadowed_by [Id]
new_ids) (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)
([ClsInst]
cls_insts, [FamInst]
fam_insts) = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
ictxt
old_cls_insts :: [ClsInst]
old_cls_insts = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (\ClsInst
i -> (ClsInst -> Bool) -> [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
i) [ClsInst]
new_cls_insts) [ClsInst]
cls_insts
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt [Id]
new_ids
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
new_ids = InteractiveContext
ictxt
| Bool
otherwise = InteractiveContext
ictxt { ic_mod_index :: Int
ic_mod_index = InteractiveContext -> Int
ic_mod_index InteractiveContext
ictxt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, ic_tythings :: [TyThing]
ic_tythings = [TyThing]
new_tythings [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ [TyThing]
old_tythings
, ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ictxt GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` [TyThing]
new_tythings }
where
new_tythings :: [TyThing]
new_tythings = (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
new_ids
old_tythings :: [TyThing]
old_tythings = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id] -> TyThing -> Bool
shadowed_by [Id]
new_ids) (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)
shadowed_by :: [Id] -> TyThing -> Bool
shadowed_by :: [Id] -> TyThing -> Bool
shadowed_by [Id]
ids = TyThing -> Bool
shadowed
where
shadowed :: TyThing -> Bool
shadowed (AnId Id
id) | Id -> Bool
isRecordSelector Id
id = Bool
False
shadowed TyThing
tything = TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyThing
tything OccName -> OccSet -> Bool
`elemOccSet` OccSet
new_occs
new_occs :: OccSet
new_occs = [OccName] -> OccSet
mkOccSet ((Id -> OccName) -> [Id] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName [Id]
ids)
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName InteractiveContext
ic Name
n = InteractiveContext
ic{ic_int_print :: Name
ic_int_print = Name
n}
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv GlobalRdrEnv
env [TyThing]
tythings
= (TyThing -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyThing -> GlobalRdrEnv -> GlobalRdrEnv
add GlobalRdrEnv
env [TyThing]
tythings
where
add :: TyThing -> GlobalRdrEnv -> GlobalRdrEnv
add TyThing
thing GlobalRdrEnv
env
| TyThing -> Bool
is_sub_bndr TyThing
thing
= GlobalRdrEnv
env
| Bool
otherwise
= (GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrElt] -> GlobalRdrEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv GlobalRdrEnv
env1 ((AvailInfo -> [GlobalRdrElt]) -> [AvailInfo] -> [GlobalRdrElt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [GlobalRdrElt]
localGREsFromAvail [AvailInfo]
avail)
where
env1 :: GlobalRdrEnv
env1 = GlobalRdrEnv -> [GreName] -> GlobalRdrEnv
shadowNames GlobalRdrEnv
env ((AvailInfo -> [GreName]) -> [AvailInfo] -> [GreName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [GreName]
availGreNames [AvailInfo]
avail)
avail :: [AvailInfo]
avail = TyThing -> [AvailInfo]
tyThingAvailInfo TyThing
thing
is_sub_bndr :: TyThing -> Bool
is_sub_bndr (AnId Id
f) = case Id -> IdDetails
idDetails Id
f of
RecSelId {} -> Bool
True
ClassOpId {} -> Bool
True
IdDetails
_ -> Bool
False
is_sub_bndr TyThing
_ = Bool
False
substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext ictxt :: InteractiveContext
ictxt@InteractiveContext{ ic_tythings :: InteractiveContext -> [TyThing]
ic_tythings = [TyThing]
tts } TCvSubst
subst
| TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst = InteractiveContext
ictxt
| Bool
otherwise = InteractiveContext
ictxt { ic_tythings :: [TyThing]
ic_tythings = (TyThing -> TyThing) -> [TyThing] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> TyThing
subst_ty [TyThing]
tts }
where
subst_ty :: TyThing -> TyThing
subst_ty (AnId Id
id)
= Id -> TyThing
AnId (Id -> TyThing) -> Id -> TyThing
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Id -> Id
updateIdTypeAndMult (TCvSubst -> Type -> Type
substTyAddInScope TCvSubst
subst) Id
id
subst_ty TyThing
tt
= TyThing
tt
instance Outputable InteractiveImport where
ppr :: InteractiveImport -> SDoc
ppr (IIModule ModuleName
m) = Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m
ppr (IIDecl ImportDecl GhcPs
d) = ImportDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ImportDecl GhcPs
d