module GHC.Runtime.Context
( InteractiveContext (..)
, InteractiveImport (..)
, emptyInteractiveContext
, extendInteractiveContext
, extendInteractiveContextWithIds
, setInteractivePrintName
, substInteractiveContext
, replaceImportEnv
, icReaderEnv
, icExtendGblRdrEnv
, icInteractiveModule
, icInScopeTTs
, icNamePprCtx
)
where
import GHC.Prelude
import GHC.Hs
import GHC.Driver.DynFlags
import {-# SOURCE #-} GHC.Driver.Plugins
import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Core.Type
import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )
import GHC.Types.Fixity.Env
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
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 -> IcGlobalRdrEnv
ic_gre_cache :: IcGlobalRdrEnv,
InteractiveContext -> (InstEnv, [FamInst])
ic_instances :: (InstEnv, [FamInst]),
InteractiveContext -> FixityEnv
ic_fix_env :: FixityEnv,
InteractiveContext -> DefaultEnv
ic_default :: DefaultEnv,
InteractiveContext -> [Resume]
ic_resume :: [Resume],
InteractiveContext -> Name
ic_monad :: Name,
InteractiveContext -> Name
ic_int_print :: Name,
InteractiveContext -> Maybe FilePath
ic_cwd :: Maybe FilePath,
InteractiveContext -> Plugins
ic_plugins :: !Plugins
}
data InteractiveImport
= IIDecl (ImportDecl GhcPs)
| IIModule ModuleName
emptyIcGlobalRdrEnv :: IcGlobalRdrEnv
emptyIcGlobalRdrEnv :: IcGlobalRdrEnv
emptyIcGlobalRdrEnv = IcGlobalRdrEnv
{ igre_env :: GlobalRdrEnv
igre_env = GlobalRdrEnv
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv
, igre_prompt_env :: GlobalRdrEnv
igre_prompt_env = GlobalRdrEnv
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv
}
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
= InteractiveContext {
ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags,
ic_imports :: [InteractiveImport]
ic_imports = [],
ic_gre_cache :: IcGlobalRdrEnv
ic_gre_cache = IcGlobalRdrEnv
emptyIcGlobalRdrEnv,
ic_mod_index :: Int
ic_mod_index = Int
1,
ic_tythings :: [TyThing]
ic_tythings = [],
ic_instances :: (InstEnv, [FamInst])
ic_instances = (InstEnv
emptyInstEnv,[]),
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 :: DefaultEnv
ic_default = DefaultEnv
emptyDefaultEnv,
ic_resume :: [Resume]
ic_resume = [],
ic_cwd :: Maybe FilePath
ic_cwd = Maybe FilePath
forall a. Maybe a
Nothing,
ic_plugins :: Plugins
ic_plugins = Plugins
emptyPlugins
}
icReaderEnv :: InteractiveContext -> GlobalRdrEnv
icReaderEnv :: InteractiveContext -> GlobalRdrEnv
icReaderEnv = IcGlobalRdrEnv -> GlobalRdrEnv
igre_env (IcGlobalRdrEnv -> GlobalRdrEnv)
-> (InteractiveContext -> IcGlobalRdrEnv)
-> InteractiveContext
-> GlobalRdrEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveContext -> IcGlobalRdrEnv
ic_gre_cache
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule (InteractiveContext { ic_mod_index :: InteractiveContext -> Int
ic_mod_index = Int
index })
= FilePath -> Module
mkInteractiveModule (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
index)
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs InteractiveContext
ictxt = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filter TyThing -> Bool
in_scope_unqualified (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)
where
in_scope_unqualified :: TyThing -> Bool
in_scope_unqualified TyThing
thing = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ GlobalRdrEltX GREInfo -> Bool
forall info. GlobalRdrEltX info -> Bool
unQualOK GlobalRdrEltX GREInfo
gre
| GlobalRdrEltX GREInfo
gre <- TyThing -> [GlobalRdrEltX GREInfo]
tyThingLocalGREs TyThing
thing
, let name :: Name
name = GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrEltX GREInfo
gre
, Just GlobalRdrEltX GREInfo
gre <- [GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name (InteractiveContext -> GlobalRdrEnv
icReaderEnv InteractiveContext
ictxt) Name
name]
]
icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
icNamePprCtx UnitEnv
unit_env InteractiveContext
ictxt = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc UnitEnv
unit_env (InteractiveContext -> GlobalRdrEnv
icReaderEnv InteractiveContext
ictxt)
where ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ictxt)
extendInteractiveContext :: InteractiveContext
-> [TyThing]
-> InstEnv -> [FamInst]
-> DefaultEnv
-> FixityEnv
-> InteractiveContext
extendInteractiveContext :: InteractiveContext
-> [TyThing]
-> InstEnv
-> [FamInst]
-> DefaultEnv
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings InstEnv
new_cls_insts [FamInst]
new_fam_insts DefaultEnv
defaults FixityEnv
fix_env
= InteractiveContext
ictxt { ic_mod_index = ic_mod_index ictxt + 1
, ic_tythings = new_tythings ++ ic_tythings ictxt
, ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings
, ic_instances = ( new_cls_insts `unionInstEnv` old_cls_insts
, new_fam_insts ++ fam_insts )
, ic_default = defaults
, ic_fix_env = fix_env
}
where
(InstEnv
cls_insts, [FamInst]
fam_insts) = InteractiveContext -> (InstEnv, [FamInst])
ic_instances InteractiveContext
ictxt
old_cls_insts :: InstEnv
old_cls_insts = (ClsInst -> Bool) -> InstEnv -> InstEnv
filterInstEnv (\ClsInst
i -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ClsInst -> Bool) -> InstEnv -> Bool
anyInstEnv (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
i) InstEnv
new_cls_insts) InstEnv
cls_insts
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt [Id]
new_ids
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
new_ids = InteractiveContext
ictxt
| Bool
otherwise
= InteractiveContext
ictxt { ic_mod_index = ic_mod_index ictxt + 1
, ic_tythings = new_tythings ++ ic_tythings ictxt
, ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` 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
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName InteractiveContext
ic Name
n = InteractiveContext
ic{ic_int_print = n}
icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv
icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv
icExtendIcGblRdrEnv IcGlobalRdrEnv
igre [TyThing]
tythings = IcGlobalRdrEnv
{ igre_env :: GlobalRdrEnv
igre_env = Bool -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv Bool
False (IcGlobalRdrEnv -> GlobalRdrEnv
igre_env IcGlobalRdrEnv
igre) [TyThing]
tythings
, igre_prompt_env :: GlobalRdrEnv
igre_prompt_env = Bool -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv Bool
True (IcGlobalRdrEnv -> GlobalRdrEnv
igre_prompt_env IcGlobalRdrEnv
igre) [TyThing]
tythings
}
replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv
replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv
replaceImportEnv IcGlobalRdrEnv
igre GlobalRdrEnv
import_env = IcGlobalRdrEnv
igre { igre_env = new_env }
where
import_env_shadowed :: GlobalRdrEnv
import_env_shadowed = Bool -> GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
shadowNames Bool
False GlobalRdrEnv
import_env (IcGlobalRdrEnv -> GlobalRdrEnv
igre_prompt_env IcGlobalRdrEnv
igre)
new_env :: GlobalRdrEnv
new_env = GlobalRdrEnv
import_env_shadowed GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
`plusGlobalRdrEnv` IcGlobalRdrEnv -> GlobalRdrEnv
igre_prompt_env IcGlobalRdrEnv
igre
icExtendGblRdrEnv :: Bool
-> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv :: Bool -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv Bool
drop_only_qualified GlobalRdrEnv
env [TyThing]
tythings
= (TyThing -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
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 -> GlobalRdrEltX GREInfo -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' GlobalRdrEnv -> GlobalRdrEltX GREInfo -> GlobalRdrEnv
extendGlobalRdrEnv GlobalRdrEnv
env1 [GlobalRdrEltX GREInfo]
new_gres
where
new_gres :: [GlobalRdrEltX GREInfo]
new_gres = TyThing -> [GlobalRdrEltX GREInfo]
tyThingLocalGREs TyThing
thing
env1 :: GlobalRdrEnv
env1 = Bool -> GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
shadowNames Bool
drop_only_qualified GlobalRdrEnv
env (GlobalRdrEnv -> GlobalRdrEnv) -> GlobalRdrEnv -> GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ [GlobalRdrEltX GREInfo] -> GlobalRdrEnv
mkGlobalRdrEnv [GlobalRdrEltX GREInfo]
new_gres
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 -> Subst -> InteractiveContext
substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext
substInteractiveContext ictxt :: InteractiveContext
ictxt@InteractiveContext{ ic_tythings :: InteractiveContext -> [TyThing]
ic_tythings = [TyThing]
tts } Subst
subst
| Subst -> Bool
isEmptyTCvSubst Subst
subst = InteractiveContext
ictxt
| Bool
otherwise = InteractiveContext
ictxt { ic_tythings = map subst_ty 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 (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTyAddInScope Subst
subst) Id
id
subst_ty TyThing
tt
= TyThing
tt
instance Outputable InteractiveImport where
ppr :: InteractiveImport -> SDoc
ppr (IIModule ModuleName
m) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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