{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Runtime.Eval (
Resume(..), History(..),
execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
runDecls, runDeclsWithLocation, runParsedDecls,
parseImportDecl, SingleStep(..),
abandon, abandonAll,
getResumeContext,
getHistorySpan,
getModBreaks,
getHistoryModule,
setupBreakpoint,
back, forward,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
parseInstanceHead,
getInstancesForType,
getDocs,
GetDocsFailure(..),
showModule,
moduleIsBootOrNotObjectLinkable,
parseExpr, compileParsedExpr,
compileExpr, dynCompileExpr,
compileExprRemote, compileParsedExprRemote,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Monad
import GHC.Driver.Main
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Context
import GHCi.Message
import GHCi.RemoteTypes
import GHC.ByteCode.Types
import GHC.Linker.Types
import GHC.Linker.Loader as Loader
import GHC.Hs
import GHC.Core.Predicate
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv ( FamInst )
import GHC.Core.FVs ( orphNamesOfFamInst )
import GHC.Core.TyCon
import GHC.Core.Type hiding( typeKind )
import qualified GHC.Core.Type as Type
import GHC.Iface.Env ( newInteractiveBinder )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )
import GHC.Builtin.Types ( isCTupleTyConName )
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.RepType
import GHC.Types.Fixity.Env
import GHC.Types.Var
import GHC.Types.Id as Id
import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Types.TyThing
import GHC.Unit
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo
import System.Directory
import Data.Dynamic
import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import GHC.Utils.Exception
import Unsafe.Coerce ( unsafeCoerce )
import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) )
import GHC.Tc.Utils.Env (tcGetInstEnvs)
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Monad
import GHC.Core.Class (classTyCon)
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext :: forall (m :: * -> *). GhcMonad m => m [Resume]
getResumeContext = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveContext -> [Resume]
ic_resume forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
hsc_IC)
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
hval BreakInfo
bi = ForeignHValue -> BreakInfo -> [String] -> History
History ForeignHValue
hval BreakInfo
bi (HscEnv -> BreakInfo -> [String]
findEnclosingDecls HscEnv
hsc_env BreakInfo
bi)
getHistoryModule :: History -> Module
getHistoryModule :: History -> Module
getHistoryModule = BreakInfo -> Module
breakInfo_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> BreakInfo
historyBreakInfo
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan HscEnv
hsc_env History{[String]
ForeignHValue
BreakInfo
historyEnclosingDecls :: History -> [String]
historyApStack :: History -> ForeignHValue
historyEnclosingDecls :: [String]
historyBreakInfo :: BreakInfo
historyApStack :: ForeignHValue
historyBreakInfo :: History -> BreakInfo
..} =
let BreakInfo{BreakIndex
Module
breakInfo_number :: BreakInfo -> BreakIndex
breakInfo_number :: BreakIndex
breakInfo_module :: Module
breakInfo_module :: BreakInfo -> Module
..} = BreakInfo
historyBreakInfo in
case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
breakInfo_module) of
Just HomeModInfo
hmi -> ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs (HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi) forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
Maybe HomeModInfo
_ -> forall a. String -> a
panic String
"getHistorySpan"
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls HscEnv
hsc_env (BreakInfo Module
modl BreakIndex
ix) =
let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"findEnclosingDecls" forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
modl)
mb :: ModBreaks
mb = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
in ModBreaks -> Array BreakIndex [String]
modBreaks_decls ModBreaks
mb forall i e. Ix i => Array i e -> i -> e
! BreakIndex
ix
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv :: forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_fix_env :: FixityEnv
ic_fix_env = FixityEnv
fix_env } }
execOptions :: ExecOptions
execOptions :: ExecOptions
execOptions = ExecOptions
{ execSingleStep :: SingleStep
execSingleStep = SingleStep
RunToCompletion
, execSourceFile :: String
execSourceFile = String
"<interactive>"
, execLineNumber :: BreakIndex
execLineNumber = BreakIndex
1
, execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execWrap = forall a. a -> EvalExpr a
EvalThis
}
execStmt
:: GhcMonad m
=> String
-> ExecOptions
-> m ExecResult
execStmt :: forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
input exec_opts :: ExecOptions
exec_opts@ExecOptions{BreakIndex
String
SingleStep
ForeignHValue -> EvalExpr ForeignHValue
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: BreakIndex
execSourceFile :: String
execSingleStep :: SingleStep
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: ExecOptions -> BreakIndex
execSourceFile :: ExecOptions -> String
execSingleStep :: ExecOptions -> SingleStep
..} = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mb_stmt <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
String -> BreakIndex -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
execSourceFile BreakIndex
execLineNumber String
input
case Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mb_stmt of
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right []) Word64
0)
Just GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt -> forall (m :: * -> *).
GhcMonad m =>
GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt String
input ExecOptions
exec_opts
execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' :: forall (m :: * -> *).
GhcMonad m =>
GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' GhciLStmt GhcPs
stmt String
stmt_text ExecOptions{BreakIndex
String
SingleStep
ForeignHValue -> EvalExpr ForeignHValue
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: BreakIndex
execSourceFile :: String
execSingleStep :: SingleStep
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: ExecOptions -> BreakIndex
execSourceFile :: ExecOptions -> String
execSingleStep :: ExecOptions -> SingleStep
..} = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
idflags' :: DynFlags
idflags' = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic DynFlags -> WarningFlag -> DynFlags
`wopt_unset` WarningFlag
Opt_WarnUnusedLocalBinds
hsc_env' :: HscEnv
hsc_env' = HscEnv -> HscEnv
mkInteractiveHscEnv (HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic{ ic_dflags :: DynFlags
ic_dflags = DynFlags
idflags' }})
Maybe ([Id], ForeignHValue, FixityEnv)
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env' GhciLStmt GhcPs
stmt
case Maybe ([Id], ForeignHValue, FixityEnv)
r of
Maybe ([Id], ForeignHValue, FixityEnv)
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right []) Word64
0)
Just ([Id]
ids, ForeignHValue
hval, FixityEnv
fix_env) -> do
forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env
EvalStatus_ [ForeignHValue] [HValueRef]
status <-
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Interp
-> DynFlags
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp DynFlags
idflags' (SingleStep -> Bool
isStep SingleStep
execSingleStep) (ForeignHValue -> EvalExpr ForeignHValue
execWrap ForeignHValue
hval)
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
bindings :: ([TyThing], GlobalRdrEnv)
bindings = (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic, InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ic)
size :: BreakIndex
size = DynFlags -> BreakIndex
ghciHistSize DynFlags
idflags'
forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
execSingleStep String
stmt_text ([TyThing], GlobalRdrEnv)
bindings [Id]
ids
EvalStatus_ [ForeignHValue] [HValueRef]
status (BreakIndex -> BoundedList History
emptyHistory BreakIndex
size)
runDecls :: GhcMonad m => String -> m [Name]
runDecls :: forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls = forall (m :: * -> *).
GhcMonad m =>
String -> BreakIndex -> String -> m [Name]
runDeclsWithLocation String
"<interactive>" BreakIndex
1
runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
runDeclsWithLocation :: forall (m :: * -> *).
GhcMonad m =>
String -> BreakIndex -> String -> m [Name]
runDeclsWithLocation String
source BreakIndex
line_num String
input = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> String -> BreakIndex -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env String
source BreakIndex
line_num String
input)
forall (m :: * -> *). GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls
runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls :: forall (m :: * -> *). GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls [LHsDecl GhcPs]
decls = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
([TyThing]
tyThings, InteractiveContext
ic) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls)
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic }
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
HscEnv
hsc_env' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [TyThing]
tyThings
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD m a
m = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
case Interp -> InterpInstance
interpInstance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
Just (ExternalInterp {}) -> m a
m
Maybe InterpInstance
_ -> do
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
let set_cwd :: m String
set_cwd = do
String
dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
case InteractiveContext -> Maybe String
ic_cwd InteractiveContext
ic of
Just String
dir -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
reset_cwd :: String -> m ()
reset_cwd String
orig_dir = do
String
virt_dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let old_IC :: InteractiveContext
old_IC = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
old_IC{ ic_cwd :: Maybe String
ic_cwd = forall a. a -> Maybe a
Just String
virt_dir } }
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
orig_dir
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m String
set_cwd forall {m :: * -> *}. GhcMonad m => String -> m ()
reset_cwd forall a b. (a -> b) -> a -> b
$ \String
_ -> m a
m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl :: forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
expr = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport HscEnv
hsc_env String
expr
emptyHistory :: Int -> BoundedList History
emptyHistory :: BreakIndex -> BoundedList History
emptyHistory BreakIndex
size = forall a. BreakIndex -> BoundedList a
nilBL BreakIndex
size
handleRunStatus :: GhcMonad m
=> SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus :: forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
step String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
history
| SingleStep
RunAndLogSteps <- SingleStep
step = m ExecResult
tracing
| Bool
otherwise = m ExecResult
not_tracing
where
tracing :: m ExecResult
tracing
| EvalBreak Bool
is_exception HValueRef
apStack_ref BreakIndex
ix BreakIndex
mod_uniq RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
_ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
, Bool -> Bool
not Bool
is_exception
= do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" forall a b. (a -> b) -> a -> b
$
HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
(BreakIndex -> Unique
mkUniqueGrimily BreakIndex
mod_uniq)
modl :: Module
modl = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
breaks :: ModBreaks
breaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Interp -> ForeignRef BreakArray -> BreakIndex -> IO Bool
breakpointStatus Interp
interp (ModBreaks -> ForeignRef BreakArray
modBreaks_flags ModBreaks
breaks) BreakIndex
ix
if Bool
b
then m ExecResult
not_tracing
else do
ForeignHValue
apStack_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp HValueRef
apStack_ref
let bi :: BreakInfo
bi = Module -> BreakIndex -> BreakInfo
BreakInfo Module
modl BreakIndex
ix
!history' :: BoundedList History
history' = HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack_fhv BreakInfo
bi forall a. a -> BoundedList a -> BoundedList a
`consBL` BoundedList History
history
ForeignRef (ResumeContext [HValueRef])
fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext [HValueRef])
resume_ctxt
EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt Interp
interp DynFlags
dflags Bool
True ForeignRef (ResumeContext [HValueRef])
fhv
forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
RunAndLogSteps String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids
EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
history'
| Bool
otherwise
= m ExecResult
not_tracing
not_tracing :: m ExecResult
not_tracing
| EvalBreak Bool
is_exception HValueRef
apStack_ref BreakIndex
ix BreakIndex
mod_uniq RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext [HValueRef])
resume_ctxt
ForeignHValue
apStack_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp HValueRef
apStack_ref
let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" forall a b. (a -> b) -> a -> b
$
HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
(BreakIndex -> Unique
mkUniqueGrimily BreakIndex
mod_uniq)
modl :: Module
modl = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
bp :: Maybe BreakInfo
bp | Bool
is_exception = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Module -> BreakIndex -> BreakInfo
BreakInfo Module
modl BreakIndex
ix)
(HscEnv
hsc_env1, [Name]
names, SrcSpan
span, String
decl) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack_fhv Maybe BreakInfo
bp
let
resume :: Resume
resume = Resume
{ resumeStmt :: String
resumeStmt = String
expr, resumeContext :: ForeignRef (ResumeContext [HValueRef])
resumeContext = ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv
, resumeBindings :: ([TyThing], GlobalRdrEnv)
resumeBindings = ([TyThing], GlobalRdrEnv)
bindings, resumeFinalIds :: [Id]
resumeFinalIds = [Id]
final_ids
, resumeApStack :: ForeignHValue
resumeApStack = ForeignHValue
apStack_fhv
, resumeBreakInfo :: Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
bp
, resumeSpan :: SrcSpan
resumeSpan = SrcSpan
span, resumeHistory :: [History]
resumeHistory = forall a. BoundedList a -> [a]
toListBL BoundedList History
history
, resumeDecl :: String
resumeDecl = String
decl
, resumeCCS :: RemotePtr CostCentreStack
resumeCCS = RemotePtr CostCentreStack
ccs
, resumeHistoryIx :: BreakIndex
resumeHistoryIx = BreakIndex
0 }
hsc_env2 :: HscEnv
hsc_env2 = HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env1 Resume
resume
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Maybe BreakInfo -> ExecResult
ExecBreak [Name]
names Maybe BreakInfo
bp)
| EvalComplete Word64
allocs (EvalSuccess [ForeignHValue]
hvals) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let final_ic :: InteractiveContext
final_ic = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) [Id]
final_ids
final_names :: [Name]
final_names = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [Id]
final_ids
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
final_names [ForeignHValue]
hvals)
HscEnv
hsc_env' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{hsc_IC :: InteractiveContext
hsc_IC=InteractiveContext
final_ic}
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right [Name]
final_names) Word64
allocs)
| EvalComplete Word64
alloc (EvalException SerializableException
e) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. a -> Either a b
Left (SerializableException -> SomeException
fromSerializableException SerializableException
e)) Word64
alloc)
#if __GLASGOW_HASKELL__ <= 810
| otherwise
= panic "not_tracing"
#endif
resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
-> m ExecResult
resumeExec :: forall (m :: * -> *).
GhcMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe BreakIndex -> m ExecResult
resumeExec SrcSpan -> Bool
canLogSpan SingleStep
step Maybe BreakIndex
mbCnt
= do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
case [Resume]
resume of
[] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"not stopped at a breakpoint")
(Resume
r:[Resume]
rs) -> do
let ([TyThing]
resume_tmp_te,GlobalRdrEnv
resume_rdr_env) = Resume -> ([TyThing], GlobalRdrEnv)
resumeBindings Resume
r
ic' :: InteractiveContext
ic' = InteractiveContext
ic { ic_tythings :: [TyThing]
ic_tythings = [TyThing]
resume_tmp_te,
ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
resume_rdr_env,
ic_resume :: [Resume]
ic_resume = [Resume]
rs }
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic' }
let old_names :: [Name]
old_names = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [TyThing]
resume_tmp_te
new_names :: [Name]
new_names = [ Name
n | TyThing
thing <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic
, let n :: Name
n = forall a. NamedThing a => a -> Name
getName TyThing
thing
, Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
old_names) ]
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> [Name] -> IO ()
Loader.deleteFromLoadedEnv Interp
interp [Name]
new_names
case Resume
r of
Resume { resumeStmt :: Resume -> String
resumeStmt = String
expr, resumeContext :: Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext = ForeignRef (ResumeContext [HValueRef])
fhv
, resumeBindings :: Resume -> ([TyThing], GlobalRdrEnv)
resumeBindings = ([TyThing], GlobalRdrEnv)
bindings, resumeFinalIds :: Resume -> [Id]
resumeFinalIds = [Id]
final_ids
, resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack, resumeBreakInfo :: Resume -> Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
mb_brkpt
, resumeSpan :: Resume -> SrcSpan
resumeSpan = SrcSpan
span
, resumeHistory :: Resume -> [History]
resumeHistory = [History]
hist } ->
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe BreakInfo
mb_brkpt Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe BreakIndex
mbCnt) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakInfo -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env (forall a. HasCallStack => Maybe a -> a
fromJust Maybe BreakInfo
mb_brkpt) (forall a. HasCallStack => Maybe a -> a
fromJust Maybe BreakIndex
mbCnt)
EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt Interp
interp DynFlags
dflags (SingleStep -> Bool
isStep SingleStep
step) ForeignRef (ResumeContext [HValueRef])
fhv
let prevHistoryLst :: BoundedList History
prevHistoryLst = forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
hist' :: BoundedList History
hist' = case Maybe BreakInfo
mb_brkpt of
Maybe BreakInfo
Nothing -> BoundedList History
prevHistoryLst
Just BreakInfo
bi
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ SrcSpan -> Bool
canLogSpan SrcSpan
span -> BoundedList History
prevHistoryLst
| Bool
otherwise -> HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack BreakInfo
bi forall a. a -> BoundedList a -> BoundedList a
`consBL`
forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
step String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
hist'
setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()
setupBreakpoint :: forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakInfo -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env BreakInfo
brkInfo BreakIndex
cnt = do
let Module
modl :: Module = BreakInfo -> Module
breakInfo_module BreakInfo
brkInfo
breaks :: HscEnv -> GenModule unit -> ModBreaks
breaks HscEnv
hsc_env GenModule unit
modl = HomeModInfo -> ModBreaks
getModBreaks forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"setupBreakpoint" forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName GenModule unit
modl)
ix :: BreakIndex
ix = BreakInfo -> BreakIndex
breakInfo_number BreakInfo
brkInfo
modBreaks :: ModBreaks
modBreaks = forall {unit}. HscEnv -> GenModule unit -> ModBreaks
breaks HscEnv
hsc_env Module
modl
breakarray :: ForeignRef BreakArray
breakarray = ModBreaks -> ForeignRef BreakArray
modBreaks_flags ModBreaks
modBreaks
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> ForeignRef BreakArray -> BreakIndex -> BreakIndex -> IO ()
GHCi.storeBreakpoint Interp
interp ForeignRef BreakArray
breakarray BreakIndex
ix BreakIndex
cnt
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
back :: forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> m ([Name], BreakIndex, SrcSpan, String)
back BreakIndex
n = forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (forall a. Num a => a -> a -> a
+BreakIndex
n)
forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
forward :: forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> m ([Name], BreakIndex, SrcSpan, String)
forward BreakIndex
n = forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (forall a. Num a => a -> a -> a
subtract BreakIndex
n)
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
moveHist :: forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist BreakIndex -> BreakIndex
fn = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
case InteractiveContext -> [Resume]
ic_resume (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) of
[] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"not stopped at a breakpoint")
(Resume
r:[Resume]
rs) -> do
let ix :: BreakIndex
ix = Resume -> BreakIndex
resumeHistoryIx Resume
r
history :: [History]
history = Resume -> [History]
resumeHistory Resume
r
new_ix :: BreakIndex
new_ix = BreakIndex -> BreakIndex
fn BreakIndex
ix
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([History]
history forall a. [a] -> BreakIndex -> Bool
`lengthLessThan` BreakIndex
new_ix) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"no more logged breakpoints")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BreakIndex
new_ix forall a. Ord a => a -> a -> Bool
< BreakIndex
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"already at the beginning of the history")
let
update_ic :: ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe BreakInfo
mb_info = do
(HscEnv
hsc_env1, [Name]
names, SrcSpan
span, String
decl) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe BreakInfo
mb_info
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env1
r' :: Resume
r' = Resume
r { resumeHistoryIx :: BreakIndex
resumeHistoryIx = BreakIndex
new_ix }
ic' :: InteractiveContext
ic' = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = Resume
r'forall a. a -> [a] -> [a]
:[Resume]
rs }
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic' }
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
names, BreakIndex
new_ix, SrcSpan
span, String
decl)
if BreakIndex
new_ix forall a. Eq a => a -> a -> Bool
== BreakIndex
0
then case Resume
r of
Resume { resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack,
resumeBreakInfo :: Resume -> Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
mb_brkpt } ->
ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe BreakInfo
mb_brkpt
else case [History]
history forall a. [a] -> BreakIndex -> a
!! (BreakIndex
new_ix forall a. Num a => a -> a -> a
- BreakIndex
1) of
History{[String]
ForeignHValue
BreakInfo
historyEnclosingDecls :: [String]
historyBreakInfo :: BreakInfo
historyApStack :: ForeignHValue
historyEnclosingDecls :: History -> [String]
historyApStack :: History -> ForeignHValue
historyBreakInfo :: History -> BreakInfo
..} ->
ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
historyApStack (forall a. a -> Maybe a
Just BreakInfo
historyBreakInfo)
result_fs :: FastString
result_fs :: FastString
result_fs = String -> FastString
fsLit String
"_result"
bindLocalsAtBreakpoint
:: HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint :: HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe BreakInfo
Nothing = do
let exn_occ :: OccName
exn_occ = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"_exception")
span :: SrcSpan
span = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"<unknown>")
Name
exn_name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
exn_occ SrcSpan
span
let e_fs :: FastString
e_fs = String -> FastString
fsLit String
"e"
e_name :: Name
e_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (forall a. Uniquable a => a -> Unique
getUnique FastString
e_fs) (FastString -> OccName
mkTyVarOccFS FastString
e_fs) SrcSpan
span
e_tyvar :: Id
e_tyvar = Name -> Kind -> Id
mkRuntimeUnkTyVar Name
e_name Kind
liftedTypeKind
exn_id :: Id
exn_id = Name -> Kind -> Id
Id.mkVanillaGlobal Name
exn_name (Id -> Kind
mkTyVarTy Id
e_tyvar)
ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id
exn_id]
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp [(Name
exn_name, ForeignHValue
apStack)]
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }, [Name
exn_name], SrcSpan
span, String
"<exception thrown>")
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack_fhv (Just BreakInfo{BreakIndex
Module
breakInfo_number :: BreakIndex
breakInfo_module :: Module
breakInfo_number :: BreakInfo -> BreakIndex
breakInfo_module :: BreakInfo -> Module
..}) = do
let
hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint" forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
breakInfo_module)
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
breaks :: ModBreaks
breaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
info :: CgBreakInfo
info = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint2" forall a b. (a -> b) -> a -> b
$
forall a. BreakIndex -> IntMap a -> Maybe a
IntMap.lookup BreakIndex
breakInfo_number (ModBreaks -> IntMap CgBreakInfo
modBreaks_breakInfo ModBreaks
breaks)
mbVars :: [Maybe (Id, Word16)]
mbVars = CgBreakInfo -> [Maybe (Id, Word16)]
cgb_vars CgBreakInfo
info
result_ty :: Kind
result_ty = CgBreakInfo -> Kind
cgb_resty CgBreakInfo
info
occs :: [OccName]
occs = ModBreaks -> Array BreakIndex [OccName]
modBreaks_vars ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
span :: SrcSpan
span = ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
decl :: String
decl = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ ModBreaks -> Array BreakIndex [String]
modBreaks_decls ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
mbPointers :: [Maybe (Id, Word16)]
mbPointers = forall {b}. Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Id, Word16)]
mbVars
([Id]
ids, [Word16]
offsets, [OccName]
occs') = forall a b c. [Maybe (a, b)] -> [c] -> ([a], [b], [c])
syncOccs [Maybe (Id, Word16)]
mbPointers [OccName]
occs
free_tvs :: [Id]
free_tvs = [Kind] -> [Id]
tyCoVarsOfTypesList (Kind
result_tyforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
ids)
[Maybe ForeignHValue]
mb_hValues <-
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Interp -> ForeignHValue -> BreakIndex -> IO (Maybe ForeignHValue)
getBreakpointVar Interp
interp ForeignHValue
apStack_fhv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word16]
offsets
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isNothing [Maybe ForeignHValue]
mb_hValues) forall a b. (a -> b) -> a -> b
$
Logger -> DynFlags -> BreakIndex -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) BreakIndex
1 forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Warning: _result has been evaluated, some bindings have been lost"
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'I'
let tv_subst :: TCvSubst
tv_subst = UniqSupply -> [Id] -> TCvSubst
newTyVars UniqSupply
us [Id]
free_tvs
([Id]
filtered_ids, [OccName]
occs'') = forall a b. [(a, b)] -> ([a], [b])
unzip
[ (Id
id, OccName
occ) | (Id
id, Just ForeignHValue
_hv, OccName
occ) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
ids [Maybe ForeignHValue]
mb_hValues [OccName]
occs' ]
(TidyEnv
_,[Kind]
tidy_tys) = TidyEnv -> [Kind] -> (TidyEnv, [Kind])
tidyOpenTypes TidyEnv
emptyTidyEnv forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
tv_subst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType) [Id]
filtered_ids
[Id]
new_ids <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M OccName -> Kind -> Id -> IO Id
mkNewId [OccName]
occs'' [Kind]
tidy_tys [Id]
filtered_ids
Name
result_name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env (FastString -> OccName
mkVarOccFS FastString
result_fs) SrcSpan
span
let result_id :: Id
result_id = Name -> Kind -> Id
Id.mkVanillaGlobal Name
result_name
(HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
tv_subst Kind
result_ty)
result_ok :: Bool
result_ok = Id -> Bool
isPointer Id
result_id
final_ids :: [Id]
final_ids | Bool
result_ok = Id
result_id forall a. a -> [a] -> [a]
: [Id]
new_ids
| Bool
otherwise = [Id]
new_ids
ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id]
final_ids
names :: [Name]
names = forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
new_ids
let fhvs :: [ForeignHValue]
fhvs = forall a. [Maybe a] -> [a]
catMaybes [Maybe ForeignHValue]
mb_hValues
Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ForeignHValue]
fhvs)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
result_ok forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp [(Name
result_name, ForeignHValue
apStack_fhv)]
HscEnv
hsc_env1 <- HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env1, if Bool
result_ok then Name
result_nameforall a. a -> [a] -> [a]
:[Name]
names else [Name]
names, SrcSpan
span, String
decl)
where
mkNewId :: OccName -> Type -> Id -> IO Id
mkNewId :: OccName -> Kind -> Id -> IO Id
mkNewId OccName
occ Kind
ty Id
old_id
= do { Name
name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
old_id)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> IdInfo -> Id
Id.mkVanillaGlobalWithInfo Name
name Kind
ty (HasDebugCallStack => Id -> IdInfo
idInfo Id
old_id)) }
newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
newTyVars :: UniqSupply -> [Id] -> TCvSubst
newTyVars UniqSupply
us [Id]
tvs
= [(Id, Kind)] -> TCvSubst
mkTvSubstPrs [ (Id
tv, Id -> Kind
mkTyVarTy (Name -> Kind -> Id
mkRuntimeUnkTyVar Name
name (Id -> Kind
tyVarKind Id
tv)))
| (Id
tv, Unique
uniq) <- [Id]
tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us
, let name :: Name
name = Name -> Unique -> Name
setNameUnique (Id -> Name
tyVarName Id
tv) Unique
uniq ]
isPointer :: Id -> Bool
isPointer Id
id | [PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
id)
, PrimRep -> Bool
isGcPtrRep PrimRep
rep = Bool
True
| Bool
otherwise = Bool
False
nullUnboxed :: Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed (Just (fv :: (Id, b)
fv@(Id
id, b
_)))
| Id -> Bool
isPointer Id
id = forall a. a -> Maybe a
Just (Id, b)
fv
| Bool
otherwise = forall a. Maybe a
Nothing
nullUnboxed Maybe (Id, b)
Nothing = forall a. Maybe a
Nothing
syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
syncOccs :: forall a b c. [Maybe (a, b)] -> [c] -> ([a], [b], [c])
syncOccs [Maybe (a, b)]
mbVs [c]
ocs = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs [Maybe (a, b)]
mbVs [c]
ocs
where
joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
joinOccs :: forall a b c. [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"bindLocalsAtBreakpoint" forall {f :: * -> *} {a} {b} {c}.
Applicative f =>
f (a, b) -> c -> f (a, b, c)
joinOcc
joinOcc :: f (a, b) -> c -> f (a, b, c)
joinOcc f (a, b)
mbV c
oc = (\(a
a,b
b) c
c -> (a
a,b
b,c
c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
mbV forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
oc
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} = do
let tmp_ids :: [Id]
tmp_ids = [Id
id | AnId Id
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
incompletelyTypedIds :: [Id]
incompletelyTypedIds =
[Id
id | Id
id <- [Id]
tmp_ids
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Id -> Bool
noSkolems Id
id
, (OccName -> FastString
occNameFSforall b c a. (b -> c) -> (a -> b) -> a -> c
.Name -> OccName
nameOccNameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name
idName) Id
id forall a. Eq a => a -> a -> Bool
/= FastString
result_fs]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HscEnv -> Name -> IO HscEnv
improveTypes HscEnv
hsc_env (forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
incompletelyTypedIds)
where
noSkolems :: Id -> Bool
noSkolems = Kind -> Bool
noFreeVarsOfType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType
improveTypes :: HscEnv -> Name -> IO HscEnv
improveTypes hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} Name
name = do
let tmp_ids :: [Id]
tmp_ids = [Id
id | AnId Id
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
Just Id
id = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Id
i -> Id -> Name
idName Id
i forall a. Eq a => a -> a -> Bool
== Name
name) [Id]
tmp_ids
if Id -> Bool
noSkolems Id
id
then forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
else do
Maybe Kind
mb_new_ty <- HscEnv -> BreakIndex -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env BreakIndex
10 Id
id
let old_ty :: Kind
old_ty = Id -> Kind
idType Id
id
case Maybe Kind
mb_new_ty of
Maybe Kind
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
Just Kind
new_ty -> do
case HscEnv -> Kind -> Kind -> Maybe TCvSubst
improveRTTIType HscEnv
hsc_env Kind
old_ty Kind
new_ty of
Maybe TCvSubst
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
WARN(True, text (":print failed to calculate the "
++ "improvement for a type")) hsc_env
Just TCvSubst
subst -> do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_rtti String
"RTTI"
DumpFormat
FormatText
([SDoc] -> SDoc
fsep [String -> SDoc
text String
"RTTI Improvement for", forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
equals,
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst])
let ic' :: InteractiveContext
ic' = InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext InteractiveContext
ic TCvSubst
subst
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{hsc_IC :: InteractiveContext
hsc_IC=InteractiveContext
ic'}
pushResume :: HscEnv -> Resume -> HscEnv
pushResume :: HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env Resume
resume = HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }
where
ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext
ictxt0 { ic_resume :: [Resume]
ic_resume = Resume
resume forall a. a -> [a] -> [a]
: InteractiveContext -> [Resume]
ic_resume InteractiveContext
ictxt0 }
abandon :: GhcMonad m => m Bool
abandon :: forall (m :: * -> *). GhcMonad m => m Bool
abandon = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
case [Resume]
resume of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Resume
r:[Resume]
rs -> do
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [Resume]
rs } }
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interp (Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext Resume
r)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
abandonAll :: GhcMonad m => m Bool
abandonAll :: forall (m :: * -> *). GhcMonad m => m Bool
abandonAll = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
case [Resume]
resume of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[Resume]
rs -> do
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [] } }
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interpforall b c a. (b -> c) -> (a -> b) -> a -> c
. Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext) [Resume]
rs
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
data BoundedList a = BL
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
[a]
[a]
nilBL :: Int -> BoundedList a
nilBL :: forall a. BreakIndex -> BoundedList a
nilBL BreakIndex
bound = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
0 BreakIndex
bound [] []
consBL :: a -> BoundedList a -> BoundedList a
consBL :: forall a. a -> BoundedList a -> BoundedList a
consBL a
a (BL BreakIndex
len BreakIndex
bound [a]
left [a]
right)
| BreakIndex
len forall a. Ord a => a -> a -> Bool
< BreakIndex
bound = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL (BreakIndex
lenforall a. Num a => a -> a -> a
+BreakIndex
1) BreakIndex
bound (a
aforall a. a -> [a] -> [a]
:[a]
left) [a]
right
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len BreakIndex
bound [a
a] forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
tail (forall a. [a] -> [a]
reverse [a]
left)
| Bool
otherwise = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len BreakIndex
bound (a
aforall a. a -> [a] -> [a]
:[a]
left) forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
tail [a]
right
toListBL :: BoundedList a -> [a]
toListBL :: forall a. BoundedList a -> [a]
toListBL (BL BreakIndex
_ BreakIndex
_ [a]
left [a]
right) = [a]
left forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
right
fromListBL :: Int -> [a] -> BoundedList a
fromListBL :: forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
bound [a]
l = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL (forall (t :: * -> *) a. Foldable t => t a -> BreakIndex
length [a]
l) BreakIndex
bound [a]
l []
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext :: forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
imports
= do { HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
; Either (ModuleName, String) GlobalRdrEnv
all_env_err <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
findGlobalRdrEnv HscEnv
hsc_env [InteractiveImport]
imports
; case Either (ModuleName, String) GlobalRdrEnv
all_env_err of
Left (ModuleName
mod, String
err) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. GhcException -> IO a
throwGhcExceptionIO (forall {a}. Outputable a => DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags ModuleName
mod String
err)
Right GlobalRdrEnv
all_env -> do {
; let old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
!final_rdr_env :: GlobalRdrEnv
final_rdr_env = GlobalRdrEnv
all_env GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
old_ic
; forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession
HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
old_ic { ic_imports :: [InteractiveImport]
ic_imports = [InteractiveImport]
imports
, ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
final_rdr_env }}}}
where
formatError :: DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags a
mod String
err = String -> GhcException
ProgramError forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Cannot add module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
mod SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"to context:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
err
findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
findGlobalRdrEnv :: HscEnv
-> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
findGlobalRdrEnv HscEnv
hsc_env [InteractiveImport]
imports
= do { GlobalRdrEnv
idecls_env <- HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
idecls
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either (ModuleName, String) GlobalRdrEnv
mkEnv [ModuleName]
imods) of
([], [GlobalRdrEnv]
imods_env) -> forall a b. b -> Either a b
Right (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv GlobalRdrEnv
idecls_env [GlobalRdrEnv]
imods_env)
((ModuleName, String)
err : [(ModuleName, String)]
_, [GlobalRdrEnv]
_) -> forall a b. a -> Either a b
Left (ModuleName, String)
err }
where
idecls :: [LImportDecl GhcPs]
idecls :: [LImportDecl GhcPs]
idecls = [forall a an. a -> LocatedAn an a
noLocA ImportDecl GhcPs
d | IIDecl ImportDecl GhcPs
d <- [InteractiveImport]
imports]
imods :: [ModuleName]
imods :: [ModuleName]
imods = [ModuleName
m | IIModule ModuleName
m <- [InteractiveImport]
imports]
mkEnv :: ModuleName -> Either (ModuleName, String) GlobalRdrEnv
mkEnv ModuleName
mod = case HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod of
Left String
err -> forall a b. a -> Either a b
Left (ModuleName
mod, String
err)
Right GlobalRdrEnv
env -> forall a b. b -> Either a b
Right GlobalRdrEnv
env
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv HomePackageTable
hpt ModuleName
modl
= case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
modl of
Maybe HomeModInfo
Nothing -> forall a b. a -> Either a b
Left String
"not a home module"
Just HomeModInfo
details ->
case forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details) of
Maybe GlobalRdrEnv
Nothing -> forall a b. a -> Either a b
Left String
"not interpreted"
Just GlobalRdrEnv
env -> forall a b. b -> Either a b
Right GlobalRdrEnv
env
getContext :: GhcMonad m => m [InteractiveImport]
getContext :: forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv{ hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic } ->
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> [InteractiveImport]
ic_imports InteractiveContext
ic)
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted :: forall (m :: * -> *). GhcMonad m => Module -> m Bool
moduleIsInterpreted Module
modl = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
h ->
if HomeUnit -> Module -> Bool
notHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
h) Module
modl
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
h) (forall unit. GenModule unit -> ModuleName
moduleName Module
modl) of
Just HomeModInfo
details -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Bool
isJust (forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details)))
Maybe HomeModInfo
_not_a_home_module -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
getInfo :: GhcMonad m => Bool -> Name
-> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
getInfo :: forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo Bool
allInfo Name
name
= forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
do Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env Name
name
case Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff of
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, SDoc
docs) -> do
let rdr_env :: GlobalRdrEnv
rdr_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
let cls_insts' :: [ClsInst]
cls_insts' = forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> NameSet
orphNamesOfClsInst) [ClsInst]
cls_insts
fam_insts' :: [FamInst]
fam_insts' = forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> NameSet
orphNamesOfFamInst) [FamInst]
fam_insts
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts', [FamInst]
fam_insts', SDoc
docs))
where
plausible :: GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env NameSet
names
= Bool
allInfo
Bool -> Bool -> Bool
|| (Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
ok NameSet
names
where
ok :: Name -> Bool
ok Name
n | Name
n forall a. Eq a => a -> a -> Bool
== Name
name = Bool
True
| Name -> Bool
pretendNameIsInScope Name
n = Bool
True
| Name -> Bool
isBuiltInSyntax Name
n = Bool
True
| Name -> Bool
isCTupleTyConName Name
n = Bool
True
| Name -> Bool
isExternalName Name
n = forall a. Maybe a -> Bool
isJust (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
n)
| Bool
otherwise = Bool
True
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope :: forall (m :: * -> *). GhcMonad m => m [Name]
getNamesInScope = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
greMangledName (GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts (InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))))
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope :: forall (m :: * -> *). GhcMonad m => m [RdrName]
getRdrNamesInScope = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let
ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
gbl_rdrenv :: GlobalRdrEnv
gbl_rdrenv = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ic
gbl_names :: [RdrName]
gbl_names = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GlobalRdrElt -> [RdrName]
greRdrNames forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
gbl_rdrenv
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc) [RdrName]
gbl_names)
parseName :: GhcMonad m => String -> m [Name]
parseName :: forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
str = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
do { LocatedN RdrName
lrdr_name <- HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier HscEnv
hsc_env String
str
; HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName HscEnv
hsc_env LocatedN RdrName
lrdr_name }
getDocs :: GhcMonad m
=> Name
-> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
getDocs :: forall (m :: * -> *).
GhcMonad m =>
Name
-> m (Either
GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
getDocs Name
name =
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
case Name -> Maybe Module
nameModule_maybe Name
name of
Maybe Module
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Name -> GetDocsFailure
NameHasNoModule Name
name))
Just Module
mod -> do
if Module -> Bool
isInteractiveModule Module
mod
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left GetDocsFailure
InteractiveName)
else do
ModIface { mi_doc_hdr :: forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr = Maybe HsDocString
mb_doc_hdr
, mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap Map Name HsDocString
dmap
, mi_arg_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs = ArgDocMap Map Name (IntMap HsDocString)
amap
} <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env Module
mod
if forall a. Maybe a -> Bool
isNothing Maybe HsDocString
mb_doc_hdr Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Name HsDocString
dmap Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Name (IntMap HsDocString)
amap
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod Bool
compiled))
else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ( forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap
, forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Name
name Map Name (IntMap HsDocString)
amap))
where
compiled :: Bool
compiled =
case Name -> SrcLoc
nameSrcLoc Name
name of
RealSrcLoc {} -> Bool
False
UnhelpfulLoc {} -> Bool
True
data GetDocsFailure
= NameHasNoModule Name
| NoDocsInIface
Module
Bool
| InteractiveName
instance Outputable GetDocsFailure where
ppr :: GetDocsFailure -> SDoc
ppr (NameHasNoModule Name
name) =
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has no module where we could look for docs."
ppr (NoDocsInIface Module
mod Bool
compiled) = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Can't find any documentation for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.'
, String -> SDoc
text String
"This is probably because the module was"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (if Bool
compiled then String
"compiled" else String
"loaded")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"without '-haddock',"
, String -> SDoc
text String
"but it's also possible that the module contains no documentation."
, String -> SDoc
text String
""
, if Bool
compiled
then String -> SDoc
text String
"Try re-compiling with '-haddock'."
else String -> SDoc
text String
"Try running ':set -haddock' and :load the file again."
]
ppr GetDocsFailure
InteractiveName =
String -> SDoc
text String
"Docs are unavailable for interactive declarations."
exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
exprType :: forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
mode String
expr = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
Kind
ty <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRnExprMode -> String -> IO Kind
hscTcExpr HscEnv
hsc_env TcRnExprMode
mode String
expr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TidyEnv -> Kind -> Kind
tidyType TidyEnv
emptyTidyEnv Kind
ty
typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
typeKind :: forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
typeKind Bool
normalise String
str = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Bool -> String -> IO (Kind, Kind)
hscKcType HscEnv
hsc_env Bool
normalise String
str
getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
getInstancesForType :: forall (m :: * -> *). GhcMonad m => Kind -> m [ClsInst]
getInstancesForType Kind
ty = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)
runTcInteractive HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
HscEnv -> InteractiveContext -> TcM ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
[(ClsInst, [Maybe Kind])]
matches <- Kind -> TcM [(ClsInst, [Maybe Kind])]
findMatchingInstances Kind
ty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ClsInst, [Maybe Kind])]
matches forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ClsInst
-> [Maybe Kind] -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe ClsInst)
checkForExistence
parseInstanceHead :: GhcMonad m => String -> m Type
parseInstanceHead :: forall (m :: * -> *). GhcMonad m => String -> m Kind
parseInstanceHead String
str = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env0 -> do
(Kind
ty, Kind
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
GenLocated SrcSpanAnnA (HsType GhcPs)
ty <- String -> Hsc (LHsType GhcPs)
hscParseType String
str
forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages DecoratedSDoc, Maybe (Kind, Kind))
tcRnType HscEnv
hsc_env ZonkFlexi
SkolemiseFlexi Bool
True GenLocated SrcSpanAnnA (HsType GhcPs)
ty
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty
getDictionaryBindings :: PredType -> TcM CtEvidence
getDictionaryBindings :: Kind -> TcM CtEvidence
getDictionaryBindings Kind
theta = do
Name
dictName <- OccName -> TcM Name
newName (OccName -> OccName
mkDictOcc (String -> OccName
mkVarOcc String
"magic"))
let dict_var :: Id
dict_var = Name -> Kind -> Id
mkVanillaGlobal Name
dictName Kind
theta
CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (SkolemInfo -> CtOrigin
GivenOrigin SkolemInfo
UnkSkol) forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return CtWanted {
ctev_pred :: Kind
ctev_pred = Id -> Kind
varType Id
dict_var,
ctev_dest :: TcEvDest
ctev_dest = Id -> TcEvDest
EvVarDest Id
dict_var,
ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WDeriv,
ctev_loc :: CtLoc
ctev_loc = CtLoc
loc
}
findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
findMatchingInstances :: Kind -> TcM [(ClsInst, [Maybe Kind])]
findMatchingInstances Kind
ty = do
ies :: InstEnvs
ies@(InstEnvs {ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
ie_global, ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
ie_local}) <- TcM InstEnvs
tcGetInstEnvs
let allClasses :: [Class]
allClasses = InstEnv -> [Class]
instEnvClasses InstEnv
ie_global forall a. [a] -> [a] -> [a]
++ InstEnv -> [Class]
instEnvClasses InstEnv
ie_local
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (InstEnvs -> Class -> [(ClsInst, [Maybe Kind])]
try_cls InstEnvs
ies) [Class]
allClasses
where
try_cls :: InstEnvs -> Class -> [(ClsInst, [Maybe Kind])]
try_cls InstEnvs
ies Class
cls
| Just (Kind
_, Kind
arg_kind, Kind
res_kind) <- Kind -> Maybe (Kind, Kind, Kind)
splitFunTy_maybe (TyCon -> Kind
tyConKind forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls)
, Kind -> Bool
tcIsConstraintKind Kind
res_kind
, HasDebugCallStack => Kind -> Kind
Type.typeKind Kind
ty Kind -> Kind -> Bool
`eqType` Kind
arg_kind
, ([(ClsInst, [Maybe Kind])]
matches, [ClsInst]
_, [(ClsInst, [Maybe Kind])]
_) <- Bool
-> InstEnvs
-> Class
-> [Kind]
-> ([(ClsInst, [Maybe Kind])], [ClsInst],
[(ClsInst, [Maybe Kind])])
lookupInstEnv Bool
True InstEnvs
ies Class
cls [Kind
ty]
= [(ClsInst, [Maybe Kind])]
matches
| Bool
otherwise
= []
checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
checkForExistence :: ClsInst
-> [Maybe Kind] -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe ClsInst)
checkForExistence ClsInst
clsInst [Maybe Kind]
mb_inst_tys = do
([Kind]
tys, [Kind]
thetas) <- Id -> [Maybe Kind] -> TcM ([Kind], [Kind])
instDFunType (ClsInst -> Id
is_dfun ClsInst
clsInst) [Maybe Kind]
mb_inst_tys
[CtEvidence]
wanteds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> TcM CtEvidence
getDictionaryBindings [Kind]
thetas
WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
impls } <- [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
wanteds
if forall a. (a -> Bool) -> Bag a -> Bool
allBag Ct -> Bool
allowedSimple Cts
simples Bool -> Bool -> Bool
&& Bag Implication -> Bool
solvedImplics Bag Implication
impls
then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Kind] -> [Kind] -> ClsInst -> ClsInst
substInstArgs [Kind]
tys (forall a. Bag a -> [a]
bagToList (forall a b. (a -> b) -> Bag a -> Bag b
mapBag Ct -> Kind
ctPred Cts
simples)) ClsInst
clsInst
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where
allowedSimple :: Ct -> Bool
allowedSimple :: Ct -> Bool
allowedSimple Ct
ct = Kind -> Bool
isSatisfiablePred (Ct -> Kind
ctPred Ct
ct)
solvedImplics :: Bag Implication -> Bool
solvedImplics :: Bag Implication -> Bool
solvedImplics Bag Implication
impls = forall a. (a -> Bool) -> Bag a -> Bool
allBag (ImplicStatus -> Bool
isSolvedStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implication -> ImplicStatus
ic_status) Bag Implication
impls
isSatisfiablePred :: PredType -> Bool
isSatisfiablePred :: Kind -> Bool
isSatisfiablePred Kind
ty = case Kind -> Maybe (Class, [Kind])
getClassPredTys_maybe Kind
ty of
Just (Class
_, tys :: [Kind]
tys@(Kind
_:[Kind]
_)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTyVarTy [Kind]
tys
Maybe (Class, [Kind])
_ -> Kind -> Bool
isTyVarTy Kind
ty
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (Kind -> VarSet
tyCoVarsOfType (Id -> Kind
idType forall a b. (a -> b) -> a -> b
$ ClsInst -> Id
is_dfun ClsInst
clsInst)))
substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst
substInstArgs :: [Kind] -> [Kind] -> ClsInst -> ClsInst
substInstArgs [Kind]
tys [Kind]
thetas ClsInst
inst = let
subst :: TCvSubst
subst = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TCvSubst
a (Id, Kind)
b -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (TCvSubst -> Id -> Kind -> TCvSubst
extendTvSubstAndInScope TCvSubst
a) (Id, Kind)
b) TCvSubst
empty_subst (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
dfun_tvs [Kind]
tys)
tau :: Kind
tau = Class -> [Kind] -> Kind
mkClassPred Class
cls (HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTheta TCvSubst
subst [Kind]
args)
phi :: Kind
phi = [Kind] -> Kind -> Kind
mkPhiTy [Kind]
thetas Kind
tau
sigma :: Kind
sigma = [TyCoVarBinder] -> Kind -> Kind
mkForAllTys (forall a b. (a -> b) -> [a] -> [b]
map (\Id
v -> forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ArgFlag
Inferred) [Id]
dfun_tvs) Kind
phi
in ClsInst
inst { is_dfun :: Id
is_dfun = (ClsInst -> Id
is_dfun ClsInst
inst) { varType :: Kind
varType = Kind
sigma }}
where
([Id]
dfun_tvs, [Kind]
_, Class
cls, [Kind]
args) = ClsInst -> ([Id], [Kind], Class, [Kind])
instanceSig ClsInst
inst
parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr :: forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr
compileExpr :: GhcMonad m => String -> m HValue
compileExpr :: forall (m :: * -> *). GhcMonad m => String -> m HValue
compileExpr String
expr = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
compileExprRemote :: GhcMonad m => String -> m ForeignHValue
compileExprRemote :: forall (m :: * -> *). GhcMonad m => String -> m ForeignHValue
compileExprRemote String
expr = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote :: forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote expr :: LHsExpr GhcPs
expr@(L SrcSpanAnnA
loc HsExpr GhcPs
_) = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let expr_fs :: FastString
expr_fs = String -> FastString
fsLit String
"_compileParsedExpr"
loc' :: SrcSpan
loc' = forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc
expr_name :: Name
expr_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (forall a. Uniquable a => a -> Unique
getUnique FastString
expr_fs) (FastString -> OccName
mkTyVarOccFS FastString
expr_fs) SrcSpan
loc'
let_stmt :: GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
let_stmt = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds forall a. EpAnn a
noAnn) forall a b. (a -> b) -> a -> b
$
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds AnnSortKey
NoAnnSortKey
(forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc' (forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
expr_name) LHsExpr GhcPs
expr) []
Maybe ([Id], ForeignHValue, FixityEnv)
pstmt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
let_stmt
let (ForeignHValue
hvals_io, FixityEnv
fix_env) = case Maybe ([Id], ForeignHValue, FixityEnv)
pstmt of
Just ([Id
_id], ForeignHValue
hvals_io', FixityEnv
fix_env') -> (ForeignHValue
hvals_io', FixityEnv
fix_env')
Maybe ([Id], ForeignHValue, FixityEnv)
_ -> forall a. String -> a
panic String
"compileParsedExprRemote"
forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env
EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp DynFlags
dflags Bool
False (forall a. a -> EvalExpr a
EvalThis ForeignHValue
hvals_io)
case EvalStatus_ [ForeignHValue] [HValueRef]
status of
EvalComplete Word64
_ (EvalSuccess [ForeignHValue
hval]) -> forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval
EvalComplete Word64
_ (EvalException SerializableException
e) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
EvalStatus_ [ForeignHValue] [HValueRef]
_ -> forall a. String -> a
panic String
"compileParsedExpr"
compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr :: forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
expr = do
ForeignHValue
fhv <- forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote LHsExpr GhcPs
expr
Interp
interp <- HscEnv -> Interp
hscInterp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> ForeignRef a -> IO a
wormhole Interp
interp ForeignHValue
fhv
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr :: forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
expr = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
let loc :: SrcSpanAnnA
loc = forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
to_dyn_expr :: LHsExpr GhcPs
to_dyn_expr = forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
toDynName)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
HValue
hval <- forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
to_dyn_expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b
unsafeCoerce HValue
hval :: Dynamic)
showModule :: GhcMonad m => ModSummary -> m String
showModule :: forall (m :: * -> *). GhcMonad m => ModSummary -> m String
showModule ModSummary
mod_summary =
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
Bool
interpreted <- forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags Bool
interpreted (ExtendedModSummary -> ModuleGraphNode
ModuleNode (ModSummary -> ExtendedModSummary
extendModSummaryNoDeps ModSummary
mod_summary)))
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable :: forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
Maybe HomeModInfo
Nothing -> forall a. String -> a
panic String
"missing linkable"
Just HomeModInfo
mod_info -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info of
Maybe Linkable
Nothing -> Bool
True
Just Linkable
linkable -> Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
linkable)
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
#if defined(HAVE_INTERNAL_INTERPRETER)
obtainTermFromVal :: forall a. HscEnv -> BreakIndex -> Bool -> Kind -> a -> IO Term
obtainTermFromVal HscEnv
hsc_env BreakIndex
bound Bool
force Kind
ty a
x = case Interp -> InterpInstance
interpInstance Interp
interp of
InterpInstance
InternalInterp -> HscEnv -> BreakIndex -> Bool -> Kind -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env BreakIndex
bound Bool
force Kind
ty (forall a b. a -> b
unsafeCoerce a
x)
#else
obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of
#endif
ExternalInterp {} -> forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError
String
"this operation requires -fno-external-interpreter")
where
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId :: HscEnv -> BreakIndex -> Bool -> Id -> IO Term
obtainTermFromId HscEnv
hsc_env BreakIndex
bound Bool
force Id
id = do
ForeignHValue
hv <- Interp -> HscEnv -> Name -> IO ForeignHValue
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
HscEnv -> BreakIndex -> Bool -> Kind -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env BreakIndex
bound Bool
force (Id -> Kind
idType Id
id) ForeignHValue
hv
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType :: HscEnv -> BreakIndex -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env BreakIndex
bound Id
id = do
ForeignHValue
hv <- Interp -> HscEnv -> Name -> IO ForeignHValue
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
HscEnv -> BreakIndex -> Kind -> ForeignHValue -> IO (Maybe Kind)
cvReconstructType HscEnv
hsc_env BreakIndex
bound (Id -> Kind
idType Id
id) ForeignHValue
hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar :: Name -> Kind -> Id
mkRuntimeUnkTyVar Name
name Kind
kind = Name -> Kind -> TcTyVarDetails -> Id
mkTcTyVar Name
name Kind
kind TcTyVarDetails
RuntimeUnk