{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

{-# 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,
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        parseInstanceHead,
        getInstancesForType,
        getDocs,
        GetDocsFailure(..),
        showModule,
        moduleIsBootOrNotObjectLinkable,
        parseExpr, compileParsedExpr,
        compileExpr, dynCompileExpr,
        compileExprRemote, compileParsedExprRemote,
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
        ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Monad
import GHC.Driver.Main
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr

import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Context
import GHCi.Message
import GHCi.RemoteTypes
import GHC.ByteCode.Types

import GHC.Linker.Types
import GHC.Linker.Loader as Loader

import GHC.Hs

import GHC.Core.Predicate
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv ( FamInst )
import GHC.Core.FVs        ( orphNamesOfFamInst )
import GHC.Core.TyCon
import GHC.Core.Type       hiding( typeKind )
import qualified GHC.Core.Type as Type

import GHC.Iface.Env       ( newInteractiveBinder )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin

import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )
import GHC.Builtin.Types ( isCTupleTyConName )

import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.Bag

import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger

import GHC.Types.RepType
import GHC.Types.Fixity.Env
import GHC.Types.Var
import GHC.Types.Id as Id
import GHC.Types.Name      hiding ( varName )
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Types.TyThing

import GHC.Unit
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo

import System.Directory
import Data.Dynamic
import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import GHC.Utils.Exception
import Unsafe.Coerce ( unsafeCoerce )

import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) )
import GHC.Tc.Utils.Env (tcGetInstEnvs)
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Monad
import GHC.Core.Class (classTyCon)

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

getResumeContext :: GhcMonad m => m [Resume]
getResumeContext :: forall (m :: * -> *). GhcMonad m => m [Resume]
getResumeContext = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveContext -> [Resume]
ic_resume forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
hsc_IC)

mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
hval BreakInfo
bi = ForeignHValue -> BreakInfo -> [String] -> History
History ForeignHValue
hval BreakInfo
bi (HscEnv -> BreakInfo -> [String]
findEnclosingDecls HscEnv
hsc_env BreakInfo
bi)

getHistoryModule :: History -> Module
getHistoryModule :: History -> Module
getHistoryModule = BreakInfo -> Module
breakInfo_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> BreakInfo
historyBreakInfo

getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan HscEnv
hsc_env History{[String]
ForeignHValue
BreakInfo
historyEnclosingDecls :: History -> [String]
historyApStack :: History -> ForeignHValue
historyEnclosingDecls :: [String]
historyBreakInfo :: BreakInfo
historyApStack :: ForeignHValue
historyBreakInfo :: History -> BreakInfo
..} =
  let BreakInfo{BreakIndex
Module
breakInfo_number :: BreakInfo -> BreakIndex
breakInfo_number :: BreakIndex
breakInfo_module :: Module
breakInfo_module :: BreakInfo -> Module
..} = BreakInfo
historyBreakInfo in
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
breakInfo_module) of
    Just HomeModInfo
hmi -> ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs (HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi) forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
    Maybe HomeModInfo
_ -> forall a. String -> a
panic String
"getHistorySpan"

{- | 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 -> BreakInfo -> [String]
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls HscEnv
hsc_env (BreakInfo Module
modl BreakIndex
ix) =
   let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"findEnclosingDecls" forall a b. (a -> b) -> a -> b
$
             HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
modl)
       mb :: ModBreaks
mb = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
   in ModBreaks -> Array BreakIndex [String]
modBreaks_decls ModBreaks
mb forall i e. Ix i => Array i e -> i -> e
! BreakIndex
ix

-- | 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
  HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_fix_env :: FixityEnv
ic_fix_env = FixityEnv
fix_env } }

-- -----------------------------------------------------------------------------
-- 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 = 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
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: BreakIndex
execSourceFile :: String
execSingleStep :: SingleStep
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: ExecOptions -> BreakIndex
execSourceFile :: ExecOptions -> String
execSingleStep :: ExecOptions -> SingleStep
..} = do
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mb_stmt <-
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
      String -> BreakIndex -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
execSourceFile BreakIndex
execLineNumber String
input

    case Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mb_stmt of
      -- empty statement / comment
      Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right []) Word64
0)
      Just GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt -> forall (m :: * -> *).
GhcMonad m =>
GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt String
input ExecOptions
exec_opts

-- | 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
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: BreakIndex
execSourceFile :: String
execSingleStep :: SingleStep
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: ExecOptions -> BreakIndex
execSourceFile :: ExecOptions -> String
execSingleStep :: ExecOptions -> SingleStep
..} = do
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
    -- warnings about the implicit bindings we introduce.
    let ic :: InteractiveContext
ic       = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env -- use the interactive dflags
        idflags' :: DynFlags
idflags' = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic DynFlags -> WarningFlag -> DynFlags
`wopt_unset` WarningFlag
Opt_WarnUnusedLocalBinds
        hsc_env' :: HscEnv
hsc_env' = HscEnv -> HscEnv
mkInteractiveHscEnv (HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic{ ic_dflags :: DynFlags
ic_dflags = DynFlags
idflags' }})

    Maybe ([Id], ForeignHValue, FixityEnv)
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env' GhciLStmt GhcPs
stmt

    case Maybe ([Id], ForeignHValue, FixityEnv)
r of
      Maybe ([Id], ForeignHValue, FixityEnv)
Nothing ->
        -- empty statement / comment
        forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right []) Word64
0)
      Just ([Id]
ids, ForeignHValue
hval, FixityEnv
fix_env) -> do
        forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env

        EvalStatus_ [ForeignHValue] [HValueRef]
status <-
          forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              Interp
-> DynFlags
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp DynFlags
idflags' (SingleStep -> Bool
isStep SingleStep
execSingleStep) (ForeignHValue -> EvalExpr ForeignHValue
execWrap ForeignHValue
hval)

        let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
            bindings :: ([TyThing], GlobalRdrEnv)
bindings = (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic, InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ic)

            size :: BreakIndex
size = DynFlags -> BreakIndex
ghciHistSize DynFlags
idflags'

        forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
execSingleStep String
stmt_text ([TyThing], GlobalRdrEnv)
bindings [Id]
ids
                        EvalStatus_ [ForeignHValue] [HValueRef]
status (BreakIndex -> BoundedList History
emptyHistory BreakIndex
size)

runDecls :: GhcMonad m => String -> m [Name]
runDecls :: forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls = forall (m :: * -> *).
GhcMonad m =>
String -> BreakIndex -> String -> m [Name]
runDeclsWithLocation String
"<interactive>" BreakIndex
1

-- | 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
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> String -> BreakIndex -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env String
source BreakIndex
line_num String
input)
    forall (m :: * -> *). GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls

-- | 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
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    ([TyThing]
tyThings, InteractiveContext
ic) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls)

    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic }
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    HscEnv
hsc_env' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env
    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName)
             -- For this filter, see Note [What to show to users]
           forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [TyThing]
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
  HscEnv
hsc_env <- 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 Interp -> InterpInstance
interpInstance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
    Just (ExternalInterp {}) -> m a
m
    Maybe InterpInstance
_ -> do
      let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
      let set_cwd :: m String
set_cwd = do
            String
dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
            case InteractiveContext -> Maybe String
ic_cwd InteractiveContext
ic of
               Just String
dir -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir
               Maybe String
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall (m :: * -> *) a. Monad m => a -> m a
return String
dir

          reset_cwd :: String -> m ()
reset_cwd String
orig_dir = do
            String
virt_dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
            HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
            let old_IC :: InteractiveContext
old_IC = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
            forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{  hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
old_IC{ ic_cwd :: Maybe String
ic_cwd = forall a. a -> Maybe a
Just String
virt_dir } }
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
orig_dir

      forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m String
set_cwd forall {m :: * -> *}. GhcMonad m => String -> m ()
reset_cwd forall a b. (a -> b) -> a -> b
$ \String
_ -> m a
m

parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl :: forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
expr = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport HscEnv
hsc_env String
expr

emptyHistory :: Int -> BoundedList History
emptyHistory :: BreakIndex -> BoundedList History
emptyHistory BreakIndex
size = forall a. BreakIndex -> BoundedList a
nilBL BreakIndex
size

handleRunStatus :: GhcMonad m
                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
                -> EvalStatus_ [ForeignHValue] [HValueRef]
                -> BoundedList History
                -> m ExecResult

handleRunStatus :: forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
step String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
history
  | SingleStep
RunAndLogSteps <- SingleStep
step = m ExecResult
tracing
  | Bool
otherwise              = m ExecResult
not_tracing
 where
  tracing :: m ExecResult
tracing
    | EvalBreak Bool
is_exception HValueRef
apStack_ref BreakIndex
ix BreakIndex
mod_uniq RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
_ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
    , Bool -> Bool
not Bool
is_exception
    = do
       HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
       let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
       let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" forall a b. (a -> b) -> a -> b
$
                   HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                     (BreakIndex -> Unique
mkUniqueGrimily BreakIndex
mod_uniq)
           modl :: Module
modl = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
           breaks :: ModBreaks
breaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi

       Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              Interp -> ForeignRef BreakArray -> BreakIndex -> IO Bool
breakpointStatus Interp
interp (ModBreaks -> ForeignRef BreakArray
modBreaks_flags ModBreaks
breaks) BreakIndex
ix
       if Bool
b
         then m ExecResult
not_tracing
           -- This breakpoint is explicitly enabled; we want to stop
           -- instead of just logging it.
         else do
           ForeignHValue
apStack_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp HValueRef
apStack_ref
           let bi :: BreakInfo
bi = Module -> BreakIndex -> BreakInfo
BreakInfo Module
modl BreakIndex
ix
               !history' :: BoundedList History
history' = HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack_fhv BreakInfo
bi forall a. a -> BoundedList a -> BoundedList a
`consBL` BoundedList History
history
                 -- history is strict, otherwise our BoundedList is pointless.
           ForeignRef (ResumeContext [HValueRef])
fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext [HValueRef])
resume_ctxt
           EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt Interp
interp DynFlags
dflags Bool
True ForeignRef (ResumeContext [HValueRef])
fhv
           forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
RunAndLogSteps String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids
                           EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
history'
    | Bool
otherwise
    = m ExecResult
not_tracing

  not_tracing :: m ExecResult
not_tracing
    -- Hit a breakpoint
    | EvalBreak Bool
is_exception HValueRef
apStack_ref BreakIndex
ix BreakIndex
mod_uniq RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
    = do
         HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
         let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
         ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext [HValueRef])
resume_ctxt
         ForeignHValue
apStack_fhv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp HValueRef
apStack_ref
         let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" forall a b. (a -> b) -> a -> b
$
                     HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                       (BreakIndex -> Unique
mkUniqueGrimily BreakIndex
mod_uniq)
             modl :: Module
modl = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
             bp :: Maybe BreakInfo
bp | Bool
is_exception = forall a. Maybe a
Nothing
                | Bool
otherwise = forall a. a -> Maybe a
Just (Module -> BreakIndex -> BreakInfo
BreakInfo Module
modl BreakIndex
ix)
         (HscEnv
hsc_env1, [Name]
names, SrcSpan
span, String
decl) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
           HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack_fhv Maybe BreakInfo
bp
         let
           resume :: Resume
resume = Resume
             { resumeStmt :: String
resumeStmt = String
expr, resumeContext :: ForeignRef (ResumeContext [HValueRef])
resumeContext = ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv
             , resumeBindings :: ([TyThing], GlobalRdrEnv)
resumeBindings = ([TyThing], GlobalRdrEnv)
bindings, resumeFinalIds :: [Id]
resumeFinalIds = [Id]
final_ids
             , resumeApStack :: ForeignHValue
resumeApStack = ForeignHValue
apStack_fhv
             , resumeBreakInfo :: Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
bp
             , resumeSpan :: SrcSpan
resumeSpan = SrcSpan
span, resumeHistory :: [History]
resumeHistory = forall a. BoundedList a -> [a]
toListBL BoundedList History
history
             , resumeDecl :: String
resumeDecl = String
decl
             , resumeCCS :: RemotePtr CostCentreStack
resumeCCS = RemotePtr CostCentreStack
ccs
             , resumeHistoryIx :: BreakIndex
resumeHistoryIx = BreakIndex
0 }
           hsc_env2 :: HscEnv
hsc_env2 = HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env1 Resume
resume

         forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2
         forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Maybe BreakInfo -> ExecResult
ExecBreak [Name]
names Maybe BreakInfo
bp)

    -- Completed successfully
    | EvalComplete Word64
allocs (EvalSuccess [ForeignHValue]
hvals) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
    = do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
         let final_ic :: InteractiveContext
final_ic = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) [Id]
final_ids
             final_names :: [Name]
final_names = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [Id]
final_ids
             interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
final_names [ForeignHValue]
hvals)
         HscEnv
hsc_env' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{hsc_IC :: InteractiveContext
hsc_IC=InteractiveContext
final_ic}
         forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
         forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right [Name]
final_names) Word64
allocs)

    -- Completed with an exception
    | EvalComplete Word64
alloc (EvalException SerializableException
e) <- EvalStatus_ [ForeignHValue] [HValueRef]
status
    = forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. a -> Either a b
Left (SerializableException -> SomeException
fromSerializableException SerializableException
e)) Word64
alloc)

#if __GLASGOW_HASKELL__ <= 810
    | otherwise
    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
#endif


resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
           -> m ExecResult
resumeExec :: forall (m :: * -> *).
GhcMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe BreakIndex -> m ExecResult
resumeExec SrcSpan -> Bool
canLogSpan SingleStep
step Maybe BreakIndex
mbCnt
 = do
   HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic

   case [Resume]
resume of
     [] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
           forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"not stopped at a breakpoint")
     (Resume
r:[Resume]
rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
        let ([TyThing]
resume_tmp_te,GlobalRdrEnv
resume_rdr_env) = Resume -> ([TyThing], GlobalRdrEnv)
resumeBindings Resume
r
            ic' :: InteractiveContext
ic' = InteractiveContext
ic { ic_tythings :: [TyThing]
ic_tythings = [TyThing]
resume_tmp_te,
                       ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
resume_rdr_env,
                       ic_resume :: [Resume]
ic_resume   = [Resume]
rs }
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic' }

        -- remove any bindings created since the breakpoint from the
        -- linker's environment
        let old_names :: [Name]
old_names = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [TyThing]
resume_tmp_te
            new_names :: [Name]
new_names = [ Name
n | TyThing
thing <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic
                            , let n :: Name
n = forall a. NamedThing a => a -> Name
getName TyThing
thing
                            , Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
old_names) ]
            interp :: Interp
interp    = HscEnv -> Interp
hscInterp HscEnv
hsc_env
            dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> [Name] -> IO ()
Loader.deleteFromLoadedEnv Interp
interp [Name]
new_names

        case Resume
r of
          Resume { resumeStmt :: Resume -> String
resumeStmt = String
expr, resumeContext :: Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext = ForeignRef (ResumeContext [HValueRef])
fhv
                 , resumeBindings :: Resume -> ([TyThing], GlobalRdrEnv)
resumeBindings = ([TyThing], GlobalRdrEnv)
bindings, resumeFinalIds :: Resume -> [Id]
resumeFinalIds = [Id]
final_ids
                 , resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack, resumeBreakInfo :: Resume -> Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
mb_brkpt
                 , resumeSpan :: Resume -> SrcSpan
resumeSpan = SrcSpan
span
                 , resumeHistory :: Resume -> [History]
resumeHistory = [History]
hist } ->
               forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD forall a b. (a -> b) -> a -> b
$ do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe BreakInfo
mb_brkpt Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe BreakIndex
mbCnt) forall a b. (a -> b) -> a -> b
$ do
                  forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakInfo -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env (forall a. HasCallStack => Maybe a -> a
fromJust Maybe BreakInfo
mb_brkpt) (forall a. HasCallStack => Maybe a -> a
fromJust Maybe BreakIndex
mbCnt)
                    -- When the user specified a break ignore count, set it
                    -- in the interpreter
                EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt Interp
interp DynFlags
dflags (SingleStep -> Bool
isStep SingleStep
step) ForeignRef (ResumeContext [HValueRef])
fhv
                let prevHistoryLst :: BoundedList History
prevHistoryLst = forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
                    hist' :: BoundedList History
hist' = case Maybe BreakInfo
mb_brkpt of
                       Maybe BreakInfo
Nothing -> BoundedList History
prevHistoryLst
                       Just BreakInfo
bi
                         | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ SrcSpan -> Bool
canLogSpan SrcSpan
span -> BoundedList History
prevHistoryLst
                         | Bool
otherwise -> HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack BreakInfo
bi forall a. a -> BoundedList a -> BoundedList a
`consBL`
                                                        forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
50 [History]
hist
                forall (m :: * -> *).
GhcMonad m =>
SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
handleRunStatus SingleStep
step String
expr ([TyThing], GlobalRdrEnv)
bindings [Id]
final_ids EvalStatus_ [ForeignHValue] [HValueRef]
status BoundedList History
hist'

setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()   -- #19157
setupBreakpoint :: forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakInfo -> BreakIndex -> m ()
setupBreakpoint HscEnv
hsc_env BreakInfo
brkInfo BreakIndex
cnt = do
  let Module
modl :: Module = BreakInfo -> Module
breakInfo_module BreakInfo
brkInfo
      breaks :: HscEnv -> GenModule unit -> ModBreaks
breaks HscEnv
hsc_env GenModule unit
modl = HomeModInfo -> ModBreaks
getModBreaks forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"setupBreakpoint" forall a b. (a -> b) -> a -> b
$
         HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName GenModule unit
modl)
      ix :: BreakIndex
ix = BreakInfo -> BreakIndex
breakInfo_number BreakInfo
brkInfo
      modBreaks :: ModBreaks
modBreaks  = forall {unit}. HscEnv -> GenModule unit -> ModBreaks
breaks HscEnv
hsc_env Module
modl
      breakarray :: ForeignRef BreakArray
breakarray = ModBreaks -> ForeignRef BreakArray
modBreaks_flags ModBreaks
modBreaks
      interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
  ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> ForeignRef BreakArray -> BreakIndex -> BreakIndex -> IO ()
GHCi.storeBreakpoint Interp
interp ForeignRef BreakArray
breakarray BreakIndex
ix BreakIndex
cnt
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
back :: forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> m ([Name], BreakIndex, SrcSpan, String)
back BreakIndex
n = forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (forall a. Num a => a -> a -> a
+BreakIndex
n)

forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
forward :: forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> m ([Name], BreakIndex, SrcSpan, String)
forward BreakIndex
n = forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist (forall a. Num a => a -> a -> a
subtract BreakIndex
n)

moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
moveHist :: forall (m :: * -> *).
GhcMonad m =>
(BreakIndex -> BreakIndex)
-> m ([Name], BreakIndex, SrcSpan, String)
moveHist BreakIndex -> BreakIndex
fn = do
  HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  case InteractiveContext -> [Resume]
ic_resume (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) of
     [] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
           forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"not stopped at a breakpoint")
     (Resume
r:[Resume]
rs) -> do
        let ix :: BreakIndex
ix = Resume -> BreakIndex
resumeHistoryIx Resume
r
            history :: [History]
history = Resume -> [History]
resumeHistory Resume
r
            new_ix :: BreakIndex
new_ix = BreakIndex -> BreakIndex
fn BreakIndex
ix
        --
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([History]
history forall a. [a] -> BreakIndex -> Bool
`lengthLessThan` BreakIndex
new_ix) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
           forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"no more logged breakpoints")
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BreakIndex
new_ix forall a. Ord a => a -> a -> Bool
< BreakIndex
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
           forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError String
"already at the beginning of the history")

        let
          update_ic :: ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe BreakInfo
mb_info = do
            (HscEnv
hsc_env1, [Name]
names, SrcSpan
span, String
decl) <-
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe BreakInfo
mb_info
            let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env1
                r' :: Resume
r' = Resume
r { resumeHistoryIx :: BreakIndex
resumeHistoryIx = BreakIndex
new_ix }
                ic' :: InteractiveContext
ic' = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = Resume
r'forall a. a -> [a] -> [a]
:[Resume]
rs }

            forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic' }

            forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
names, BreakIndex
new_ix, SrcSpan
span, String
decl)

        -- 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 forall a. Eq a => a -> a -> Bool
== BreakIndex
0
           then case Resume
r of
                   Resume { resumeApStack :: Resume -> ForeignHValue
resumeApStack = ForeignHValue
apStack,
                            resumeBreakInfo :: Resume -> Maybe BreakInfo
resumeBreakInfo = Maybe BreakInfo
mb_brkpt } ->
                          ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe BreakInfo
mb_brkpt
           else case [History]
history forall a. [a] -> BreakIndex -> a
!! (BreakIndex
new_ix forall a. Num a => a -> a -> a
- BreakIndex
1) of
                   History{[String]
ForeignHValue
BreakInfo
historyEnclosingDecls :: [String]
historyBreakInfo :: BreakInfo
historyApStack :: ForeignHValue
historyEnclosingDecls :: History -> [String]
historyApStack :: History -> ForeignHValue
historyBreakInfo :: History -> BreakInfo
..} ->
                     ForeignHValue
-> Maybe BreakInfo -> m ([Name], BreakIndex, SrcSpan, String)
update_ic ForeignHValue
historyApStack (forall a. a -> Maybe a
Just BreakInfo
historyBreakInfo)


-- -----------------------------------------------------------------------------
-- 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 BreakInfo
        -> 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 BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack Maybe BreakInfo
Nothing = do
   let exn_occ :: OccName
exn_occ = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"_exception")
       span :: SrcSpan
span    = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"<unknown>")
   Name
exn_name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
exn_occ SrcSpan
span

   let e_fs :: FastString
e_fs    = String -> FastString
fsLit String
"e"
       e_name :: Name
e_name  = Unique -> OccName -> SrcSpan -> Name
mkInternalName (forall a. Uniquable a => a -> Unique
getUnique FastString
e_fs) (FastString -> OccName
mkTyVarOccFS FastString
e_fs) SrcSpan
span
       e_tyvar :: Id
e_tyvar = Name -> Kind -> Id
mkRuntimeUnkTyVar Name
e_name Kind
liftedTypeKind
       exn_id :: Id
exn_id  = Name -> Kind -> Id
Id.mkVanillaGlobal Name
exn_name (Id -> Kind
mkTyVarTy Id
e_tyvar)

       ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id
exn_id]
       interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
   --
   Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp [(Name
exn_name, ForeignHValue
apStack)]
   forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }, [Name
exn_name], SrcSpan
span, String
"<exception thrown>")

-- 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 BreakInfo{BreakIndex
Module
breakInfo_number :: BreakIndex
breakInfo_module :: Module
breakInfo_number :: BreakInfo -> BreakIndex
breakInfo_module :: BreakInfo -> Module
..}) = do
   let
       hmi :: HomeModInfo
hmi       = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint" forall a b. (a -> b) -> a -> b
$
                     HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
breakInfo_module)
       interp :: Interp
interp    = HscEnv -> Interp
hscInterp HscEnv
hsc_env
       breaks :: ModBreaks
breaks    = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
       info :: CgBreakInfo
info      = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"bindLocalsAtBreakpoint2" forall a b. (a -> b) -> a -> b
$
                     forall a. BreakIndex -> IntMap a -> Maybe a
IntMap.lookup BreakIndex
breakInfo_number (ModBreaks -> IntMap CgBreakInfo
modBreaks_breakInfo ModBreaks
breaks)
       mbVars :: [Maybe (Id, Word16)]
mbVars    = CgBreakInfo -> [Maybe (Id, Word16)]
cgb_vars CgBreakInfo
info
       result_ty :: Kind
result_ty = CgBreakInfo -> Kind
cgb_resty CgBreakInfo
info
       occs :: [OccName]
occs      = ModBreaks -> Array BreakIndex [OccName]
modBreaks_vars ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
       span :: SrcSpan
span      = ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
       decl :: String
decl      = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ ModBreaks -> Array BreakIndex [String]
modBreaks_decls ModBreaks
breaks forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number

           -- Filter out any unboxed ids by changing them to Nothings;
           -- we can't bind these at the prompt
       mbPointers :: [Maybe (Id, Word16)]
mbPointers = forall {b}. Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Id, Word16)]
mbVars

       ([Id]
ids, [Word16]
offsets, [OccName]
occs') = forall a b c. [Maybe (a, b)] -> [c] -> ([a], [b], [c])
syncOccs [Maybe (Id, Word16)]
mbPointers [OccName]
occs

       free_tvs :: [Id]
free_tvs = [Kind] -> [Id]
tyCoVarsOfTypesList (Kind
result_tyforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
ids)

   -- 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.
   [Maybe ForeignHValue]
mb_hValues <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Interp -> ForeignHValue -> BreakIndex -> IO (Maybe ForeignHValue)
getBreakpointVar Interp
interp ForeignHValue
apStack_fhv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word16]
offsets
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isNothing [Maybe ForeignHValue]
mb_hValues) forall a b. (a -> b) -> a -> b
$
      Logger -> DynFlags -> BreakIndex -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) BreakIndex
1 forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Warning: _result has been evaluated, some bindings have been lost"

   UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'I'   -- Dodgy; will give the same uniques every time
   let tv_subst :: TCvSubst
tv_subst     = UniqSupply -> [Id] -> TCvSubst
newTyVars UniqSupply
us [Id]
free_tvs
       ([Id]
filtered_ids, [OccName]
occs'') = forall a b. [(a, b)] -> ([a], [b])
unzip         -- again, sync the occ-names
          [ (Id
id, OccName
occ) | (Id
id, Just ForeignHValue
_hv, OccName
occ) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
ids [Maybe ForeignHValue]
mb_hValues [OccName]
occs' ]
       (TidyEnv
_,[Kind]
tidy_tys) = TidyEnv -> [Kind] -> (TidyEnv, [Kind])
tidyOpenTypes TidyEnv
emptyTidyEnv forall a b. (a -> b) -> a -> b
$
                      forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
tv_subst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType) [Id]
filtered_ids

   [Id]
new_ids     <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M OccName -> Kind -> Id -> IO Id
mkNewId [OccName]
occs'' [Kind]
tidy_tys [Id]
filtered_ids
   Name
result_name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env (FastString -> OccName
mkVarOccFS FastString
result_fs) SrcSpan
span

   let result_id :: Id
result_id = Name -> Kind -> Id
Id.mkVanillaGlobal Name
result_name
                     (HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
tv_subst Kind
result_ty)
       result_ok :: Bool
result_ok = Id -> Bool
isPointer Id
result_id

       final_ids :: [Id]
final_ids | Bool
result_ok = Id
result_id forall a. a -> [a] -> [a]
: [Id]
new_ids
                 | Bool
otherwise = [Id]
new_ids
       ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id]
final_ids
       names :: [Name]
names  = forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
new_ids

   let fhvs :: [ForeignHValue]
fhvs = forall a. [Maybe a] -> [a]
catMaybes [Maybe ForeignHValue]
mb_hValues
   Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ForeignHValue]
fhvs)
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
result_ok forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
Loader.extendLoadedEnv Interp
interp [(Name
result_name, ForeignHValue
apStack_fhv)]
   HscEnv
hsc_env1 <- HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }
   forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env1, if Bool
result_ok then Name
result_nameforall a. a -> [a] -> [a]
:[Name]
names else [Name]
names, SrcSpan
span, String
decl)
  where
        -- 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
name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
old_id)
          ; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> IdInfo -> Id
Id.mkVanillaGlobalWithInfo Name
name Kind
ty (HasDebugCallStack => Id -> IdInfo
idInfo Id
old_id)) }

   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
     -- Similarly, clone the type variables mentioned in the types
     -- we have here, *and* make them all RuntimeUnk tyvars
   newTyVars :: UniqSupply -> [Id] -> TCvSubst
newTyVars UniqSupply
us [Id]
tvs
     = [(Id, Kind)] -> TCvSubst
mkTvSubstPrs [ (Id
tv, Id -> Kind
mkTyVarTy (Name -> Kind -> Id
mkRuntimeUnkTyVar Name
name (Id -> Kind
tyVarKind Id
tv)))
                    | (Id
tv, Unique
uniq) <- [Id]
tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us
                    , let name :: Name
name = Name -> Unique -> Name
setNameUnique (Id -> Name
tyVarName Id
tv) Unique
uniq ]

   isPointer :: Id -> Bool
isPointer Id
id | [PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
id)
                , PrimRep -> Bool
isGcPtrRep PrimRep
rep                   = Bool
True
                | Bool
otherwise                        = Bool
False

   -- 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          = forall a. a -> Maybe a
Just (Id, b)
fv
     | Bool
otherwise             = forall a. Maybe a
Nothing
   nullUnboxed Maybe (Id, b)
Nothing       = forall a. Maybe a
Nothing

   -- 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 = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs [Maybe (a, b)]
mbVs [c]
ocs
     where
       joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
       joinOccs :: forall a b c. [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"bindLocalsAtBreakpoint" forall {f :: * -> *} {a} {b} {c}.
Applicative f =>
f (a, b) -> c -> f (a, b, c)
joinOcc
       joinOcc :: f (a, b) -> c -> f (a, b, c)
joinOcc f (a, b)
mbV c
oc = (\(a
a,b
b) c
c -> (a
a,b
b,c
c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
mbV forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
oc

rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} = do
   let tmp_ids :: [Id]
tmp_ids = [Id
id | AnId Id
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
       incompletelyTypedIds :: [Id]
incompletelyTypedIds =
           [Id
id | Id
id <- [Id]
tmp_ids
               , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Id -> Bool
noSkolems Id
id
               , (OccName -> FastString
occNameFSforall b c a. (b -> c) -> (a -> b) -> a -> c
.Name -> OccName
nameOccNameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name
idName) Id
id forall a. Eq a => a -> a -> Bool
/= FastString
result_fs]
   forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HscEnv -> Name -> IO HscEnv
improveTypes HscEnv
hsc_env (forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
incompletelyTypedIds)
    where
     noSkolems :: Id -> Bool
noSkolems = Kind -> Bool
noFreeVarsOfType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType
     improveTypes :: HscEnv -> Name -> IO HscEnv
improveTypes hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} Name
name = do
      let tmp_ids :: [Id]
tmp_ids = [Id
id | AnId Id
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
          Just Id
id = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Id
i -> Id -> Name
idName Id
i forall a. Eq a => a -> a -> Bool
== Name
name) [Id]
tmp_ids
      if Id -> Bool
noSkolems Id
id
         then forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
         else do
           Maybe Kind
mb_new_ty <- HscEnv -> BreakIndex -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env BreakIndex
10 Id
id
           let old_ty :: Kind
old_ty = Id -> Kind
idType Id
id
           case Maybe Kind
mb_new_ty of
             Maybe Kind
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
             Just Kind
new_ty -> do
              case HscEnv -> Kind -> Kind -> Maybe TCvSubst
improveRTTIType HscEnv
hsc_env Kind
old_ty Kind
new_ty of
               Maybe TCvSubst
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just TCvSubst
subst -> do
                 let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
                 let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
                 Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_rtti String
"RTTI"
                   DumpFormat
FormatText
                   ([SDoc] -> SDoc
fsep [String -> SDoc
text String
"RTTI Improvement for", forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
equals,
                          forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst])

                 let ic' :: InteractiveContext
ic' = InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext InteractiveContext
ic TCvSubst
subst
                 forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{hsc_IC :: InteractiveContext
hsc_IC=InteractiveContext
ic'}

pushResume :: HscEnv -> Resume -> HscEnv
pushResume :: HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env Resume
resume = HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }
  where
        ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
        ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext
ictxt0 { ic_resume :: [Resume]
ic_resume = Resume
resume forall a. a -> [a] -> [a]
: InteractiveContext -> [Resume]
ic_resume InteractiveContext
ictxt0 }


  {-
  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 environement.
  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
   HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
       interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
   case [Resume]
resume of
      []    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Resume
r:[Resume]
rs  -> do
         forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [Resume]
rs } }
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interp (Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext Resume
r)
         forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

abandonAll :: GhcMonad m => m Bool
abandonAll :: forall (m :: * -> *). GhcMonad m => m Bool
abandonAll = do
   HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       resume :: [Resume]
resume = InteractiveContext -> [Resume]
ic_resume InteractiveContext
ic
       interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
   case [Resume]
resume of
      []  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      [Resume]
rs  -> do
         forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [] } }
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interpforall b c a. (b -> c) -> (a -> b) -> a -> c
. Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext) [Resume]
rs
         forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- -----------------------------------------------------------------------------
-- 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 = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
0 BreakIndex
bound [] []

consBL :: a -> BoundedList a -> BoundedList a
consBL :: forall a. a -> BoundedList a -> BoundedList a
consBL a
a (BL BreakIndex
len BreakIndex
bound [a]
left [a]
right)
  | BreakIndex
len forall a. Ord a => a -> a -> Bool
< BreakIndex
bound = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL (BreakIndex
lenforall a. Num a => a -> a -> a
+BreakIndex
1) BreakIndex
bound (a
aforall a. a -> [a] -> [a]
:[a]
left) [a]
right
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right  = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len     BreakIndex
bound [a
a]      forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
tail (forall a. [a] -> [a]
reverse [a]
left)
  | Bool
otherwise   = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL BreakIndex
len     BreakIndex
bound (a
aforall a. a -> [a] -> [a]
:[a]
left) forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
tail [a]
right

toListBL :: BoundedList a -> [a]
toListBL :: forall a. BoundedList a -> [a]
toListBL (BL BreakIndex
_ BreakIndex
_ [a]
left [a]
right) = [a]
left forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
right

fromListBL :: Int -> [a] -> BoundedList a
fromListBL :: forall a. BreakIndex -> [a] -> BoundedList a
fromListBL BreakIndex
bound [a]
l = forall a. BreakIndex -> BreakIndex -> [a] -> [a] -> BoundedList a
BL (forall (t :: * -> *) a. Foldable t => t a -> BreakIndex
length [a]
l) BreakIndex
bound [a]
l []

-- 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
-- constructs the ic_rn_glb_env 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 { HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       ; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
       ; Either (ModuleName, String) GlobalRdrEnv
all_env_err <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
findGlobalRdrEnv HscEnv
hsc_env [InteractiveImport]
imports
       ; case Either (ModuleName, String) GlobalRdrEnv
all_env_err of
           Left (ModuleName
mod, String
err) ->
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. GhcException -> IO a
throwGhcExceptionIO (forall {a}. Outputable a => DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags ModuleName
mod String
err)
           Right GlobalRdrEnv
all_env -> do {
       ; let old_ic :: InteractiveContext
old_ic         = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
             !final_rdr_env :: GlobalRdrEnv
final_rdr_env = GlobalRdrEnv
all_env GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
`icExtendGblRdrEnv` InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
old_ic
       ; forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession
         HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
old_ic { ic_imports :: [InteractiveImport]
ic_imports    = [InteractiveImport]
imports
                                  , ic_rn_gbl_env :: GlobalRdrEnv
ic_rn_gbl_env = GlobalRdrEnv
final_rdr_env }}}}
  where
    formatError :: DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags a
mod String
err = String -> GhcException
ProgramError forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text String
"Cannot add module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
mod SDoc -> SDoc -> SDoc
<+>
      String -> SDoc
text String
"to context:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
err

findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv :: HscEnv
-> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
findGlobalRdrEnv HscEnv
hsc_env [InteractiveImport]
imports
  = do { GlobalRdrEnv
idecls_env <- HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
idecls
                    -- This call also loads any orphan modules
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either (ModuleName, String) GlobalRdrEnv
mkEnv [ModuleName]
imods) of
           ([], [GlobalRdrEnv]
imods_env) -> forall a b. b -> Either a b
Right (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv GlobalRdrEnv
idecls_env [GlobalRdrEnv]
imods_env)
           ((ModuleName, String)
err : [(ModuleName, String)]
_, [GlobalRdrEnv]
_)    -> forall a b. a -> Either a b
Left (ModuleName, String)
err }
  where
    idecls :: [LImportDecl GhcPs]
    idecls :: [LImportDecl GhcPs]
idecls = [forall a an. a -> LocatedAn an a
noLocA ImportDecl GhcPs
d | IIDecl ImportDecl GhcPs
d <- [InteractiveImport]
imports]

    imods :: [ModuleName]
    imods :: [ModuleName]
imods = [ModuleName
m | IIModule ModuleName
m <- [InteractiveImport]
imports]

    mkEnv :: ModuleName -> Either (ModuleName, String) GlobalRdrEnv
mkEnv ModuleName
mod = case HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod of
      Left String
err -> forall a b. a -> Either a b
Left (ModuleName
mod, String
err)
      Right GlobalRdrEnv
env -> forall a b. b -> Either a b
Right GlobalRdrEnv
env

mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv HomePackageTable
hpt ModuleName
modl
  = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
modl of
      Maybe HomeModInfo
Nothing -> forall a b. a -> Either a b
Left String
"not a home module"
      Just HomeModInfo
details ->
         case forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details) of
                Maybe GlobalRdrEnv
Nothing  -> forall a b. a -> Either a b
Left String
"not interpreted"
                Just GlobalRdrEnv
env -> forall a b. b -> Either a b
Right GlobalRdrEnv
env

-- | 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv{ hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic } ->
             forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> [InteractiveImport]
ic_imports InteractiveContext
ic)

-- | 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
h ->
 if HomeUnit -> Module -> Bool
notHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
h) Module
modl
        then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
h) (forall unit. GenModule unit -> ModuleName
moduleName Module
modl) of
                Just HomeModInfo
details       -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Bool
isJust (forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details)))
                Maybe HomeModInfo
_not_a_home_module -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Looks up an identifier in the current interactive context (for :info)
-- Filter the instances by the ones whose tycons (or clases 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
  = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    do Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env Name
name
       case Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff of
         Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         Just (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, SDoc
docs) -> do
           let rdr_env :: GlobalRdrEnv
rdr_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)

           -- Filter the instances based on whether the constituent names of their
           -- instance heads are all in scope.
           let cls_insts' :: [ClsInst]
cls_insts' = forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> NameSet
orphNamesOfClsInst) [ClsInst]
cls_insts
               fam_insts' :: [FamInst]
fam_insts' = forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> NameSet
orphNamesOfFamInst) [FamInst]
fam_insts
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts', [FamInst]
fam_insts', SDoc
docs))
  where
    plausible :: GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env NameSet
names
          -- Dfun involving only names that are in ic_rn_glb_env
        = 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 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
               | Name -> Bool
isBuiltInSyntax Name
n      = Bool
True
               | Name -> Bool
isCTupleTyConName Name
n    = Bool
True
               | Name -> Bool
isExternalName Name
n       = forall a. Maybe a -> Bool
isJust (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
n)
               | Bool
otherwise              = Bool
True

-- | Returns all names in scope in the current interactive context
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope :: forall (m :: * -> *). GhcMonad m => m [Name]
getNamesInScope = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
greMangledName (GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts (InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))))

-- | 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  let
      ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
      gbl_rdrenv :: GlobalRdrEnv
gbl_rdrenv = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ic
      gbl_names :: [RdrName]
gbl_names = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GlobalRdrElt -> [RdrName]
greRdrNames forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
gbl_rdrenv
  -- Exclude internally generated names; see e.g. #11328
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc) [RdrName]
gbl_names)


-- | 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 [Name]
parseName :: forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
str = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
   do { LocatedN RdrName
lrdr_name <- HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier HscEnv
hsc_env String
str
      ; HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName HscEnv
hsc_env LocatedN RdrName
lrdr_name }


getDocs :: GhcMonad m
        => Name
        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
           -- TODO: What about docs for constructors etc.?
getDocs :: forall (m :: * -> *).
GhcMonad m =>
Name
-> m (Either
        GetDocsFailure (Maybe HsDocString, IntMap HsDocString))
getDocs Name
name =
  forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
     case Name -> Maybe Module
nameModule_maybe Name
name of
       Maybe Module
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Name -> GetDocsFailure
NameHasNoModule Name
name))
       Just Module
mod -> do
         if Module -> Bool
isInteractiveModule Module
mod
           then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left GetDocsFailure
InteractiveName)
           else do
             ModIface { mi_doc_hdr :: forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe HsDocString
mi_doc_hdr = Maybe HsDocString
mb_doc_hdr
                      , mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap Map Name HsDocString
dmap
                      , mi_arg_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> ArgDocMap
mi_arg_docs = ArgDocMap Map Name (IntMap HsDocString)
amap
                      } <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env Module
mod
             if forall a. Maybe a -> Bool
isNothing Maybe HsDocString
mb_doc_hdr Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Name HsDocString
dmap Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Name (IntMap HsDocString)
amap
               then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod Bool
compiled))
               else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ( forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap
                                , forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Name
name Map Name (IntMap HsDocString)
amap))
  where
    compiled :: Bool
compiled =
      -- TODO: Find a more direct indicator.
      case Name -> SrcLoc
nameSrcLoc Name
name of
        RealSrcLoc {} -> Bool
False
        UnhelpfulLoc {} -> Bool
True

-- | Failure modes for 'getDocs'.

-- TODO: Find a way to differentiate between modules loaded without '-haddock'
-- and modules that contain no docs.
data GetDocsFailure

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

    -- | This is probably because the module was loaded without @-haddock@,
    -- but it's also possible that the entire module contains no documentation.
  | 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 (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has no module where we could look for docs."
  ppr (NoDocsInIface Module
mod Bool
compiled) = [SDoc] -> SDoc
vcat
    [ String -> SDoc
text String
"Can't find any documentation for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.'
    , String -> SDoc
text String
"This is probably because the module was"
        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (if Bool
compiled then String
"compiled" else String
"loaded")
        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"without '-haddock',"
    , String -> SDoc
text String
"but it's also possible that the module contains no documentation."
    , String -> SDoc
text String
""
    , if Bool
compiled
        then String -> SDoc
text String
"Try re-compiling with '-haddock'."
        else String -> SDoc
text String
"Try running ':set -haddock' and :load the file again."
        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
    ]
  ppr GetDocsFailure
InteractiveName =
    String -> SDoc
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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
   Kind
ty <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRnExprMode -> String -> IO Kind
hscTcExpr HscEnv
hsc_env TcRnExprMode
mode String
expr
   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TidyEnv -> Kind -> Kind
tidyType TidyEnv
emptyTidyEnv Kind
ty

-- -----------------------------------------------------------------------------
-- 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Bool -> String -> IO (Kind, Kind)
hscKcType HscEnv
hsc_env Bool
normalise String
str

-- ----------------------------------------------------------------------------
-- 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
    forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)
runTcInteractive HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
      -- 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)
      [(ClsInst, [Maybe Kind])]
matches <- Kind -> TcM [(ClsInst, [Maybe Kind])]
findMatchingInstances Kind
ty

      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ClsInst, [Maybe Kind])]
matches forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ClsInst
-> [Maybe Kind] -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe ClsInst)
checkForExistence

-- 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env0 -> do
  (Kind
ty, Kind
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    GenLocated SrcSpanAnnA (HsType GhcPs)
ty <- String -> Hsc (LHsType GhcPs)
hscParseType String
str
    forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages DecoratedSDoc, Maybe (Kind, Kind))
tcRnType HscEnv
hsc_env ZonkFlexi
SkolemiseFlexi Bool
True GenLocated SrcSpanAnnA (HsType GhcPs)
ty

  forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty

-- Get all the constraints required of a dictionary binding
getDictionaryBindings :: PredType -> TcM CtEvidence
getDictionaryBindings :: Kind -> TcM CtEvidence
getDictionaryBindings Kind
theta = do
  Name
dictName <- OccName -> TcM Name
newName (OccName -> OccName
mkDictOcc (String -> OccName
mkVarOcc String
"magic"))
  let dict_var :: Id
dict_var = Name -> Kind -> Id
mkVanillaGlobal Name
dictName Kind
theta
  CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (SkolemInfo -> CtOrigin
GivenOrigin SkolemInfo
UnkSkol) forall a. Maybe a
Nothing

  -- Generate a wanted here because at the end of constraint
  -- solving, most derived constraints get thrown away, which in certain
  -- cases, notably with quantified constraints makes it impossible to rule
  -- out instances as invalid. (See #18071)
  forall (m :: * -> *) a. Monad m => a -> m a
return CtWanted {
    ctev_pred :: Kind
ctev_pred = Id -> Kind
varType Id
dict_var,
    ctev_dest :: TcEvDest
ctev_dest = Id -> TcEvDest
EvVarDest Id
dict_var,
    ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WDeriv,
    ctev_loc :: CtLoc
ctev_loc = CtLoc
loc
  }

-- 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
ies@(InstEnvs {ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
ie_global, ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
ie_local}) <- TcM InstEnvs
tcGetInstEnvs
  let allClasses :: [Class]
allClasses = InstEnv -> [Class]
instEnvClasses InstEnv
ie_global forall a. [a] -> [a] -> [a]
++ InstEnv -> [Class]
instEnvClasses InstEnv
ie_local
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (InstEnvs -> Class -> [(ClsInst, [Maybe Kind])]
try_cls InstEnvs
ies) [Class]
allClasses
  where
  {- 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 (Kind
_, Kind
arg_kind, Kind
res_kind) <- Kind -> Maybe (Kind, Kind, Kind)
splitFunTy_maybe (TyCon -> Kind
tyConKind forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls)
    , Kind -> Bool
tcIsConstraintKind Kind
res_kind
    , HasDebugCallStack => Kind -> Kind
Type.typeKind Kind
ty Kind -> Kind -> Bool
`eqType` Kind
arg_kind
    , ([(ClsInst, [Maybe Kind])]
matches, [ClsInst]
_, [(ClsInst, [Maybe Kind])]
_) <- Bool
-> InstEnvs
-> Class
-> [Kind]
-> ([(ClsInst, [Maybe Kind])], [ClsInst],
    [(ClsInst, [Maybe Kind])])
lookupInstEnv Bool
True InstEnvs
ies Class
cls [Kind
ty]
    = [(ClsInst, [Maybe Kind])]
matches
    | Bool
otherwise
    = []


{-
  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.
  ([Kind]
tys, [Kind]
thetas) <- Id -> [Maybe Kind] -> TcM ([Kind], [Kind])
instDFunType (ClsInst -> Id
is_dfun ClsInst
clsInst) [Maybe Kind]
mb_inst_tys
  [CtEvidence]
wanteds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> TcM CtEvidence
getDictionaryBindings [Kind]
thetas
  -- 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 :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
impls } <- [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
wanteds

  if forall a. (a -> Bool) -> Bag a -> Bool
allBag Ct -> Bool
allowedSimple Cts
simples Bool -> Bool -> Bool
&& Bag Implication -> Bool
solvedImplics Bag Implication
impls
  then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Kind] -> [Kind] -> ClsInst -> ClsInst
substInstArgs [Kind]
tys (forall a. Bag a -> [a]
bagToList (forall a b. (a -> b) -> Bag a -> Bag b
mapBag Ct -> Kind
ctPred Cts
simples)) ClsInst
clsInst
  else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  where
  allowedSimple :: Ct -> Bool
  allowedSimple :: Ct -> Bool
allowedSimple Ct
ct = Kind -> Bool
isSatisfiablePred (Ct -> Kind
ctPred Ct
ct)

  solvedImplics :: Bag Implication -> Bool
  solvedImplics :: Bag Implication -> Bool
solvedImplics Bag Implication
impls = forall a. (a -> Bool) -> Bag a -> Bool
allBag (ImplicStatus -> Bool
isSolvedStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implication -> ImplicStatus
ic_status) Bag Implication
impls

  -- 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]
_)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTyVarTy [Kind]
tys
      Maybe (Class, [Kind])
_                   -> Kind -> Bool
isTyVarTy Kind
ty

  empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (Kind -> VarSet
tyCoVarsOfType (Id -> Kind
idType forall a b. (a -> b) -> a -> b
$ ClsInst -> Id
is_dfun ClsInst
clsInst)))

  {- 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 :: TCvSubst
subst = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TCvSubst
a (Id, Kind)
b -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (TCvSubst -> Id -> Kind -> TCvSubst
extendTvSubstAndInScope TCvSubst
a) (Id, Kind)
b) TCvSubst
empty_subst (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
dfun_tvs [Kind]
tys)
      -- Build instance head with arguments substituted in
      tau :: Kind
tau   = Class -> [Kind] -> Kind
mkClassPred Class
cls (HasCallStack => TCvSubst -> [Kind] -> [Kind]
substTheta TCvSubst
subst [Kind]
args)
      -- Constrain the instance with any residual constraints
      phi :: Kind
phi   = [Kind] -> Kind -> Kind
mkPhiTy [Kind]
thetas Kind
tau
      sigma :: Kind
sigma = [TyCoVarBinder] -> Kind -> Kind
mkForAllTys (forall a b. (a -> b) -> [a] -> [b]
map (\Id
v -> forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ArgFlag
Inferred) [Id]
dfun_tvs) Kind
phi

    in ClsInst
inst { is_dfun :: Id
is_dfun = (ClsInst -> Id
is_dfun ClsInst
inst) { varType :: Kind
varType = Kind
sigma }}
    where
    ([Id]
dfun_tvs, [Kind]
_, Class
cls, [Kind]
args) = ClsInst -> ([Id], [Kind], Class, [Kind])
instanceSig ClsInst
inst

-----------------------------------------------------------------------------
-- 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 = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr

-- | 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
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr

-- | 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
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr

-- | 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
_) = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

  -- > let _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' = forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc
      expr_name :: Name
expr_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (forall a. Uniquable a => a -> Unique
getUnique FastString
expr_fs) (FastString -> OccName
mkTyVarOccFS FastString
expr_fs) SrcSpan
loc'
      let_stmt :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
let_stmt = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds forall a. EpAnn a
noAnn) forall a b. (a -> b) -> a -> b
$
        forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds AnnSortKey
NoAnnSortKey
                     (forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc' (forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
expr_name) LHsExpr GhcPs
expr) []

  Maybe ([Id], ForeignHValue, FixityEnv)
pstmt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
let_stmt
  let (ForeignHValue
hvals_io, FixityEnv
fix_env) = case Maybe ([Id], ForeignHValue, FixityEnv)
pstmt of
        Just ([Id
_id], ForeignHValue
hvals_io', FixityEnv
fix_env') -> (ForeignHValue
hvals_io', FixityEnv
fix_env')
        Maybe ([Id], ForeignHValue, FixityEnv)
_ -> forall a. String -> a
panic String
"compileParsedExprRemote"

  forall (m :: * -> *). GhcMonad m => FixityEnv -> m ()
updateFixityEnv FixityEnv
fix_env
  EvalStatus_ [ForeignHValue] [HValueRef]
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> DynFlags
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp DynFlags
dflags Bool
False (forall a. a -> EvalExpr a
EvalThis ForeignHValue
hvals_io)
  case EvalStatus_ [ForeignHValue] [HValueRef]
status of
    EvalComplete Word64
_ (EvalSuccess [ForeignHValue
hval]) -> forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval
    EvalComplete Word64
_ (EvalException SerializableException
e) ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
    EvalStatus_ [ForeignHValue] [HValueRef]
_ -> forall a. String -> a
panic String
"compileParsedExpr"

compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr :: forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
expr = do
   ForeignHValue
fhv <- forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote LHsExpr GhcPs
expr
   Interp
interp <- HscEnv -> Interp
hscInterp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> ForeignRef a -> IO a
wormhole Interp
interp ForeignHValue
fhv

-- | 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
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  -- > Data.Dynamic.toDyn expr
  let loc :: SrcSpanAnnA
loc = forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
      to_dyn_expr :: LHsExpr GhcPs
to_dyn_expr = forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
toDynName)
                            GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
  HValue
hval <- forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
to_dyn_expr
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b
unsafeCoerce HValue
hval :: Dynamic)

-----------------------------------------------------------------------------
-- 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 =
    forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
        Bool
interpreted <- forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary
        let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        -- extendModSummaryNoDeps because the message doesn't look at the deps
        forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags Bool
interpreted (ExtendedModSummary -> ModuleGraphNode
ModuleNode (ModSummary -> ExtendedModSummary
extendModSummaryNoDeps ModSummary
mod_summary)))

moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable :: forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary = forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
        Maybe HomeModInfo
Nothing       -> forall a. String -> a
panic String
"missing linkable"
        Just HomeModInfo
mod_info -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info of
          Maybe Linkable
Nothing       -> Bool
True
          Just Linkable
linkable -> Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
linkable)

----------------------------------------------------------------------------
-- 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 (forall a b. a -> b
unsafeCoerce a
x)
#else
obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of
#endif
  ExternalInterp {} -> forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError
                        String
"this operation requires -fno-external-interpreter")
  where
    interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId :: HscEnv -> BreakIndex -> Bool -> Id -> IO Term
obtainTermFromId HscEnv
hsc_env BreakIndex
bound Bool
force Id
id =  do
  ForeignHValue
hv <- Interp -> HscEnv -> Name -> IO ForeignHValue
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
  HscEnv -> BreakIndex -> Bool -> Kind -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env BreakIndex
bound Bool
force (Id -> Kind
idType Id
id) ForeignHValue
hv

-- 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
  ForeignHValue
hv <- Interp -> HscEnv -> Name -> IO ForeignHValue
Loader.loadName (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env (Id -> Name
varName Id
id)
  HscEnv -> BreakIndex -> Kind -> ForeignHValue -> IO (Maybe Kind)
cvReconstructType HscEnv
hsc_env BreakIndex
bound (Id -> Kind
idType Id
id) ForeignHValue
hv

mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar :: Name -> Kind -> Id
mkRuntimeUnkTyVar Name
name Kind
kind = Name -> Kind -> TcTyVarDetails -> Id
mkTcTyVar Name
name Kind
kind TcTyVarDetails
RuntimeUnk