{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# 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,
mkTopLevEnv,
getNamesInScope,
getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
parseInstanceHead,
getInstancesForType,
getDocs,
GetDocsFailure(..),
showModule,
moduleIsBootOrNotObjectLinkable,
parseExpr, compileParsedExpr,
compileExpr, dynCompileExpr,
compileExprRemote, compileParsedExprRemote,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
) where
import GHC.Prelude
import GHC.Driver.Monad
import GHC.Driver.Main
import GHC.Driver.Errors.Types ( hoistTcRnMessage )
import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Config
import GHC.Rename.Names (importsFromIface)
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.Loader as Loader
import GHC.Hs
import GHC.Core.Class (classTyCon)
import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst )
import GHC.Core.InstEnv
import GHC.Core.Predicate
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCon
import GHC.Core.Type hiding( typeKind )
import qualified GHC.Core.Type as Type
import GHC.Iface.Env ( newInteractiveBinder )
import GHC.Iface.Load ( loadSrcInterface )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Builtin.Names ( toDynName )
import GHC.Builtin.Types ( pretendNameIsInScope )
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Utils.Error
import GHC.Utils.Exception
import GHC.Utils.Logger
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
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.Unique.DSet
import GHC.Types.TyThing
import GHC.Types.Breakpoint
import GHC.Types.Unique.Map
import GHC.Unit
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo
import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal)
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) )
import GHC.Unit.Env
import GHC.IfaceToCore
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import Data.Dynamic
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import Data.List.NonEmpty (NonEmpty)
import System.Directory
import Unsafe.Coerce ( unsafeCoerce )
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext :: forall (m :: * -> *). GhcMonad m => m [Resume]
getResumeContext = (HscEnv -> m [Resume]) -> m [Resume]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ([Resume] -> m [Resume]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Resume] -> m [Resume])
-> (HscEnv -> [Resume]) -> HscEnv -> m [Resume]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveContext -> [Resume]
ic_resume (InteractiveContext -> [Resume])
-> (HscEnv -> InteractiveContext) -> HscEnv -> [Resume]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
hsc_IC)
mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History
mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History
mkHistory HscEnv
hsc_env ForeignHValue
hval InternalBreakpointId
ibi = ForeignHValue -> InternalBreakpointId -> [String] -> History
History ForeignHValue
hval InternalBreakpointId
ibi (HscEnv -> InternalBreakpointId -> [String]
findEnclosingDecls HscEnv
hsc_env InternalBreakpointId
ibi)
getHistoryModule :: History -> Module
getHistoryModule :: History -> Module
getHistoryModule = InternalBreakpointId -> Module
ibi_tick_mod (InternalBreakpointId -> Module)
-> (History -> InternalBreakpointId) -> History -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> InternalBreakpointId
historyBreakpointId
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan HscEnv
hsc_env History
hist =
let ibi :: InternalBreakpointId
ibi = History -> InternalBreakpointId
historyBreakpointId History
hist in
case Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule (InternalBreakpointId -> Module
ibi_tick_mod InternalBreakpointId
ibi) (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) of
Just HomeModInfo
hmi -> ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs (HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi) Array BreakIndex SrcSpan -> BreakIndex -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
ibi
Maybe HomeModInfo
_ -> String -> SrcSpan
forall a. HasCallStack => String -> a
panic String
"getHistorySpan"
findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String]
findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String]
findEnclosingDecls HscEnv
hsc_env InternalBreakpointId
ibi =
let hmi :: HomeModInfo
hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"findEnclosingDecls" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule (InternalBreakpointId -> Module
ibi_tick_mod InternalBreakpointId
ibi) (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
in ModBreaks -> Array BreakIndex [String]
modBreaks_decls (HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi) Array BreakIndex [String] -> BreakIndex -> [String]
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
ibi
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv :: forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
setSession $ hsc_env { hsc_IC = ic { ic_fix_env = 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 = ForeignHValue -> EvalExpr ForeignHValue
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
execSingleStep :: ExecOptions -> SingleStep
execSourceFile :: ExecOptions -> String
execLineNumber :: ExecOptions -> BreakIndex
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execSingleStep :: SingleStep
execSourceFile :: String
execLineNumber :: BreakIndex
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
..} = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
mb_stmt <-
liftIO $
runInteractiveHsc hsc_env $
hscParseStmtWithLocation execSourceFile execLineNumber input
case mb_stmt of
Maybe (GhciLStmt GhcPs)
Nothing -> ExecResult -> m ExecResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right []) Word64
0)
Just GhciLStmt GhcPs
stmt -> GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
forall (m :: * -> *).
GhcMonad m =>
GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' GhciLStmt 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
execSingleStep :: ExecOptions -> SingleStep
execSourceFile :: ExecOptions -> String
execLineNumber :: ExecOptions -> BreakIndex
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execSingleStep :: SingleStep
execSourceFile :: String
execLineNumber :: BreakIndex
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
..} = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
idflags' = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic DynFlags -> WarningFlag -> DynFlags
`wopt_unset` WarningFlag
Opt_WarnUnusedLocalBinds
hsc_env' = HscEnv -> HscEnv
mkInteractiveHscEnv (HscEnv
hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})
r <- liftIO $ hscParsedStmt hsc_env' stmt
case r of
Maybe ([Id], ForeignHValue, FixityEnv)
Nothing ->
ExecResult -> m ExecResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right []) Word64
0)
Just ([Id]
ids, ForeignHValue
hval, FixityEnv
fix_env) -> do
FixityEnv -> m ()
forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env
status <-
m (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD (m (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$
IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$ do
let eval_opts :: EvalOpts
eval_opts = DynFlags -> Bool -> EvalOpts
initEvalOpts DynFlags
idflags' (SingleStep -> Bool
isStep SingleStep
execSingleStep)
Interp
-> EvalOpts
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp EvalOpts
eval_opts (ForeignHValue -> EvalExpr ForeignHValue
execWrap ForeignHValue
hval)
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
bindings = (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic, InteractiveContext -> IcGlobalRdrEnv
ic_gre_cache InteractiveContext
ic)
size = DynFlags -> BreakIndex
ghciHistSize DynFlags
idflags'
handleRunStatus execSingleStep stmt_text bindings ids
status (emptyHistory size)
runDecls :: GhcMonad m => String -> m [Name]
runDecls :: forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls = String -> BreakIndex -> String -> m [Name]
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
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
runParsedDecls decls
runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls :: forall (m :: * -> *). GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls [LHsDecl GhcPs]
decls = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
setSession $ hsc_env { hsc_IC = ic }
hsc_env <- getSession
hsc_env' <- liftIO $ rttiEnvironment hsc_env
setSession hsc_env'
return $ filter (not . isDerivedOccName . nameOccName)
$ map getName tyThings
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD m a
m = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
case interpInstance <$> hsc_interp 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
dir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
case ic_cwd ic of
Just String
dir -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir
Maybe String
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
return dir
reset_cwd :: String -> m ()
reset_cwd String
orig_dir = do
virt_dir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
hsc_env <- getSession
let old_IC = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
m String -> (String -> m ()) -> (String -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m String
set_cwd String -> m ()
forall {m :: * -> *}. GhcMonad m => String -> m ()
reset_cwd ((String -> m a) -> m a) -> (String -> m a) -> m a
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 = (HscEnv -> m (ImportDecl GhcPs)) -> m (ImportDecl GhcPs)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (ImportDecl GhcPs)) -> m (ImportDecl GhcPs))
-> (HscEnv -> m (ImportDecl GhcPs)) -> m (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> IO (ImportDecl GhcPs) -> m (ImportDecl GhcPs)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ImportDecl GhcPs) -> m (ImportDecl GhcPs))
-> IO (ImportDecl GhcPs) -> m (ImportDecl GhcPs)
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 = BreakIndex -> BoundedList History
forall a. BreakIndex -> BoundedList a
nilBL BreakIndex
size
handleRunStatus :: GhcMonad m
=> SingleStep -> String
-> ResumeBindings
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus :: forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], IcGlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
step String
expr ([TyThing], IcGlobalRdrEnv)
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 HValueRef
apStack_ref (Just EvalBreakpoint
eval_break) RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
_ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let ibi = HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) EvalBreakpoint
eval_break
let hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (InternalBreakpointId -> Module
ibi_tick_mod InternalBreakpointId
ibi))
breaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
b <- liftIO $
breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi)
if b
then not_tracing
else do
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let !history' = HscEnv -> ForeignHValue -> InternalBreakpointId -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack_fhv InternalBreakpointId
ibi History -> BoundedList History -> BoundedList History
forall a. a -> BoundedList a -> BoundedList a
`consBL` BoundedList History
history
fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
let eval_opts = DynFlags -> Bool -> EvalOpts
initEvalOpts DynFlags
dflags Bool
True
status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
handleRunStatus RunAndLogSteps expr bindings final_ids
status history'
| Bool
otherwise
= m ExecResult
not_tracing
not_tracing :: m ExecResult
not_tracing
| EvalBreak HValueRef
apStack_ref Maybe EvalBreakpoint
maybe_break RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let ibi = HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (EvalBreakpoint -> InternalBreakpointId)
-> Maybe EvalBreakpoint -> Maybe InternalBreakpointId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EvalBreakpoint
maybe_break
(hsc_env1, names, span, decl) <- liftIO $
bindLocalsAtBreakpoint hsc_env apStack_fhv ibi
let
resume = Resume
{ resumeStmt :: String
resumeStmt = String
expr
, resumeContext :: ForeignRef (ResumeContext [HValueRef])
resumeContext = ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv
, resumeBindings :: ([TyThing], IcGlobalRdrEnv)
resumeBindings = ([TyThing], IcGlobalRdrEnv)
bindings
, resumeFinalIds :: [Id]
resumeFinalIds = [Id]
final_ids
, resumeApStack :: ForeignHValue
resumeApStack = ForeignHValue
apStack_fhv
, resumeBreakpointId :: Maybe InternalBreakpointId
resumeBreakpointId = Maybe InternalBreakpointId
ibi
, resumeSpan :: SrcSpan
resumeSpan = SrcSpan
span
, resumeHistory :: [History]
resumeHistory = BoundedList History -> [History]
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 -> Resume -> HscEnv
pushResume HscEnv
hsc_env1 Resume
resume
setSession hsc_env2
return (ExecBreak names ibi)
| EvalComplete Word64
allocs (EvalSuccess [ForeignHValue]
hvals) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= do hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let final_ic = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) [Id]
final_ids
final_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
forall a. NamedThing a => a -> Name
getName [Id]
final_ids
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
setSession hsc_env'
return (ExecComplete (Right final_names) allocs)
| EvalComplete Word64
alloc (EvalException SerializableException
e) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
= ExecResult -> m ExecResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (SomeException -> Either SomeException [Name]
forall a b. a -> Either a b
Left (SerializableException -> SomeException
fromSerializableException SerializableException
e)) Word64
alloc)
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
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
case resume of
[] -> IO ExecResult -> m ExecResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExecResult -> m ExecResult) -> IO ExecResult -> m ExecResult
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ExecResult
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,IcGlobalRdrEnv
resume_gre_cache) = Resume -> ([TyThing], IcGlobalRdrEnv)
resumeBindings Resume
r
ic' :: InteractiveContext
ic' = InteractiveContext
ic { ic_tythings = resume_tmp_te,
ic_gre_cache = resume_gre_cache,
ic_resume = rs }
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC = ic' }
let old_names :: [Name]
old_names = (TyThing -> Name) -> [TyThing] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> Name
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 = TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing
, Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
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
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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], IcGlobalRdrEnv)
resumeBindings = ([TyThing], IcGlobalRdrEnv)
bindings
, resumeFinalIds :: Resume -> [Id]
resumeFinalIds = [Id]
final_ids
, resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack
, resumeBreakpointId :: Resume -> Maybe InternalBreakpointId
resumeBreakpointId = Maybe InternalBreakpointId
mb_brkpt
, resumeSpan :: Resume -> SrcSpan
resumeSpan = SrcSpan
span
, resumeHistory :: Resume -> [History]
resumeHistory = [History]
hist } ->
m ExecResult -> m ExecResult
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD (m ExecResult -> m ExecResult) -> m ExecResult -> m ExecResult
forall a b. (a -> b) -> a -> b
$ do
case (Maybe InternalBreakpointId
mb_brkpt, Maybe BreakIndex
mbCnt) of
(Just InternalBreakpointId
brkpt, Just BreakIndex
cnt) -> HscEnv -> BreakpointId -> BreakIndex -> m ()
forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakpointId -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env (InternalBreakpointId -> BreakpointId
toBreakpointId InternalBreakpointId
brkpt) BreakIndex
cnt
(Maybe InternalBreakpointId, Maybe BreakIndex)
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let eval_opts :: EvalOpts
eval_opts = DynFlags -> Bool -> EvalOpts
initEvalOpts DynFlags
dflags (SingleStep -> Bool
isStep SingleStep
step)
status <- IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$ Interp
-> EvalOpts
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt Interp
interp EvalOpts
eval_opts ForeignRef (ResumeContext [HValueRef])
fhv
let prevHistoryLst = BreakIndex -> [History] -> BoundedList History
forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
hist' = case Maybe InternalBreakpointId
mb_brkpt of
Maybe InternalBreakpointId
Nothing -> BoundedList History
prevHistoryLst
Just InternalBreakpointId
bi
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Bool
canLogSpan SrcSpan
span -> BoundedList History
prevHistoryLst
| Bool
otherwise -> HscEnv -> ForeignHValue -> InternalBreakpointId -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack InternalBreakpointId
bi History -> BoundedList History -> BoundedList History
forall a. a -> BoundedList a -> BoundedList a
`consBL`
BreakIndex -> [History] -> BoundedList History
forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
handleRunStatus step expr bindings final_ids status hist'
setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m ()
setupBreakpoint :: forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakpointId -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env BreakpointId
bi BreakIndex
cnt = do
let modl :: Module
modl = BreakpointId -> Module
bi_tick_mod BreakpointId
bi
breaks :: HscEnv -> GenModule unit -> ModBreaks
breaks HscEnv
hsc_env GenModule unit
modl = HomeModInfo -> ModBreaks
getModBreaks (HomeModInfo -> ModBreaks) -> HomeModInfo -> ModBreaks
forall a b. (a -> b) -> a -> b
$ String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"setupBreakpoint" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (GenModule unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule unit
modl)
modBreaks :: ModBreaks
modBreaks = HscEnv -> Module -> 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
_ <- IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp
-> ForeignRef BreakArray -> BreakIndex -> BreakIndex -> IO ()
GHCi.storeBreakpoint Interp
interp ForeignRef BreakArray
breakarray (BreakpointId -> BreakIndex
bi_tick_index BreakpointId
bi) BreakIndex
cnt
pure ()
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
back :: forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> m ([Name], BreakIndex, SrcSpan, String)
back BreakIndex
n = (BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (BreakIndex -> BreakIndex -> BreakIndex
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 = (BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (BreakIndex -> BreakIndex -> BreakIndex
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
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
case ic_resume (hsc_IC hsc_env) of
[] -> IO ([Name], BreakIndex, SrcSpan, String)
-> m ([Name], BreakIndex, SrcSpan, String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Name], BreakIndex, SrcSpan, String)
-> m ([Name], BreakIndex, SrcSpan, String))
-> IO ([Name], BreakIndex, SrcSpan, String)
-> m ([Name], BreakIndex, SrcSpan, String)
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ([Name], BreakIndex, SrcSpan, String)
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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([History]
history [History] -> BreakIndex -> Bool
forall a. [a] -> BreakIndex -> Bool
`lengthLessThan` BreakIndex
new_ix) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"no more logged breakpoints")
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BreakIndex
new_ix BreakIndex -> BreakIndex -> Bool
forall a. Ord a => a -> a -> Bool
< BreakIndex
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"already at the beginning of the history")
let
update_ic :: ForeignHValue
-> Maybe InternalBreakpointId
-> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe InternalBreakpointId
mb_info = do
(hsc_env1, names, span, decl) <-
IO (HscEnv, [Name], SrcSpan, String)
-> m (HscEnv, [Name], SrcSpan, String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HscEnv, [Name], SrcSpan, String)
-> m (HscEnv, [Name], SrcSpan, String))
-> IO (HscEnv, [Name], SrcSpan, String)
-> m (HscEnv, [Name], SrcSpan, String)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ForeignHValue
-> Maybe InternalBreakpointId
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe InternalBreakpointId
mb_info
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env1
r' = Resume
r { resumeHistoryIx = new_ix }
ic' = InteractiveContext
ic { ic_resume = r':rs }
setSession hsc_env1{ hsc_IC = ic' }
return (names, new_ix, span, decl)
if BreakIndex
new_ix BreakIndex -> BreakIndex -> Bool
forall a. Eq a => a -> a -> Bool
== BreakIndex
0
then case Resume
r of
Resume { resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack,
resumeBreakpointId :: Resume -> Maybe InternalBreakpointId
resumeBreakpointId = Maybe InternalBreakpointId
mb_brkpt } ->
ForeignHValue
-> Maybe InternalBreakpointId
-> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe InternalBreakpointId
mb_brkpt
else case [History]
history [History] -> BreakIndex -> History
forall a. HasCallStack => [a] -> BreakIndex -> a
!! (BreakIndex
new_ix BreakIndex -> BreakIndex -> BreakIndex
forall a. Num a => a -> a -> a
- BreakIndex
1) of
History{[String]
ForeignHValue
InternalBreakpointId
historyBreakpointId :: History -> InternalBreakpointId
historyApStack :: ForeignHValue
historyBreakpointId :: InternalBreakpointId
historyEnclosingDecls :: [String]
historyEnclosingDecls :: History -> [String]
historyApStack :: History -> ForeignHValue
..} ->
ForeignHValue
-> Maybe InternalBreakpointId
-> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
historyApStack (InternalBreakpointId -> Maybe InternalBreakpointId
forall a. a -> Maybe a
Just InternalBreakpointId
historyBreakpointId)
result_fs :: FastString
result_fs :: FastString
result_fs = String -> FastString
fsLit String
"_result"
bindLocalsAtBreakpoint
:: HscEnv
-> ForeignHValue
-> Maybe InternalBreakpointId
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint :: HscEnv
-> ForeignHValue
-> Maybe InternalBreakpointId
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe InternalBreakpointId
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>")
exn_name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
exn_occ SrcSpan
span
let e_fs = String -> FastString
fsLit String
"e"
e_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
e_fs) (FastString -> OccName
mkTyVarOccFS FastString
e_fs) SrcSpan
span
e_tyvar = Name -> Kind -> Id
mkRuntimeUnkTyVar Name
e_name Kind
liftedTypeKind
exn_id = HasDebugCallStack => Name -> Kind -> Id
Name -> Kind -> Id
Id.mkVanillaGlobal Name
exn_name (Id -> Kind
mkTyVarTy Id
e_tyvar)
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id
exn_id]
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
Loader.extendLoadedEnv interp [(exn_name, apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack_fhv (Just InternalBreakpointId
ibi) = do
let
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
info_mod :: Module
info_mod = InternalBreakpointId -> Module
ibi_info_mod InternalBreakpointId
ibi
info_hmi :: HomeModInfo
info_hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
info_mod)
info_brks :: ModBreaks
info_brks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
info_hmi
info :: CgBreakInfo
info = String -> Maybe CgBreakInfo -> CgBreakInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint2" (Maybe CgBreakInfo -> CgBreakInfo)
-> Maybe CgBreakInfo -> CgBreakInfo
forall a b. (a -> b) -> a -> b
$ BreakIndex -> IntMap CgBreakInfo -> Maybe CgBreakInfo
forall a. BreakIndex -> IntMap a -> Maybe a
IntMap.lookup (InternalBreakpointId -> BreakIndex
ibi_info_index InternalBreakpointId
ibi) (ModBreaks -> IntMap CgBreakInfo
modBreaks_breakInfo ModBreaks
info_brks)
tick_mod :: Module
tick_mod = InternalBreakpointId -> Module
ibi_tick_mod InternalBreakpointId
ibi
tick_hmi :: HomeModInfo
tick_hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
tick_mod)
tick_brks :: ModBreaks
tick_brks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
tick_hmi
occs :: [OccName]
occs = ModBreaks -> Array BreakIndex [OccName]
modBreaks_vars ModBreaks
tick_brks Array BreakIndex [OccName] -> BreakIndex -> [OccName]
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
ibi
span :: SrcSpan
span = ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs ModBreaks
tick_brks Array BreakIndex SrcSpan -> BreakIndex -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
ibi
decl :: String
decl = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ModBreaks -> Array BreakIndex [String]
modBreaks_decls ModBreaks
tick_brks Array BreakIndex [String] -> BreakIndex -> [String]
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
ibi
(mbVars, result_ty) <- HscEnv
-> IfG ([Maybe (Id, Word)], Kind) -> IO ([Maybe (Id, Word)], Kind)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env
(IfG ([Maybe (Id, Word)], Kind) -> IO ([Maybe (Id, Word)], Kind))
-> IfG ([Maybe (Id, Word)], Kind) -> IO ([Maybe (Id, Word)], Kind)
forall a b. (a -> b) -> a -> b
$ Module
-> SDoc
-> IsBootInterface
-> IfL ([Maybe (Id, Word)], Kind)
-> IfG ([Maybe (Id, Word)], Kind)
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
info_mod (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"debugger") IsBootInterface
NotBoot
(IfL ([Maybe (Id, Word)], Kind) -> IfG ([Maybe (Id, Word)], Kind))
-> IfL ([Maybe (Id, Word)], Kind) -> IfG ([Maybe (Id, Word)], Kind)
forall a b. (a -> b) -> a -> b
$ CgBreakInfo -> IfL ([Maybe (Id, Word)], Kind)
hydrateCgBreakInfo CgBreakInfo
info
let
mbPointers = Maybe (Id, Word) -> Maybe (Id, Word)
forall {b}. Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed (Maybe (Id, Word) -> Maybe (Id, Word))
-> [Maybe (Id, Word)] -> [Maybe (Id, Word)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Id, Word)]
mbVars
(ids, offsets, occs') = syncOccs mbPointers occs
free_tvs = [Kind] -> [Id]
tyCoVarsOfTypesWellScoped (Kind
result_tyKind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:(Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
ids)
mb_hValues <-
mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_logger hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
us <- mkSplitUniqSupply 'I'
let tv_subst = UniqSupply -> [Id] -> Subst
newTyVars UniqSupply
us [Id]
free_tvs
(filtered_ids, occs'') = unzip
[ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
tidy_tys = TidyEnv -> [Kind] -> [Kind]
tidyOpenTypes TidyEnv
emptyTidyEnv ([Kind] -> [Kind]) -> [Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$
(Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
tv_subst (Kind -> Kind) -> (Id -> Kind) -> Id -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType) [Id]
filtered_ids
new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
let result_id = HasDebugCallStack => Name -> Kind -> Id
Name -> Kind -> Id
Id.mkVanillaGlobal Name
result_name
(HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
tv_subst Kind
result_ty)
result_ok = Id -> Bool
isPointer Id
result_id
final_ids | Bool
result_ok = Id
result_id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
new_ids
| Bool
otherwise = [Id]
new_ids
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id]
final_ids
names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
new_ids
let fhvs = [Maybe ForeignHValue] -> [ForeignHValue]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ForeignHValue]
mb_hValues
Loader.extendLoadedEnv interp (zip names fhvs)
when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span, decl)
where
mkNewId :: OccName -> Type -> Id -> IO Id
mkNewId :: OccName -> Kind -> Id -> IO Id
mkNewId OccName
occ Kind
ty Id
old_id
= do { name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env (FastString -> OccName
mkVarOccFS (OccName -> FastString
occNameFS OccName
occ)) (Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
old_id)
; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) }
newTyVars :: UniqSupply -> [TcTyVar] -> Subst
newTyVars :: UniqSupply -> [Id] -> Subst
newTyVars UniqSupply
us [Id]
tvs = (Subst -> (Id, Unique) -> Subst)
-> Subst -> [(Id, Unique)] -> Subst
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Subst -> (Id, Unique) -> Subst
new_tv Subst
emptySubst ([Id]
tvs [Id] -> [Unique] -> [(Id, Unique)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us)
new_tv :: Subst -> (Id, Unique) -> Subst
new_tv Subst
subst (Id
tv,Unique
uniq) = Subst -> Id -> Id -> Subst
extendTCvSubstWithClone Subst
subst Id
tv Id
new_tv
where
new_tv :: Id
new_tv = Name -> Kind -> Id
mkRuntimeUnkTyVar (Name -> Unique -> Name
setNameUnique (Id -> Name
tyVarName Id
tv) Unique
uniq)
(HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
subst (Id -> Kind
tyVarKind Id
tv))
isPointer :: Id -> Bool
isPointer Id
id | [PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
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 = (Id, b) -> Maybe (Id, b)
forall a. a -> Maybe a
Just (Id, b)
fv
| Bool
otherwise = Maybe (Id, b)
forall a. Maybe a
Nothing
nullUnboxed Maybe (Id, b)
Nothing = Maybe (Id, b)
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 = [(a, b, c)] -> ([a], [b], [c])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(a, b, c)] -> ([a], [b], [c])) -> [(a, b, c)] -> ([a], [b], [c])
forall a b. (a -> b) -> a -> b
$ [Maybe (a, b, c)] -> [(a, b, c)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (a, b, c)] -> [(a, b, c)])
-> [Maybe (a, b, c)] -> [(a, b, c)]
forall a b. (a -> b) -> a -> b
$ [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
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 = String
-> (Maybe (a, b) -> c -> Maybe (a, b, c))
-> [Maybe (a, b)]
-> [c]
-> [Maybe (a, b, c)]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"bindLocalsAtBreakpoint" Maybe (a, b) -> c -> Maybe (a, b, c)
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)) ((a, b) -> c -> (a, b, c)) -> f (a, b) -> f (c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
mbV f (c -> (a, b, c)) -> f c -> f (a, b, c)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> f c
forall a. a -> f a
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Bool
noSkolems Id
id
, (OccName -> FastString
occNameFS(OccName -> FastString) -> (Id -> OccName) -> Id -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Name -> OccName
nameOccName(Name -> OccName) -> (Id -> Name) -> Id -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name
idName) Id
id FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FastString
result_fs]
(HscEnv -> Name -> IO HscEnv) -> HscEnv -> [Name] -> IO HscEnv
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 ((Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
incompletelyTypedIds)
where
noSkolems :: Id -> Bool
noSkolems = Kind -> Bool
noFreeVarsOfType (Kind -> Bool) -> (Id -> Kind) -> Id -> Bool
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 = (Id -> Bool) -> [Id] -> Maybe Id
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Id
i -> Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) [Id]
tmp_ids
if Id -> Bool
noSkolems Id
id
then HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
else do
mb_new_ty <- HscEnv -> BreakIndex -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env BreakIndex
10 Id
id
let old_ty = Id -> Kind
idType Id
id
case mb_new_ty of
Maybe Kind
Nothing -> HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
Just Kind
new_ty -> do
case HscEnv -> Kind -> Kind -> Maybe Subst
improveRTTIType HscEnv
hsc_env Kind
old_ty Kind
new_ty of
Maybe Subst
Nothing -> Bool -> String -> SDoc -> IO HscEnv -> IO HscEnv
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True (String
":print failed to calculate the "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"improvement for a type")
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"old_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
debugPprType Kind
old_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"new_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
debugPprType Kind
new_ty ]) (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
Just Subst
subst -> do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rtti String
"RTTI"
DumpFormat
FormatText
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RTTI Improvement for", Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
forall doc. IsLine doc => doc
equals,
Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst])
let ic' :: InteractiveContext
ic' = InteractiveContext -> Subst -> InteractiveContext
substInteractiveContext InteractiveContext
ic Subst
subst
HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{hsc_IC=ic'}
pushResume :: HscEnv -> Resume -> HscEnv
pushResume :: HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env Resume
resume = HscEnv
hsc_env { hsc_IC = ictxt1 }
where
ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext
ictxt0 { ic_resume = resume : ic_resume ictxt0 }
abandon :: GhcMonad m => m Bool
abandon :: forall (m :: * -> *). GhcMonad m => m Bool
abandon = do
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
case resume of
[] -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Resume
r:[Resume]
rs -> do
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC = ic { ic_resume = rs } }
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interp (Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext Resume
r)
Bool -> m Bool
forall a. a -> m a
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
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
case resume of
[] -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[Resume]
rs -> do
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC = ic { ic_resume = [] } }
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Resume -> IO ()) -> [Resume] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interp(ForeignRef (ResumeContext [HValueRef]) -> IO ())
-> (Resume -> ForeignRef (ResumeContext [HValueRef]))
-> Resume
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext) [Resume]
rs
Bool -> m Bool
forall a. a -> m a
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 = BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
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 BreakIndex -> BreakIndex -> Bool
forall a. Ord a => a -> a -> Bool
< BreakIndex
bound = BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL (BreakIndex
lenBreakIndex -> BreakIndex -> BreakIndex
forall a. Num a => a -> a -> a
+BreakIndex
1) BreakIndex
bound (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
left) [a]
right
| [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right = BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len BreakIndex
bound [a
a] ([a] -> BoundedList a) -> [a] -> BoundedList a
forall a b. (a -> b) -> a -> b
$! [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
left)
| Bool
otherwise = BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len BreakIndex
bound (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
left) ([a] -> BoundedList a) -> [a] -> BoundedList a
forall a b. (a -> b) -> a -> b
$! [a] -> [a]
forall a. HasCallStack => [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 [a] -> [a] -> [a]
forall a. [a] -> [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 = BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL ([a] -> BreakIndex
forall a. [a] -> BreakIndex
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 { hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
; let dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
; case all_env_err of
Left (ModuleName
mod, String
err) ->
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (DynFlags -> ModuleName -> String -> GhcException
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_gre_cache :: IcGlobalRdrEnv
final_gre_cache = InteractiveContext -> IcGlobalRdrEnv
ic_gre_cache InteractiveContext
old_ic IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv
`replaceImportEnv` GlobalRdrEnv
all_env
; HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession
HscEnv
hsc_env{ hsc_IC = old_ic { ic_imports = imports
, ic_gre_cache = final_gre_cache }}}}
where
formatError :: DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags a
mod String
err = String -> GhcException
ProgramError (String -> GhcException)
-> (SDoc -> String) -> SDoc -> GhcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> GhcException) -> SDoc -> GhcException
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cannot add module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to context:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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 { idecls_env <- HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
idecls
; partitionWithM mkEnv imods >>= \case
((ModuleName, String)
err : [(ModuleName, String)]
_, [GlobalRdrEnv]
_) -> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv))
-> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ (ModuleName, String) -> Either (ModuleName, String) GlobalRdrEnv
forall a b. a -> Either a b
Left (ModuleName, String)
err
([], [GlobalRdrEnv]
imods_env) -> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv))
-> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> Either (ModuleName, String) GlobalRdrEnv
forall a b. b -> Either a b
Right ((GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrEnv] -> GlobalRdrEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv GlobalRdrEnv
idecls_env [GlobalRdrEnv]
imods_env)
}
where
idecls :: [LImportDecl GhcPs]
idecls :: [LImportDecl GhcPs]
idecls = [ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e 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 -> IO (Either (ModuleName, String) GlobalRdrEnv)
mkEnv ModuleName
mod = HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)
mkTopLevEnv HscEnv
hsc_env ModuleName
mod IO (Either String GlobalRdrEnv)
-> (Either String GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv))
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left String
err -> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv))
-> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ (ModuleName, String) -> Either (ModuleName, String) GlobalRdrEnv
forall a b. a -> Either a b
Left (ModuleName
mod, String
err)
Right GlobalRdrEnv
env -> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv))
-> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> Either (ModuleName, String) GlobalRdrEnv
forall a b. b -> Either a b
Right GlobalRdrEnv
env
mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)
mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)
mkTopLevEnv HscEnv
hsc_env ModuleName
modl
= case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
modl of
Maybe HomeModInfo
Nothing -> Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv))
-> Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ String -> Either String GlobalRdrEnv
forall a b. a -> Either a b
Left String
"not a home module"
Just HomeModInfo
details ->
case ModIface_ 'ModIfaceFinal -> Maybe IfaceTopEnv
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe IfaceTopEnv
mi_top_env (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
details) of
Maybe IfaceTopEnv
Nothing -> Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv))
-> Either String GlobalRdrEnv -> IO (Either String GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ String -> Either String GlobalRdrEnv
forall a b. a -> Either a b
Left String
"not interpreted"
Just (IfaceTopEnv IfGlobalRdrEnv
exports [IfaceImport]
imports) -> do
imports_env <-
HscEnv -> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env
(Hsc GlobalRdrEnv -> IO GlobalRdrEnv)
-> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv))
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env
(TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv))
-> TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ ([GlobalRdrEnv] -> GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv]
-> TcRn GlobalRdrEnv
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrEnv] -> GlobalRdrEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv GlobalRdrEnv
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv)
(IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv] -> TcRn GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv]
-> TcRn GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ [IfaceImport]
-> (IfaceImport -> TcRn GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [IfaceImport]
imports ((IfaceImport -> TcRn GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv])
-> (IfaceImport -> TcRn GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrEnv]
forall a b. (a -> b) -> a -> b
$ \IfaceImport
iface_import -> do
let ImpUserSpec ImpDeclSpec
spec ImpUserList
details = HscEnv -> IfaceImport -> ImportUserSpec
tcIfaceImport HscEnv
hsc_env IfaceImport
iface_import
iface <- SDoc
-> ModuleName
-> IsBootInterface
-> PkgQual
-> RnM (ModIface_ 'ModIfaceFinal)
loadSrcInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imported by GHCi") (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImpDeclSpec -> Module
is_mod ImpDeclSpec
spec) (ImpDeclSpec -> IsBootInterface
is_isboot ImpDeclSpec
spec) (ImpDeclSpec -> PkgQual
is_pkg_qual ImpDeclSpec
spec)
pure $ case details of
ImpUserList
ImpUserAll -> HscEnv
-> ModIface_ 'ModIfaceFinal
-> ImpDeclSpec
-> Maybe NameSet
-> GlobalRdrEnv
importsFromIface HscEnv
hsc_env ModIface_ 'ModIfaceFinal
iface ImpDeclSpec
spec Maybe NameSet
forall a. Maybe a
Nothing
ImpUserEverythingBut NameSet
ns -> HscEnv
-> ModIface_ 'ModIfaceFinal
-> ImpDeclSpec
-> Maybe NameSet
-> GlobalRdrEnv
importsFromIface HscEnv
hsc_env ModIface_ 'ModIfaceFinal
iface ImpDeclSpec
spec (NameSet -> Maybe NameSet
forall a. a -> Maybe a
Just NameSet
ns)
ImpUserExplicit GlobalRdrEnv
x -> GlobalRdrEnv
x
let get_GRE_info Name
nm = TyThing -> GREInfo
tyThingGREInfo (TyThing -> GREInfo) -> IO TyThing -> IO GREInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
nm
let exports_env = (Name -> IO GREInfo) -> IfGlobalRdrEnv -> GlobalRdrEnv
forall info noInfo.
(Name -> IO info) -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info
hydrateGlobalRdrEnv Name -> IO GREInfo
get_GRE_info IfGlobalRdrEnv
exports
pure $ Right $ plusGlobalRdrEnv imports_env exports_env
where
hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
getContext :: GhcMonad m => m [InteractiveImport]
getContext :: forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext = (HscEnv -> m [InteractiveImport]) -> m [InteractiveImport]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [InteractiveImport]) -> m [InteractiveImport])
-> (HscEnv -> m [InteractiveImport]) -> m [InteractiveImport]
forall a b. (a -> b) -> a -> b
$ \HscEnv{ hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic } ->
[InteractiveImport] -> m [InteractiveImport]
forall a. a -> m a
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 = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
h ->
if HomeUnit -> Module -> Bool
notHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
h) Module
modl
then Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
h) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
modl) of
Just HomeModInfo
details -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe IfaceTopEnv -> Bool
forall a. Maybe a -> Bool
isJust (ModIface_ 'ModIfaceFinal -> Maybe IfaceTopEnv
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe IfaceTopEnv
mi_top_env (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
details)))
Maybe HomeModInfo
_not_a_home_module -> Bool -> m Bool
forall a. a -> m a
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
= (HscEnv -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> (HscEnv
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
do mb_stuff <- IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env Name
name
case mb_stuff of
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
Nothing -> Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
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
icReaderEnv (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
let cls_insts' :: [ClsInst]
cls_insts' = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env (NameSet -> Bool) -> (ClsInst -> NameSet) -> ClsInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> NameSet
orphNamesOfClsInst) [ClsInst]
cls_insts
fam_insts' :: [FamInst]
fam_insts' = (FamInst -> Bool) -> [FamInst] -> [FamInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env (NameSet -> Bool) -> (FamInst -> NameSet) -> FamInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> NameSet
orphNamesOfFamInst) [FamInst]
fam_insts
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Bool
True
| Name -> Bool
pretendNameIsInScope Name
n = Bool
True
| Name -> Bool
isExternalName Name
n = Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a. Maybe a -> Bool
isJust (GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env Name
n)
| Bool
otherwise = Bool
True
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope :: forall (m :: * -> *). GhcMonad m => m [Name]
getNamesInScope = (HscEnv -> m [Name]) -> m [Name]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [Name]) -> m [Name])
-> (HscEnv -> m [Name]) -> m [Name]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
[Name] -> m [Name]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> m [Name]) -> [Name] -> m [Name]
forall a b. (a -> b) -> a -> b
$ (GlobalRdrEltX GREInfo -> Name)
-> [GlobalRdrEltX GREInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrEltX GREInfo -> Name
forall info. GlobalRdrEltX info -> Name
greName ([GlobalRdrEltX GREInfo] -> [Name])
-> [GlobalRdrEltX GREInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [GlobalRdrEltX GREInfo]
forall info. GlobalRdrEnvX info -> [GlobalRdrEltX info]
globalRdrEnvElts (InteractiveContext -> GlobalRdrEnv
icReaderEnv (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope :: forall (m :: * -> *). GhcMonad m => m [RdrName]
getRdrNamesInScope = (HscEnv -> m [RdrName]) -> m [RdrName]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [RdrName]) -> m [RdrName])
-> (HscEnv -> m [RdrName]) -> m [RdrName]
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
icReaderEnv InteractiveContext
ic
gbl_names :: [RdrName]
gbl_names = (GlobalRdrEltX GREInfo -> [RdrName])
-> [GlobalRdrEltX GREInfo] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GlobalRdrEltX GREInfo -> [RdrName]
forall info. GlobalRdrEltX info -> [RdrName]
greRdrNames ([GlobalRdrEltX GREInfo] -> [RdrName])
-> [GlobalRdrEltX GREInfo] -> [RdrName]
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [GlobalRdrEltX GREInfo]
forall info. GlobalRdrEnvX info -> [GlobalRdrEltX info]
globalRdrEnvElts GlobalRdrEnv
gbl_rdrenv
[RdrName] -> m [RdrName]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((RdrName -> Bool) -> [RdrName] -> [RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RdrName -> Bool) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName (OccName -> Bool) -> (RdrName -> OccName) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc) [RdrName]
gbl_names)
parseName :: GhcMonad m => String -> m (NonEmpty Name)
parseName :: forall (m :: * -> *). GhcMonad m => String -> m (NonEmpty Name)
parseName String
str = (HscEnv -> m (NonEmpty Name)) -> m (NonEmpty Name)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (NonEmpty Name)) -> m (NonEmpty Name))
-> (HscEnv -> m (NonEmpty Name)) -> m (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> IO (NonEmpty Name) -> m (NonEmpty Name)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NonEmpty Name) -> m (NonEmpty Name))
-> IO (NonEmpty Name) -> m (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$
do { lrdr_name <- HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier HscEnv
hsc_env String
str
; hscTcRnLookupRdrName hsc_env lrdr_name }
getDocs :: GhcMonad m
=> Name
-> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
getDocs :: forall (m :: * -> *).
GhcMonad m =>
Name
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
getDocs Name
name =
(HscEnv
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> (HscEnv
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
case Name -> Maybe Module
nameModule_maybe Name
name of
Maybe Module
Nothing -> Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. a -> Either a b
Left (Name -> GetDocsFailure
NameHasNoModule Name
name))
Just Module
mod -> do
if Module -> Bool
isInteractiveModule Module
mod
then Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. a -> Either a b
Left GetDocsFailure
InteractiveName)
else do
iface <- IO (ModIface_ 'ModIfaceFinal) -> m (ModIface_ 'ModIfaceFinal)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface_ 'ModIfaceFinal) -> m (ModIface_ 'ModIfaceFinal))
-> IO (ModIface_ 'ModIfaceFinal) -> m (ModIface_ 'ModIfaceFinal)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (ModIface_ 'ModIfaceFinal)
hscGetModuleInterface HscEnv
hsc_env Module
mod
case mi_docs iface of
Maybe Docs
Nothing -> Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod Bool
compiled))
Just Docs { docs_decls :: Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls = UniqMap Name [HsDoc GhcRn]
decls
, docs_args :: Docs -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args = UniqMap Name (IntMap (HsDoc GhcRn))
args
} ->
Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> Either
GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a b. b -> Either a b
Right ( UniqMap Name [HsDoc GhcRn] -> Name -> Maybe [HsDoc GhcRn]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name [HsDoc GhcRn]
decls Name
name
, IntMap (HsDoc GhcRn)
-> Maybe (IntMap (HsDoc GhcRn)) -> IntMap (HsDoc GhcRn)
forall a. a -> Maybe a -> a
fromMaybe IntMap (HsDoc GhcRn)
forall a. Monoid a => a
mempty (Maybe (IntMap (HsDoc GhcRn)) -> IntMap (HsDoc GhcRn))
-> Maybe (IntMap (HsDoc GhcRn)) -> IntMap (HsDoc GhcRn)
forall a b. (a -> b) -> a -> b
$ UniqMap Name (IntMap (HsDoc GhcRn))
-> Name -> Maybe (IntMap (HsDoc GhcRn))
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name (IntMap (HsDoc GhcRn))
args Name
name))
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has no module where we could look for docs."
ppr (NoDocsInIface Module
mod Bool
compiled) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Can't find any documentation for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'.'
, if Bool
compiled
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Try re-compiling with '-haddock'."
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Try running ':set -haddock' and :load the file again."
]
ppr GetDocsFailure
InteractiveName =
String -> SDoc
forall doc. IsLine doc => String -> doc
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 = (HscEnv -> m Kind) -> m Kind
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Kind) -> m Kind) -> (HscEnv -> m Kind) -> m Kind
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
ty <- IO Kind -> m Kind
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Kind -> m Kind) -> IO Kind -> m Kind
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRnExprMode -> String -> IO Kind
hscTcExpr HscEnv
hsc_env TcRnExprMode
mode String
expr
return $ tidyType emptyTidyEnv ty
typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
typeKind :: forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
typeKind Bool
normalise String
str = (HscEnv -> m (Kind, Kind)) -> m (Kind, Kind)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Kind, Kind)) -> m (Kind, Kind))
-> (HscEnv -> m (Kind, Kind)) -> m (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO (Kind, Kind) -> m (Kind, Kind)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Kind, Kind) -> m (Kind, Kind))
-> IO (Kind, Kind) -> m (Kind, Kind)
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 = (HscEnv -> m [ClsInst]) -> m [ClsInst]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [ClsInst]) -> m [ClsInst])
-> (HscEnv -> m [ClsInst]) -> m [ClsInst]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO [ClsInst] -> m [ClsInst]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ClsInst] -> m [ClsInst]) -> IO [ClsInst] -> m [ClsInst]
forall a b. (a -> b) -> a -> b
$ HscEnv -> Hsc [ClsInst] -> IO [ClsInst]
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc [ClsInst] -> IO [ClsInst]) -> Hsc [ClsInst] -> IO [ClsInst]
forall a b. (a -> b) -> a -> b
$
IO (Messages GhcMessage, Maybe [ClsInst]) -> Hsc [ClsInst]
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe [ClsInst]) -> Hsc [ClsInst])
-> IO (Messages GhcMessage, Maybe [ClsInst]) -> Hsc [ClsInst]
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe [ClsInst])
-> IO (Messages GhcMessage, Maybe [ClsInst])
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe [ClsInst])
-> IO (Messages GhcMessage, Maybe [ClsInst]))
-> IO (Messages TcRnMessage, Maybe [ClsInst])
-> IO (Messages GhcMessage, Maybe [ClsInst])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn [ClsInst] -> IO (Messages TcRnMessage, Maybe [ClsInst])
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn [ClsInst] -> IO (Messages TcRnMessage, Maybe [ClsInst]))
-> TcRn [ClsInst] -> IO (Messages TcRnMessage, Maybe [ClsInst])
forall a b. (a -> b) -> a -> b
$ do
HscEnv -> InteractiveContext -> TcM ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
matches <- Kind -> TcM [(ClsInst, [Maybe Kind])]
findMatchingInstances Kind
ty
fmap catMaybes . forM matches $ uncurry checkForExistence
parseInstanceHead :: GhcMonad m => String -> m Type
parseInstanceHead :: forall (m :: * -> *). GhcMonad m => String -> m Kind
parseInstanceHead String
str = (HscEnv -> m Kind) -> m Kind
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Kind) -> m Kind) -> (HscEnv -> m Kind) -> m Kind
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env0 -> do
(ty, _) <- IO (Kind, Kind) -> m (Kind, Kind)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Kind, Kind) -> m (Kind, Kind))
-> IO (Kind, Kind) -> m (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Hsc (Kind, Kind) -> IO (Kind, Kind)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Kind, Kind) -> IO (Kind, Kind))
-> Hsc (Kind, Kind) -> IO (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ do
hsc_env <- Hsc HscEnv
getHscEnv
ty <- hscParseType str
ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty
return ty
getDictionaryBindings :: PredType -> TcM CtEvidence
getDictionaryBindings :: Kind -> TcM CtEvidence
getDictionaryBindings Kind
theta = do
dictName <- OccName -> TcM Name
newName (OccName -> OccName
mkDictOcc (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"magic")))
let dict_var = HasDebugCallStack => Name -> Kind -> Id
Name -> Kind -> Id
mkVanillaGlobal Name
dictName Kind
theta
loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing
return CtWanted {
ctev_pred = varType dict_var,
ctev_dest = EvVarDest dict_var,
ctev_loc = loc,
ctev_rewriters = emptyRewriterSet
}
findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
findMatchingInstances :: Kind -> TcM [(ClsInst, [Maybe Kind])]
findMatchingInstances Kind
ty = do
ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- TcM InstEnvs
tcGetInstEnvs
let allClasses = UniqDSet Class -> [Class]
forall a. UniqDSet a -> [a]
uniqDSetToList (UniqDSet Class -> [Class]) -> UniqDSet Class -> [Class]
forall a b. (a -> b) -> a -> b
$ InstEnv -> UniqDSet Class
instEnvClasses InstEnv
ie_global UniqDSet Class -> UniqDSet Class -> UniqDSet Class
forall a. UniqDSet a -> UniqDSet a -> UniqDSet a
`unionUniqDSets` InstEnv -> UniqDSet Class
instEnvClasses InstEnv
ie_local
return $ concatMap (try_cls ies) allClasses
where
try_cls :: InstEnvs -> Class -> [(ClsInst, [Maybe Kind])]
try_cls InstEnvs
ies Class
cls
| Just (FunTyFlag
_, Kind
_, Kind
arg_kind, Kind
res_kind) <- Kind -> Maybe (FunTyFlag, Kind, Kind, Kind)
splitFunTy_maybe (TyCon -> Kind
tyConKind (TyCon -> Kind) -> TyCon -> Kind
forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls)
, Kind -> Bool
isConstraintKind Kind
res_kind
, HasDebugCallStack => Kind -> Kind
Kind -> Kind
Type.typeKind Kind
ty HasCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
`eqType` Kind
arg_kind
, ([(ClsInst, [Maybe Kind])]
matches, PotentialUnifiers
_, [(ClsInst, [Maybe Kind])]
_) <- Bool
-> InstEnvs
-> Class
-> [Kind]
-> ([(ClsInst, [Maybe Kind])], PotentialUnifiers,
[(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
(tys, thetas) <- Id -> [Maybe Kind] -> TcM ([Kind], [Kind])
instDFunType (ClsInst -> Id
is_dfun ClsInst
clsInst) [Maybe Kind]
mb_inst_tys
wanteds <- mapM getDictionaryBindings thetas
WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds
let simple_preds = (Ct -> Kind) -> [Ct] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> Kind
ctPred (Cts -> [Ct]
forall a. Bag a -> [a]
bagToList Cts
simples)
let minimal_simples = (Kind -> Kind) -> [Kind] -> [Kind]
forall a. (a -> Kind) -> [a] -> [a]
mkMinimalBySCs Kind -> Kind
forall a. a -> a
id [Kind]
simple_preds
if all allowedSimple minimal_simples && solvedImplics impls
then return . Just $ substInstArgs tys minimal_simples clsInst
else return Nothing
where
allowedSimple :: PredType -> Bool
allowedSimple :: Kind -> Bool
allowedSimple Kind
pred = Kind -> Bool
isSatisfiablePred Kind
pred
solvedImplics :: Bag Implication -> Bool
solvedImplics :: Bag Implication -> Bool
solvedImplics Bag Implication
impls = (Implication -> Bool) -> Bag Implication -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
allBag (ImplicStatus -> Bool
isSolvedStatus (ImplicStatus -> Bool)
-> (Implication -> ImplicStatus) -> Implication -> Bool
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]
_)) -> (Kind -> Bool) -> [Kind] -> Bool
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 :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (Kind -> VarSet
tyCoVarsOfType (Id -> Kind
idType (Id -> Kind) -> Id -> Kind
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 :: Subst
subst = (Subst -> (Id, Kind) -> Subst) -> Subst -> [(Id, Kind)] -> Subst
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Subst
a (Id, Kind)
b -> (Id -> Kind -> Subst) -> (Id, Kind) -> Subst
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Subst -> Id -> Kind -> Subst
extendTvSubstAndInScope Subst
a) (Id, Kind)
b) Subst
empty_subst ([Id] -> [Kind] -> [(Id, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
dfun_tvs [Kind]
tys)
tau :: Kind
tau = Class -> [Kind] -> Kind
mkClassPred Class
cls (HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
subst [Kind]
args)
phi :: Kind
phi = [Kind] -> Kind -> Kind
HasDebugCallStack => [Kind] -> Kind -> Kind
mkPhiTy [Kind]
thetas Kind
tau
sigma :: Kind
sigma = [ForAllTyBinder] -> Kind -> Kind
mkForAllTys ((Id -> ForAllTyBinder) -> [Id] -> [ForAllTyBinder]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
v -> Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ForAllTyFlag
Inferred) [Id]
dfun_tvs) Kind
phi
in ClsInst
inst { is_dfun = (is_dfun inst) { varType = 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 = (HscEnv -> m (LHsExpr GhcPs)) -> m (LHsExpr GhcPs)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (LHsExpr GhcPs)) -> m (LHsExpr GhcPs))
-> (HscEnv -> m (LHsExpr GhcPs)) -> m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO (LHsExpr GhcPs) -> m (LHsExpr GhcPs)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LHsExpr GhcPs) -> m (LHsExpr GhcPs))
-> IO (LHsExpr GhcPs) -> m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Hsc (LHsExpr GhcPs) -> IO (LHsExpr GhcPs)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (LHsExpr GhcPs) -> IO (LHsExpr GhcPs))
-> Hsc (LHsExpr GhcPs) -> IO (LHsExpr GhcPs)
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
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
compileParsedExpr parsed_expr
compileExprRemote :: GhcMonad m => String -> m ForeignHValue
compileExprRemote :: forall (m :: * -> *). GhcMonad m => String -> m ForeignHValue
compileExprRemote String
expr = do
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
compileParsedExprRemote 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
_) = (HscEnv -> m ForeignHValue) -> m ForeignHValue
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ForeignHValue) -> m ForeignHValue)
-> (HscEnv -> m ForeignHValue) -> m ForeignHValue
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' = SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc
expr_name :: Name
expr_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (FastString -> Unique
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 = SrcSpanAnnA
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (HsValBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsValBindsLR GhcPs GhcPs
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsLocalBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. NoAnn a => a
noAnn (HsLocalBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs)
-> HsValBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
forall a. NoAnn a => a
noAnn) (HsValBindsLR GhcPs GhcPs
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> HsValBindsLR GhcPs GhcPs
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$
XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey BindTag
forall tag. AnnSortKey tag
NoAnnSortKey
[SrcSpan
-> RdrName -> LHsExpr GhcPs -> XRec GhcPs (HsBindLR GhcPs GhcPs)
mkHsVarBind SrcSpan
loc' (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
expr_name) LHsExpr GhcPs
expr] []
pstmt <- IO (Maybe ([Id], ForeignHValue, FixityEnv))
-> m (Maybe ([Id], ForeignHValue, FixityEnv))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([Id], ForeignHValue, FixityEnv))
-> m (Maybe ([Id], ForeignHValue, FixityEnv)))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
-> m (Maybe ([Id], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GhciLStmt GhcPs
GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
let_stmt
let (hvals_io, fix_env) = case pstmt of
Just ([Id
_id], ForeignHValue
hvals_io', FixityEnv
fix_env') -> (ForeignHValue
hvals_io', FixityEnv
fix_env')
Maybe ([Id], ForeignHValue, FixityEnv)
_ -> String -> (ForeignHValue, FixityEnv)
forall a. HasCallStack => String -> a
panic String
"compileParsedExprRemote"
updateFixityEnv fix_env
let eval_opts = DynFlags -> Bool -> EvalOpts
initEvalOpts DynFlags
dflags Bool
False
status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)
case status of
EvalComplete Word64
_ (EvalSuccess [ForeignHValue
hval]) -> ForeignHValue -> m ForeignHValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval
EvalComplete Word64
_ (EvalException SerializableException
e) ->
IO ForeignHValue -> m ForeignHValue
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> m ForeignHValue)
-> IO ForeignHValue -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ForeignHValue
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
EvalStatus_ [ForeignHValue] [HValueRef]
_ -> String -> m ForeignHValue
forall a. HasCallStack => 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
fhv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote LHsExpr GhcPs
expr
interp <- hscInterp <$> getSession
liftIO $ wormhole interp fhv
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr :: forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
expr = do
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
let loc = GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
to_dyn_expr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcPs -> LHsExpr GhcPs)
-> (RdrName -> HsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (GenLocated (Anno (IdGhcP 'Parsed)) RdrName -> HsExpr GhcPs)
-> (RdrName -> GenLocated (Anno (IdGhcP 'Parsed)) RdrName)
-> RdrName
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anno (IdGhcP 'Parsed)
-> RdrName -> GenLocated (Anno (IdGhcP 'Parsed)) RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> Anno (IdGhcP 'Parsed)
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
loc) (RdrName -> LHsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
toDynName)
LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce hval :: Dynamic)
showModule :: GhcMonad m => ModSummary -> m String
showModule :: forall (m :: * -> *). GhcMonad m => ModSummary -> m String
showModule ModSummary
mod_summary =
(HscEnv -> m String) -> m String
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m String) -> m String)
-> (HscEnv -> m String) -> m String
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let interpreted :: Bool
interpreted =
case HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) (ModSummary -> UnitId
ms_unitid ModSummary
mod_summary) (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
Maybe HomeModInfo
Nothing -> String -> Bool
forall a. HasCallStack => String -> a
panic String
"missing linkable"
Just HomeModInfo
mod_info -> Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isJust (HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
mod_info) Bool -> Bool -> Bool
&& Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isNothing (HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
mod_info)
String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags Bool
interpreted ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [] ModSummary
mod_summary))
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable :: forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
case HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) (ModSummary -> UnitId
ms_unitid ModSummary
mod_summary) (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
Maybe HomeModInfo
Nothing -> String -> m Bool
forall a. HasCallStack => String -> a
panic String
"missing linkable"
Just HomeModInfo
mod_info -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool)
-> (Maybe Linkable -> Bool) -> Maybe Linkable -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Linkable -> m Bool) -> Maybe Linkable -> m Bool
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
mod_info
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 (a -> ForeignHValue
forall a b. a -> b
unsafeCoerce a
x)
#else
obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of
#endif
ExternalInterp {} -> GhcException -> IO Term
forall e a. (HasCallStack, 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
(hv, _, _) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
cvObtainTerm hsc_env bound force (idType id) hv
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType :: HscEnv -> BreakIndex -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env BreakIndex
bound Id
id = do
(hv, _, _) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
cvReconstructType hsc_env bound (idType id) 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