{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
--
-- Running statements interactively
--
-- -----------------------------------------------------------------------------

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 )

-- -----------------------------------------------------------------------------
-- running a statement interactively

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"

{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
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

-- | Update fixity environment in the current interactive context.
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 } }

-- -----------------------------------------------------------------------------
-- execStmt

-- | default ExecOptions
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 -- just run the statement, don't wrap it in anything
  }

-- | Run a statement in the current interactive context.
execStmt
  :: GhcMonad m
  => String             -- ^ a statement (bind or expression)
  -> 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
      -- empty statement / comment
      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

-- | Like `execStmt`, but takes a parsed statement as argument. Useful when
-- doing preprocessing on the AST before execution, e.g. in GHCi (see
-- GHCi.UI.runStmt).
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

    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
    -- warnings about the implicit bindings we introduce.
    let ic       = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env -- use the interactive dflags
        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 ->
        -- empty statement / comment
        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

-- | Run some declarations and return any user-visible names that were brought
-- into scope.
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

-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
-- (see GHCi.UI.runStmt).
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)
             -- For this filter, see Note [What to show to users]
           $ map getName tyThings

{- Note [What to show to users]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't want to display internally-generated bindings to users.
Things like the coercion axiom for newtypes. These bindings all get
OccNames that users can't write, to avoid the possibility of name
clashes (in linker symbols).  That gives a convenient way to suppress
them. The relevant predicate is OccName.isDerivedOccName.
See #11051 for more background and examples.
-}

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

    -- a virtual CWD is only necessary when we're running interpreted code in
    -- the same process as the compiler.
  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
           -- This breakpoint is explicitly enabled; we want to stop
           -- instead of just logging it.
         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
                 -- history is strict, otherwise our BoundedList is pointless.
           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
    -- Hit a breakpoint
    | 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)

    -- Completed successfully
    | 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)

    -- Completed with an exception
    | 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
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
        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' }

        -- remove any bindings created since the breakpoint from the
        -- linker's environment
        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
                -- When the user specified a break ignore count, set it
                -- in the interpreter
                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 ()   -- #19157
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)

        -- careful: we want apStack to be the AP_STACK itself, not a thunk
        -- around it, hence the cases are carefully constructed below to
        -- make this the case.  ToDo: this is v. fragile, do something better.
        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)


-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment

result_fs :: FastString
result_fs :: FastString
result_fs = String -> FastString
fsLit String
"_result"

bindLocalsAtBreakpoint
        :: HscEnv
        -> ForeignHValue
        -> Maybe InternalBreakpointId
        -> IO (HscEnv, [Name], SrcSpan, String)

-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint.  We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
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>")

-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
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

  -- Rehydrate to understand the breakpoint info relative to the current environment.
  -- This design is critical to preventing leaks (#22530)
   (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

           -- Filter out any unboxed ids by changing them to Nothings;
           -- we can't bind these at the prompt
       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)

   -- It might be that getIdValFromApStack fails, because the AP_STACK
   -- has been accidentally evaluated, or something else has gone wrong.
   -- So that we don't fall over in a heap when this happens, just don't
   -- bind any free variables instead, and we emit a warning.
   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'   -- Dodgy; will give the same uniques every time
   let tv_subst     = UniqSupply -> [Id] -> Subst
newTyVars UniqSupply
us [Id]
free_tvs
       (filtered_ids, occs'') = unzip         -- again, sync the occ-names
          [ (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
        -- We need a fresh Unique for each Id we bind, because the linker
        -- state is single-threaded and otherwise we'd spam old bindings
        -- whenever we stop at a breakpoint.  The InteractveContext is properly
        -- saved/restored, but not the linker state.  See #1743, test break026.
   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)
              -- NB: use variable namespace.
              -- Don't use record field namespaces, lest we cause #25109.
          ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) }

   newTyVars :: UniqSupply -> [TcTyVar] -> Subst
     -- Similarly, clone the type variables mentioned in the types
     -- we have here, *and* make them all RuntimeUnk tyvars
   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

   -- Convert unboxed Id's to Nothings
   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

   -- See Note [Syncing breakpoint info]
   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 }


  {-
  Note [Syncing breakpoint info]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  To display the values of the free variables for a single breakpoint, the
  function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls
  out the information from the fields `modBreaks_breakInfo` and
  `modBreaks_vars` of the `ModBreaks` data structure.
  For a specific breakpoint this gives 2 lists of type `Id` (or `Var`)
  and `OccName`.
  They are used to create the Id's for the free variables and must be kept
  in sync!

  There are 3 situations where items are removed from the Id list
  (or replaced with `Nothing`):
  1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates
      the Id list) doesn't find an Id in the ByteCode environment.
  2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint`
      filters out unboxed elements from the Id list, because GHCi cannot
      yet handle them.
  3.) If the GHCi interpreter doesn't find the reference to a free variable
      of our breakpoint. This also happens in the function
      bindLocalsAtBreakpoint.

  If an element is removed from the Id list, then the corresponding element
  must also be removed from the Occ list. Otherwise GHCi will confuse
  variable names as in #8487.
  -}

-- -----------------------------------------------------------------------------
-- Abandoning a resume context

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

-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons

data BoundedList a = BL
                        {-# UNPACK #-} !Int  -- length
                        {-# UNPACK #-} !Int  -- bound
                        [a] -- left
                        [a] -- right,  list is (left ++ reverse right)

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 []

-- lenBL (BL len _ _ _) = len

-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
--
-- (setContext imports) sets the ic_imports field (which in turn
-- determines what is in scope at the prompt) to 'imports', and
-- updates the icReaderEnv environment to reflect it.
--
-- We retain in scope all the things defined at the prompt, and kept
-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)

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)
-- Compute the GlobalRdrEnv for the interactive context
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
                    -- This call also loads any orphan modules
       ; 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

-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
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)

-- | Returns @True@ if the specified module is interpreted, and hence has
-- its full top-level scope available.
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

-- | Looks up an identifier in the current interactive context (for :info)
-- Filter the instances by the ones whose tycons (or classes resp)
-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
-- The exact choice of which ones to show, and which to hide, is a judgement call.
--      (see #1581)
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)

           -- Filter the instances based on whether the constituent names of their
           -- instance heads are all in scope.
           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
          -- Dfun involving only names that are in icReaderEnv
        = Bool
allInfo
       Bool -> Bool -> Bool
|| (Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
ok NameSet
names
        where   -- A name is ok if it's in the rdr_env,
                -- whether qualified or not
          ok :: Name -> Bool
ok Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name              = Bool
True
                       -- The one we looked for in the first place!
               | Name -> Bool
pretendNameIsInScope Name
n = Bool
True
                   -- See Note [pretendNameIsInScope] in GHC.Builtin.Names
               | 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

-- | Returns all names in scope in the current interactive context
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))

-- | Returns all 'RdrName's in scope in the current interactive
-- context, excluding any that are internally-generated.
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
  -- Exclude internally generated names; see e.g. #11328
  [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)


-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
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)))
           -- TODO: What about docs for constructors etc.?
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 =
      -- TODO: Find a more direct indicator.
      case Name -> SrcLoc
nameSrcLoc Name
name of
        RealSrcLoc {} -> Bool
False
        UnhelpfulLoc {} -> Bool
True

-- | Failure modes for 'getDocs'.
data GetDocsFailure

    -- | 'nameModule_maybe' returned 'Nothing'.
  = NameHasNoModule Name

    -- | The module was loaded without @-haddock@,
  | NoDocsInIface
      Module
      Bool -- ^ 'True': The module was compiled.
           -- 'False': The module was :loaded.

    -- | The 'Name' was defined interactively.
  | 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."
        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
    ]
  ppr GetDocsFailure
InteractiveName =
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Docs are unavailable for interactive declarations."

-- -----------------------------------------------------------------------------
-- Getting the type of an expression

-- | Get the type of an expression
-- Returns the type as described by 'TcRnExprMode'
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

-- -----------------------------------------------------------------------------
-- Getting the kind of a type

-- | Get the kind of a  type
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

-- ----------------------------------------------------------------------------
-- Getting the class instances for a type

{-
  Note [Querying instances for a type]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Here is the implementation of GHC proposal 41.
  (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)

  The objective is to take a query string representing a (partial) type, and
  report all the class single-parameter class instances available to that type.
  Extending this feature to multi-parameter typeclasses is left as future work.

  The general outline of how we solve this is:

  1. Parse the type, leaving skolems in the place of type-holes.
  2. For every class, get a list of all instances that match with the query type.
  3. For every matching instance, ask GHC for the context the instance dictionary needs.
  4. Format and present the results, substituting our query into the instance
     and simplifying the context.

  For example, given the query "Maybe Int", we want to return:

  instance Show (Maybe Int)
  instance Read (Maybe Int)
  instance Eq   (Maybe Int)
  ....

  [Holes in queries]

  Often times we want to know what instances are available for a polymorphic type,
  like `Maybe a`, and we'd like to return instances such as:

  instance Show a => Show (Maybe a)
  ....

  These queries are expressed using type holes, so instead of `Maybe a` the user writes
  `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes
  with (un-named) type variables.

  When zonking the type holes we have two real choices: replace them with Any or replace
  them with skolem typevars. Using skolem type variables ensures that the output is more
  intuitive to end users, and there is no difference in the results between Any and skolems.

-}

-- Find all instances that match a provided type
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
      -- Bring class and instances from unqualified modules into scope, this fixes #16793.
      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

-- Parse a type string and turn any holes into skolems
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

-- Get all the constraints required of a dictionary binding
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
  }

-- Find instances where the head unifies with the provided type
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
  {- Check that a class instance is well-kinded.
    Since `:instances` only works for unary classes, we're looking for instances of kind
    k -> Constraint where k is the type of the queried type.
  -}
  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
    = []


{-
  When we've found an instance that a query matches against, we still need to
  check that all the instance's constraints are satisfiable. checkForExistence
  creates an instance dictionary and verifies that any unsolved constraints
  mention a type-hole, meaning it is blocked on an unknown.

  If the instance satisfies this condition, then we return it with the query
  substituted into the instance and all constraints simplified, for example given:

  instance D a => C (MyType a b) where

  and the query `MyType _ String`

  the unsolved constraints will be [D _] so we apply the substitution:

  { a -> _; b -> String}

  and return the instance:

  instance D _ => C (MyType _ String)

-}

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
  -- We want to force the solver to attempt to solve the constraints for clsInst.
  -- Usually, this isn't a problem since there should only be a single instance
  -- for a type. However, when we have overlapping instances, the solver will give up
  -- since it can't decide which instance to use. To get around this restriction, instead
  -- of asking the solver to solve a constraint for clsInst, we ask it to solve the
  -- thetas of clsInst.
  (tys, thetas) <- Id -> [Maybe Kind] -> TcM ([Kind], [Kind])
instDFunType (ClsInst -> Id
is_dfun ClsInst
clsInst) [Maybe Kind]
mb_inst_tys
  wanteds <- mapM getDictionaryBindings thetas
  -- It's important to zonk constraints after solving in order to expose things like TypeErrors
  -- which otherwise appear as opaque type variables. (See #18262).
  WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds

  -- The simples might contain superclasses. This clutters up the output
  -- (we want e.g. instance Ord a => Ord (Maybe a), not
  -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs
  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

  -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
  -- one argument or for the head to be a TyVar. The reason is that we want to ensure
  -- that all residual constraints mention a type-hole somewhere in the constraint,
  -- meaning that with the correct choice of a concrete type it could be possible for
  -- the constraint to be discharged.
  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)))

  {- Create a ClsInst with instantiated arguments and constraints.

     The thetas are the list of constraints that couldn't be solved because
     they mention a type-hole.
  -}
  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)
      -- Build instance head with arguments substituted in
      tau :: Kind
tau   = Class -> [Kind] -> Kind
mkClassPred Class
cls (HasDebugCallStack => Subst -> [Kind] -> [Kind]
Subst -> [Kind] -> [Kind]
substTheta Subst
subst [Kind]
args)
      -- Constrain the instance with any residual constraints
      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

-----------------------------------------------------------------------------
-- Compile an expression, run it, and deliver the result

-- | Parse an expression, the parsed expression can be further processed and
-- passed to compileParsedExpr.
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

-- | Compile an expression, run it, and deliver the resulting HValue.
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

-- | Compile an expression, run it, and deliver the resulting HValue.
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

-- | Compile a parsed expression (before renaming), run it, and deliver
-- the resulting HValue.
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 _compileParsedExpr = expr
  -- Create let stmt from expr to make hscParsedStmt happy.
  -- We will ignore the returned [Id], namely [expr_id], and not really
  -- create a new binding.
  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

-- | Compile an expression, run it and return the result as a Dynamic.
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
  -- > Data.Dynamic.toDyn 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)

-----------------------------------------------------------------------------
-- show a module and it's source/object filenames

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

----------------------------------------------------------------------------
-- RTTI primitives

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

-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
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