{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,
    RecordWildCards, BangPatterns #-}

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

module InteractiveEval (
        Resume(..), History(..),
        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
        runDecls, runDeclsWithLocation, runParsedDecls,
        isStmt, hasImport, isImport, isDecl,
        parseImportDecl, SingleStep(..),
        abandon, abandonAll,
        getResumeContext,
        getHistorySpan,
        getModBreaks,
        getHistoryModule,
        back, forward,
        setContext, getContext,
        availsToGlobalRdrEnv,
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        getDocs,
        GetDocsFailure(..),
        showModule,
        moduleIsBootOrNotObjectLinkable,
        parseExpr, compileParsedExpr,
        compileExpr, dynCompileExpr,
        compileExprRemote, compileParsedExprRemote,
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
        ) where

#include "HsVersions.h"

import GhcPrelude

import InteractiveEvalTypes

import GHCi
import GHCi.Message
import GHCi.RemoteTypes
import GhcMonad
import HscMain
import HsSyn
import HscTypes
import InstEnv
import IfaceEnv   ( newInteractiveBinder )
import FamInstEnv ( FamInst )
import CoreFVs    ( orphNamesOfFamInst )
import TyCon
import Type             hiding( typeKind )
import RepType
import TcType           hiding( typeKind )
import Var
import Id
import Name             hiding ( varName )
import NameSet
import Avail
import RdrName
import VarEnv
import ByteCodeTypes
import Linker
import DynFlags
import Unique
import UniqSupply
import MonadUtils
import Module
import PrelNames  ( toDynName, pretendNameIsInScope )
import TysWiredIn ( isCTupleTyConName )
import Panic
import Maybes
import ErrUtils
import SrcLoc
import RtClosureInspect
import Outputable
import FastString
import Bag
import Util
import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)

import System.Directory
import Data.Dynamic
import Data.Either
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import StringBuffer (stringToStringBuffer)
import Control.Monad
import GHC.Exts
import Data.Array
import Exception

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

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

mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory hsc_env :: HscEnv
hsc_env hval :: ForeignHValue
hval bi :: 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 (BreakInfo -> Module)
-> (History -> BreakInfo) -> History -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> BreakInfo
historyBreakInfo

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

getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi :: HomeModInfo
hmi
  | Just linkable :: Linkable
linkable <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
    [BCOs cbc :: CompiledByteCode
cbc _] <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
  = ModBreaks -> Maybe ModBreaks -> ModBreaks
forall a. a -> Maybe a -> a
fromMaybe ModBreaks
emptyModBreaks (CompiledByteCode -> Maybe ModBreaks
bc_breaks CompiledByteCode
cbc)
  | Bool
otherwise
  = ModBreaks
emptyModBreaks -- probably object code

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

-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv :: FixityEnv -> m ()
updateFixityEnv fix_env :: FixityEnv
fix_env = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
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 :: SingleStep
-> String
-> Int
-> (ForeignHValue -> EvalExpr ForeignHValue)
-> ExecOptions
ExecOptions
  { execSingleStep :: SingleStep
execSingleStep = SingleStep
RunToCompletion
  , execSourceFile :: String
execSourceFile = "<interactive>"
  , execLineNumber :: Int
execLineNumber = 1
  , execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execWrap = ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
EvalThis -- just run the statement, don't wrap it in anything
  }

-- | Run a statement in the current interactive context.
execStmt
  :: GhcMonad m
  => String             -- ^ a statement (bind or expression)
  -> ExecOptions
  -> m ExecResult
execStmt :: String -> ExecOptions -> m ExecResult
execStmt input :: String
input exec_opts :: ExecOptions
exec_opts@ExecOptions{..} = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

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

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

-- | Like `execStmt`, but takes a parsed statement as argument. Useful when
-- doing preprocessing on the AST before execution, e.g. in GHCi (see
-- GHCi.UI.runStmt).
execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' :: GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' stmt :: GhciLStmt GhcPs
stmt stmt_text :: String
stmt_text ExecOptions{..} = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
    -- warnings about the implicit bindings we introduce.
    -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
    -- -wwarn-unused-local-binds)
    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 <- IO (Maybe ([Id], ForeignHValue, FixityEnv))
-> m (Maybe ([Id], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([Id], ForeignHValue, FixityEnv))
 -> m (Maybe ([Id], ForeignHValue, FixityEnv)))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
-> m (Maybe ([Id], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env' GhciLStmt GhcPs
stmt

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

        EvalStatus_ [ForeignHValue] [HValueRef]
status <-
          m (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD (m (EvalStatus_ [ForeignHValue] [HValueRef])
 -> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$
            IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalStatus_ [ForeignHValue] [HValueRef])
 -> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$
              HscEnv
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt HscEnv
hsc_env' (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 :: Int
size = DynFlags -> Int
ghciHistSize DynFlags
idflags'

        SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
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 (Int -> BoundedList History
emptyHistory Int
size)

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

-- | Run some declarations and return any user-visible names that were brought
-- into scope.
runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
runDeclsWithLocation :: String -> Int -> String -> m [Name]
runDeclsWithLocation source :: String
source line_num :: Int
line_num input :: String
input = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    [LHsDecl GhcPs]
decls <- IO [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env String
source Int
line_num String
input)
    [LHsDecl GhcPs] -> m [Name]
forall (m :: * -> *). GhcMonad m => [LHsDecl GhcPs] -> m [Name]
runParsedDecls [LHsDecl 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 :: [LHsDecl GhcPs] -> m [Name]
runParsedDecls decls :: [LHsDecl GhcPs]
decls = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (tyThings :: [TyThing]
tyThings, ic :: InteractiveContext
ic) <- IO ([TyThing], InteractiveContext)
-> m ([TyThing], InteractiveContext)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls)

    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic }
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    HscEnv
hsc_env' <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env
    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
    [Name] -> m [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> m [Name]) -> [Name] -> m [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName (OccName -> Bool) -> (Name -> OccName) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName)
             -- For this filter, see Note [What to show to users]
           ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (TyThing -> Name) -> [TyThing] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> Name
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 Trac #11051 for more background and examples.
-}

withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD :: m a -> m a
withVirtualCWD m :: m a
m = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    -- a virtual CWD is only necessary when we're running interpreted code in
    -- the same process as the compiler.
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) then m a
m else do

  let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  let set_cwd :: m String
set_cwd = do
        String
dir <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
        case InteractiveContext -> Maybe String
ic_cwd InteractiveContext
ic of
           Just dir :: String
dir -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir
           Nothing  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir

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

  m String -> (String -> m ()) -> (String -> m a) -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m String
set_cwd String -> m ()
forall (m :: * -> *). GhcMonad m => String -> m ()
reset_cwd ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \_ -> m a
m

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

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

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

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

       Bool
b <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
              HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus HscEnv
hsc_env (ModBreaks -> ForeignRef BreakArray
modBreaks_flags ModBreaks
breaks) Int
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 <- IO ForeignHValue -> m ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> m ForeignHValue)
-> IO ForeignHValue -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> HValueRef -> IO ForeignHValue
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env HValueRef
apStack_ref
           let bi :: BreakInfo
bi = Module -> Int -> BreakInfo
BreakInfo Module
modl Int
ix
               !history' :: BoundedList History
history' = HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack_fhv BreakInfo
bi History -> BoundedList History -> BoundedList History
forall a. a -> BoundedList a -> BoundedList a
`consBL` BoundedList History
history
                 -- history is strict, otherwise our BoundedList is pointless.
           ForeignRef (ResumeContext [HValueRef])
fhv <- IO (ForeignRef (ResumeContext [HValueRef]))
-> m (ForeignRef (ResumeContext [HValueRef]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignRef (ResumeContext [HValueRef]))
 -> m (ForeignRef (ResumeContext [HValueRef])))
-> IO (ForeignRef (ResumeContext [HValueRef]))
-> m (ForeignRef (ResumeContext [HValueRef]))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> RemoteRef (ResumeContext [HValueRef])
-> IO (ForeignRef (ResumeContext [HValueRef]))
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env RemoteRef (ResumeContext [HValueRef])
resume_ctxt
           EvalStatus_ [ForeignHValue] [HValueRef]
status <- IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalStatus_ [ForeignHValue] [HValueRef])
 -> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt HscEnv
hsc_env Bool
True ForeignRef (ResumeContext [HValueRef])
fhv
           SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
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 is_exception :: Bool
is_exception apStack_ref :: HValueRef
apStack_ref ix :: Int
ix mod_uniq :: Int
mod_uniq resume_ctxt :: RemoteRef (ResumeContext [HValueRef])
resume_ctxt ccs :: RemotePtr CostCentreStack
ccs <- EvalStatus_ [ForeignHValue] [HValueRef]
status
    = do
         HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
         ForeignRef (ResumeContext [HValueRef])
resume_ctxt_fhv <- IO (ForeignRef (ResumeContext [HValueRef]))
-> m (ForeignRef (ResumeContext [HValueRef]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignRef (ResumeContext [HValueRef]))
 -> m (ForeignRef (ResumeContext [HValueRef])))
-> IO (ForeignRef (ResumeContext [HValueRef]))
-> m (ForeignRef (ResumeContext [HValueRef]))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> RemoteRef (ResumeContext [HValueRef])
-> IO (ForeignRef (ResumeContext [HValueRef]))
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env RemoteRef (ResumeContext [HValueRef])
resume_ctxt
         ForeignHValue
apStack_fhv <- IO ForeignHValue -> m ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> m ForeignHValue)
-> IO ForeignHValue -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> HValueRef -> IO ForeignHValue
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env HValueRef
apStack_ref
         let hmi :: HomeModInfo
hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust "handleRunStatus" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$
                     HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                       (Int -> Unique
mkUniqueGrimily Int
mod_uniq)
             modl :: Module
modl = ModIface -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
             bp :: Maybe BreakInfo
bp | Bool
is_exception = Maybe BreakInfo
forall a. Maybe a
Nothing
                | Bool
otherwise = BreakInfo -> Maybe BreakInfo
forall a. a -> Maybe a
Just (Module -> Int -> BreakInfo
BreakInfo Module
modl Int
ix)
         (hsc_env1 :: HscEnv
hsc_env1, names :: [Name]
names, span :: SrcSpan
span, decl :: String
decl) <- IO (HscEnv, [Name], SrcSpan, String)
-> m (HscEnv, [Name], SrcSpan, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HscEnv, [Name], SrcSpan, String)
 -> m (HscEnv, [Name], SrcSpan, String))
-> IO (HscEnv, [Name], SrcSpan, String)
-> m (HscEnv, [Name], SrcSpan, String)
forall a b. (a -> b) -> a -> b
$
           HscEnv
-> ForeignHValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan, String)
bindLocalsAtBreakpoint HscEnv
hsc_env ForeignHValue
apStack_fhv Maybe BreakInfo
bp
         let
           resume :: Resume
resume = Resume :: String
-> ForeignRef (ResumeContext [HValueRef])
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> ForeignHValue
-> Maybe BreakInfo
-> SrcSpan
-> String
-> RemotePtr CostCentreStack
-> [History]
-> Int
-> 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 = BoundedList History -> [History]
forall a. BoundedList a -> [a]
toListBL BoundedList History
history
             , resumeDecl :: String
resumeDecl = String
decl
             , resumeCCS :: RemotePtr CostCentreStack
resumeCCS = RemotePtr CostCentreStack
ccs
             , resumeHistoryIx :: Int
resumeHistoryIx = 0 }
           hsc_env2 :: HscEnv
hsc_env2 = HscEnv -> Resume -> HscEnv
pushResume HscEnv
hsc_env1 Resume
resume

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

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

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

    | Bool
otherwise
    = String -> m ExecResult
forall a. String -> a
panic "not_tracing" -- actually exhaustive, but GHC can't tell


resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
resumeExec :: (SrcSpan -> Bool) -> SingleStep -> m ExecResult
resumeExec canLogSpan :: SrcSpan -> Bool
canLogSpan step :: SingleStep
step
 = do
   HscEnv
hsc_env <- m HscEnv
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
     [] -> IO ExecResult -> m ExecResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExecResult -> m ExecResult) -> IO ExecResult -> m ExecResult
forall a b. (a -> b) -> a -> b
$
           GhcException -> IO ExecResult
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError "not stopped at a breakpoint")
     (r :: Resume
r:rs :: [Resume]
rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
        let (resume_tmp_te :: [TyThing]
resume_tmp_te,resume_rdr_env :: 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 }
        HscEnv -> m ()
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 = (TyThing -> Name) -> [TyThing] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> Name
forall a. NamedThing a => a -> Name
getName [TyThing]
resume_tmp_te
            new_names :: [Name]
new_names = [ Name
n | TyThing
thing <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic
                            , let n :: Name
n = TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing
                            , Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
old_names) ]
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Name] -> IO ()
Linker.deleteFromLinkEnv [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 } -> do
               m ExecResult -> m ExecResult
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withVirtualCWD (m ExecResult -> m ExecResult) -> m ExecResult -> m ExecResult
forall a b. (a -> b) -> a -> b
$ do
                EvalStatus_ [ForeignHValue] [HValueRef]
status <- IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalStatus_ [ForeignHValue] [HValueRef])
 -> m (EvalStatus_ [ForeignHValue] [HValueRef]))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> m (EvalStatus_ [ForeignHValue] [HValueRef])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
GHCi.resumeStmt HscEnv
hsc_env (SingleStep -> Bool
isStep SingleStep
step) ForeignRef (ResumeContext [HValueRef])
fhv
                let prevHistoryLst :: BoundedList History
prevHistoryLst = Int -> [History] -> BoundedList History
forall a. Int -> [a] -> BoundedList a
fromListBL 50 [History]
hist
                    hist' :: BoundedList History
hist' = case Maybe BreakInfo
mb_brkpt of
                       Nothing -> BoundedList History
prevHistoryLst
                       Just bi :: BreakInfo
bi
                         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$SrcSpan -> Bool
canLogSpan SrcSpan
span -> BoundedList History
prevHistoryLst
                         | Bool
otherwise -> HscEnv -> ForeignHValue -> BreakInfo -> History
mkHistory HscEnv
hsc_env ForeignHValue
apStack BreakInfo
bi History -> BoundedList History -> BoundedList History
forall a. a -> BoundedList a -> BoundedList a
`consBL`
                                                        Int -> [History] -> BoundedList History
forall a. Int -> [a] -> BoundedList a
fromListBL 50 [History]
hist
                SingleStep
-> String
-> ([TyThing], GlobalRdrEnv)
-> [Id]
-> EvalStatus_ [ForeignHValue] [HValueRef]
-> BoundedList History
-> m ExecResult
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'

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

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

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

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

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

            ([Name], Int, SrcSpan, String) -> m ([Name], Int, SrcSpan, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
names, Int
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 Int
new_ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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], Int, SrcSpan, String)
forall (m :: * -> *).
GhcMonad m =>
ForeignHValue
-> Maybe BreakInfo -> m ([Name], Int, SrcSpan, String)
update_ic ForeignHValue
apStack Maybe BreakInfo
mb_brkpt
           else case [History]
history [History] -> Int -> History
forall a. [a] -> Int -> a
!! (Int
new_ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) of
                   History{..} ->
                     ForeignHValue
-> Maybe BreakInfo -> m ([Name], Int, SrcSpan, String)
forall (m :: * -> *).
GhcMonad m =>
ForeignHValue
-> Maybe BreakInfo -> m ([Name], Int, SrcSpan, String)
update_ic ForeignHValue
historyApStack (BreakInfo -> Maybe BreakInfo
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 "_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 hsc_env :: HscEnv
hsc_env apStack :: ForeignHValue
apStack Nothing = do
   let exn_occ :: OccName
exn_occ = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit "_exception")
       span :: SrcSpan
span    = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit "<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 "e"
       e_name :: Name
e_name  = Unique -> OccName -> SrcSpan -> Name
mkInternalName (FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
e_fs) (FastString -> OccName
mkTyVarOccFS FastString
e_fs) SrcSpan
span
       e_tyvar :: 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]
   --
   [(Name, ForeignHValue)] -> IO ()
Linker.extendLinkEnv [(Name
exn_name, ForeignHValue
apStack)]
   (HscEnv, [Name], SrcSpan, String)
-> IO (HscEnv, [Name], SrcSpan, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }, [Name
exn_name], SrcSpan
span, "<exception thrown>")

-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env :: HscEnv
hsc_env apStack_fhv :: ForeignHValue
apStack_fhv (Just BreakInfo{..}) = do
   let
       hmi :: HomeModInfo
hmi       = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust "bindLocalsAtBreakpoint" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$
                     HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
moduleName Module
breakInfo_module)
       breaks :: ModBreaks
breaks    = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
       info :: CgBreakInfo
info      = String -> Maybe CgBreakInfo -> CgBreakInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust "bindLocalsAtBreakpoint2" (Maybe CgBreakInfo -> CgBreakInfo)
-> Maybe CgBreakInfo -> CgBreakInfo
forall a b. (a -> b) -> a -> b
$
                     Int -> IntMap CgBreakInfo -> Maybe CgBreakInfo
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
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 Int [OccName]
modBreaks_vars ModBreaks
breaks Array Int [OccName] -> Int -> [OccName]
forall i e. Ix i => Array i e -> i -> e
! Int
breakInfo_number
       span :: SrcSpan
span      = ModBreaks -> Array Int SrcSpan
modBreaks_locs ModBreaks
breaks Array Int SrcSpan -> Int -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! Int
breakInfo_number
       decl :: String
decl      = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ModBreaks -> Array Int [String]
modBreaks_decls ModBreaks
breaks Array Int [String] -> Int -> [String]
forall i e. Ix i => Array i e -> i -> e
! Int
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 = Maybe (Id, Word16) -> Maybe (Id, Word16)
forall b. Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed (Maybe (Id, Word16) -> Maybe (Id, Word16))
-> [Maybe (Id, Word16)] -> [Maybe (Id, Word16)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Id, Word16)]
mbVars

       (ids :: [Id]
ids, offsets :: [Word16]
offsets, occs' :: [OccName]
occs') = [Maybe (Id, Word16)] -> [OccName] -> ([Id], [Word16], [OccName])
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_tyKind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:(Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
ids)

   -- It might be that getIdValFromApStack fails, because the AP_STACK
   -- has been accidentally evaluated, or something else has gone wrong.
   -- So that we don't fall over in a heap when this happens, just don't
   -- bind any free variables instead, and we emit a warning.
   [Maybe ForeignHValue]
mb_hValues <-
      (Word16 -> IO (Maybe ForeignHValue))
-> [Word16] -> IO [Maybe ForeignHValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar HscEnv
hsc_env ForeignHValue
apStack_fhv (Int -> IO (Maybe ForeignHValue))
-> (Word16 -> Int) -> Word16 -> IO (Maybe ForeignHValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word16]
offsets
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe ForeignHValue -> Bool) -> [Maybe ForeignHValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe ForeignHValue -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe ForeignHValue]
mb_hValues) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 1 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> MsgDoc
text "Warning: _result has been evaluated, some bindings have been lost"

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

   [Id]
new_ids     <- (OccName -> Kind -> Id -> IO Id)
-> [OccName] -> [Kind] -> [Id] -> IO [Id]
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
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 Id -> [Id] -> [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  = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
new_ids

   let fhvs :: [ForeignHValue]
fhvs = [Maybe ForeignHValue] -> [ForeignHValue]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ForeignHValue]
mb_hValues
   [(Name, ForeignHValue)] -> IO ()
Linker.extendLinkEnv ([Name] -> [ForeignHValue] -> [(Name, ForeignHValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ForeignHValue]
fhvs)
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
result_ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Name, ForeignHValue)] -> IO ()
Linker.extendLinkEnv [(Name
result_name, ForeignHValue
apStack_fhv)]
   HscEnv
hsc_env1 <- HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ictxt1 }
   (HscEnv, [Name], SrcSpan, String)
-> IO (HscEnv, [Name], SrcSpan, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env1, if Bool
result_ok then Name
result_nameName -> [Name] -> [Name]
forall 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 occ :: OccName
occ ty :: Kind
ty old_id :: Id
old_id
     = do { Name
name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ (Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
old_id)
          ; Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> IdInfo -> Id
Id.mkVanillaGlobalWithInfo Name
name Kind
ty (HasDebugCallStack => Id -> IdInfo
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 us :: UniqSupply
us tvs :: [Id]
tvs
     = [(Id, Kind)] -> TCvSubst
mkTvSubstPrs [ (Id
tv, Id -> Kind
mkTyVarTy (Name -> Kind -> Id
mkRuntimeUnkTyVar Name
name (Id -> Kind
tyVarKind Id
tv)))
                    | (tv :: Id
tv, uniq :: Unique
uniq) <- [Id]
tvs [Id] -> [Unique] -> [(Id, Unique)]
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
id | [rep :: PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
id)
                , PrimRep -> Bool
isGcPtrRep PrimRep
rep                   = Bool
True
                | Bool
otherwise                        = Bool
False

   -- Convert unboxed Id's to Nothings
   nullUnboxed :: Maybe (Id, b) -> Maybe (Id, b)
nullUnboxed (Just (fv :: (Id, b)
fv@(id :: Id
id, _)))
     | Id -> Bool
isPointer Id
id          = (Id, b) -> Maybe (Id, b)
forall a. a -> Maybe a
Just (Id, b)
fv
     | Bool
otherwise             = Maybe (Id, b)
forall a. Maybe a
Nothing
   nullUnboxed Nothing       = Maybe (Id, b)
forall a. Maybe a
Nothing

   -- See Note [Syncing breakpoint info]
   syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
   syncOccs :: [Maybe (a, b)] -> [c] -> ([a], [b], [c])
syncOccs mbVs :: [Maybe (a, b)]
mbVs ocs :: [c]
ocs = [(a, b, c)] -> ([a], [b], [c])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(a, b, c)] -> ([a], [b], [c])) -> [(a, b, c)] -> ([a], [b], [c])
forall a b. (a -> b) -> a -> b
$ [Maybe (a, b, c)] -> [(a, b, c)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (a, b, c)] -> [(a, b, c)])
-> [Maybe (a, b, c)] -> [(a, b, c)]
forall a b. (a -> b) -> a -> b
$ [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
forall a b c. [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs [Maybe (a, b)]
mbVs [c]
ocs
     where
       joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
       joinOccs :: [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
joinOccs = (Maybe (a, b) -> c -> Maybe (a, b, c))
-> [Maybe (a, b)] -> [c] -> [Maybe (a, b, c)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe (a, b) -> c -> Maybe (a, b, c)
forall (f :: * -> *) a b a.
Applicative f =>
f (a, b) -> a -> f (a, b, a)
joinOcc
       joinOcc :: f (a, b) -> a -> f (a, b, a)
joinOcc mbV :: f (a, b)
mbV oc :: a
oc = (\(a :: a
a,b :: b
b) c :: a
c -> (a
a,b
b,a
c)) ((a, b) -> a -> (a, b, a)) -> f (a, b) -> f (a -> (a, b, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
mbV f (a -> (a, b, a)) -> f a -> f (a, b, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
       incompletelyTypedIds :: [Id]
incompletelyTypedIds =
           [Id
id | Id
id <- [Id]
tmp_ids
               , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Bool
noSkolems Id
id
               , (OccName -> FastString
occNameFS(OccName -> FastString) -> (Id -> OccName) -> Id -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Name -> OccName
nameOccName(Name -> OccName) -> (Id -> Name) -> Id -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name
idName) Id
id FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FastString
result_fs]
   HscEnv
hsc_env' <- (HscEnv -> Name -> IO HscEnv) -> HscEnv -> [Name] -> IO HscEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HscEnv -> Name -> IO HscEnv
improveTypes HscEnv
hsc_env ((Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
incompletelyTypedIds)
   HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
    where
     noSkolems :: Id -> Bool
noSkolems = Kind -> Bool
noFreeVarsOfType (Kind -> Bool) -> (Id -> Kind) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType
     improveTypes :: HscEnv -> Name -> IO HscEnv
improveTypes hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} name :: Name
name = do
      let tmp_ids :: [Id]
tmp_ids = [Id
id | AnId id :: Id
id <- InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ic]
          Just id :: Id
id = (Id -> Bool) -> [Id] -> Maybe Id
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\i :: Id
i -> Id -> Name
idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) [Id]
tmp_ids
      if Id -> Bool
noSkolems Id
id
         then HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
         else do
           Maybe Kind
mb_new_ty <- HscEnv -> Int -> Id -> IO (Maybe Kind)
reconstructType HscEnv
hsc_env 10 Id
id
           let old_ty :: Kind
old_ty = Id -> Kind
idType Id
id
           case Maybe Kind
mb_new_ty of
             Nothing -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
             Just new_ty :: Kind
new_ty -> do
              case HscEnv -> Kind -> Kind -> Maybe TCvSubst
improveRTTIType HscEnv
hsc_env Kind
old_ty Kind
new_ty of
               Nothing -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst :: TCvSubst
subst -> do
                 let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
                 DynFlags -> DumpFlag -> String -> MsgDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_rtti "RTTI"
                   ([MsgDoc] -> MsgDoc
fsep [String -> MsgDoc
text "RTTI Improvement for", Id -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Id
id, MsgDoc
equals,
                          TCvSubst -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TCvSubst
subst])

                 let ic' :: InteractiveContext
ic' = InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext InteractiveContext
ic TCvSubst
subst
                 HscEnv -> IO HscEnv
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 hsc_env :: HscEnv
hsc_env resume :: 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 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 `compiler/main/InteractiveEval.hs: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 `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates
      the Id list) doesn't find an Id in the ByteCode environement.
  2.) If function `compiler/main/InteractiveEval.hs: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 :: m Bool
abandon = do
   HscEnv
hsc_env <- m HscEnv
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
      []    -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      r :: Resume
r:rs :: [Resume]
rs  -> do
         HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [Resume]
rs } }
         IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt HscEnv
hsc_env (Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext Resume
r)
         Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

abandonAll :: GhcMonad m => m Bool
abandonAll :: m Bool
abandonAll = do
   HscEnv
hsc_env <- m HscEnv
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
      []  -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      rs :: [Resume]
rs  -> do
         HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_resume :: [Resume]
ic_resume = [] } }
         IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Resume -> IO ()) -> [Resume] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt HscEnv
hsc_env(ForeignRef (ResumeContext [HValueRef]) -> IO ())
-> (Resume -> ForeignRef (ResumeContext [HValueRef]))
-> Resume
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resume -> ForeignRef (ResumeContext [HValueRef])
resumeContext) [Resume]
rs
         Bool -> m Bool
forall (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 :: Int -> BoundedList a
nilBL bound :: Int
bound = Int -> Int -> [a] -> [a] -> BoundedList a
forall a. Int -> Int -> [a] -> [a] -> BoundedList a
BL 0 Int
bound [] []

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

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

fromListBL :: Int -> [a] -> BoundedList a
fromListBL :: Int -> [a] -> BoundedList a
fromListBL bound :: Int
bound l :: [a]
l = Int -> Int -> [a] -> [a] -> BoundedList a
forall a. Int -> Int -> [a] -> [a] -> BoundedList a
BL ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l) Int
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 :: [InteractiveImport] -> m ()
setContext imports :: [InteractiveImport]
imports
  = do { HscEnv
hsc_env <- m HscEnv
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 <- IO (Either (ModuleName, String) GlobalRdrEnv)
-> m (Either (ModuleName, String) GlobalRdrEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ModuleName, String) GlobalRdrEnv)
 -> m (Either (ModuleName, String) GlobalRdrEnv))
-> IO (Either (ModuleName, String) GlobalRdrEnv)
-> m (Either (ModuleName, String) GlobalRdrEnv)
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 (mod :: ModuleName
mod, err :: String
err) ->
               IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (DynFlags -> ModuleName -> String -> GhcException
forall a. Outputable a => DynFlags -> a -> String -> GhcException
formatError DynFlags
dflags ModuleName
mod String
err)
           Right all_env :: 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
       ; HscEnv -> m ()
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 dflags :: DynFlags
dflags mod :: a
mod err :: String
err = String -> GhcException
ProgramError (String -> GhcException)
-> (MsgDoc -> String) -> MsgDoc -> GhcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> GhcException) -> MsgDoc -> GhcException
forall a b. (a -> b) -> a -> b
$
      String -> MsgDoc
text "Cannot add module" MsgDoc -> MsgDoc -> MsgDoc
<+> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
mod MsgDoc -> MsgDoc -> MsgDoc
<+>
      String -> MsgDoc
text "to context:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
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 hsc_env :: HscEnv
hsc_env imports :: [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
       ; Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ModuleName, String) GlobalRdrEnv
 -> IO (Either (ModuleName, String) GlobalRdrEnv))
-> Either (ModuleName, String) GlobalRdrEnv
-> IO (Either (ModuleName, String) GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ case [Either (ModuleName, String) GlobalRdrEnv]
-> ([(ModuleName, String)], [GlobalRdrEnv])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((ModuleName -> Either (ModuleName, String) GlobalRdrEnv)
-> [ModuleName] -> [Either (ModuleName, String) GlobalRdrEnv]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either (ModuleName, String) GlobalRdrEnv
mkEnv [ModuleName]
imods) of
           ([], imods_env :: [GlobalRdrEnv]
imods_env) -> GlobalRdrEnv -> Either (ModuleName, String) GlobalRdrEnv
forall a b. b -> Either a b
Right ((GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv)
-> GlobalRdrEnv -> [GlobalRdrEnv] -> GlobalRdrEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv GlobalRdrEnv
idecls_env [GlobalRdrEnv]
imods_env)
           (err :: (ModuleName, String)
err : _, _)    -> (ModuleName, String) -> Either (ModuleName, String) GlobalRdrEnv
forall a b. a -> Either a b
Left (ModuleName, String)
err }
  where
    idecls :: [LImportDecl GhcPs]
    idecls :: [LImportDecl GhcPs]
idecls = [SrcSpanLess (LImportDecl GhcPs) -> LImportDecl GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LImportDecl GhcPs)
ImportDecl GhcPs
d | IIDecl d :: ImportDecl GhcPs
d <- [InteractiveImport]
imports]

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

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

availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name :: ModuleName
mod_name avails :: [AvailInfo]
avails
  = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
imp_spec) [AvailInfo]
avails)
  where
      -- We're building a GlobalRdrEnv as if the user imported
      -- all the specified modules into the global interactive module
    imp_spec :: ImportSpec
imp_spec = ImpSpec :: ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec { is_decl :: ImpDeclSpec
is_decl = ImpDeclSpec
decl, is_item :: ImpItemSpec
is_item = ImpItemSpec
ImpAll}
    decl :: ImpDeclSpec
decl = ImpDeclSpec :: ModuleName -> ModuleName -> Bool -> SrcSpan -> ImpDeclSpec
ImpDeclSpec { is_mod :: ModuleName
is_mod = ModuleName
mod_name, is_as :: ModuleName
is_as = ModuleName
mod_name,
                         is_qual :: Bool
is_qual = Bool
False,
                         is_dloc :: SrcSpan
is_dloc = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc }

mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv hpt :: HomePackageTable
hpt modl :: ModuleName
modl
  = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
modl of
      Nothing -> String -> Either String GlobalRdrEnv
forall a b. a -> Either a b
Left "not a home module"
      Just details :: HomeModInfo
details ->
         case ModIface -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details) of
                Nothing  -> String -> Either String GlobalRdrEnv
forall a b. a -> Either a b
Left "not interpreted"
                Just env :: GlobalRdrEnv
env -> GlobalRdrEnv -> Either String GlobalRdrEnv
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 :: m [InteractiveImport]
getContext = (HscEnv -> m [InteractiveImport]) -> m [InteractiveImport]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [InteractiveImport]) -> m [InteractiveImport])
-> (HscEnv -> m [InteractiveImport]) -> m [InteractiveImport]
forall a b. (a -> b) -> a -> b
$ \HscEnv{ hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic } ->
             [InteractiveImport] -> m [InteractiveImport]
forall (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 :: Module -> m Bool
moduleIsInterpreted modl :: Module
modl = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \h :: HscEnv
h ->
 if Module -> UnitId
moduleUnitId Module
modl UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
h)
        then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
h) (Module -> ModuleName
moduleName Module
modl) of
                Just details :: HomeModInfo
details       -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GlobalRdrEnv -> Bool
forall a. Maybe a -> Bool
isJust (ModIface -> Maybe GlobalRdrEnv
mi_globals (HomeModInfo -> ModIface
hm_iface HomeModInfo
details)))
                _not_a_home_module :: Maybe HomeModInfo
_not_a_home_module -> Bool -> m Bool
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 Trac #1581)
getInfo :: GhcMonad m => Bool -> Name
        -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
getInfo :: Bool
-> Name
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
getInfo allInfo :: Bool
allInfo name :: Name
name
  = (HscEnv
 -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv
  -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
 -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
-> (HscEnv
    -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env ->
    do Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
mb_stuff <- IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
 -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
hscTcRnGetInfo HscEnv
hsc_env Name
name
       case Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
mb_stuff of
         Nothing -> Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
forall a. Maybe a
Nothing
         Just (thing :: TyThing
thing, fixity :: Fixity
fixity, cls_insts :: [ClsInst]
cls_insts, fam_insts :: [FamInst]
fam_insts, docs :: MsgDoc
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' = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env (NameSet -> Bool) -> (ClsInst -> NameSet) -> ClsInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> NameSet
orphNamesOfClsInst) [ClsInst]
cls_insts
               fam_insts' :: [FamInst]
fam_insts' = (FamInst -> Bool) -> [FamInst] -> [FamInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalRdrEnv -> NameSet -> Bool
plausible GlobalRdrEnv
rdr_env (NameSet -> Bool) -> (FamInst -> NameSet) -> FamInst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> NameSet
orphNamesOfFamInst) [FamInst]
fam_insts
           Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
-> Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
forall a. a -> Maybe a
Just (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts', [FamInst]
fam_insts', MsgDoc
docs))
  where
    plausible :: GlobalRdrEnv -> NameSet -> Bool
plausible rdr_env :: GlobalRdrEnv
rdr_env names :: 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 n :: Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name              = Bool
True
                       -- The one we looked for in the first place!
               | Name -> Bool
pretendNameIsInScope Name
n = Bool
True
               | Name -> Bool
isBuiltInSyntax Name
n      = Bool
True
               | Name -> Bool
isCTupleTyConName Name
n    = Bool
True
               | Name -> Bool
isExternalName Name
n       = Maybe GlobalRdrElt -> Bool
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 :: m [Name]
getNamesInScope = (HscEnv -> m [Name]) -> m [Name]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [Name]) -> m [Name])
-> (HscEnv -> m [Name]) -> m [Name]
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
  [Name] -> m [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ((GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
gre_name (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 :: m [RdrName]
getRdrNamesInScope = (HscEnv -> m [RdrName]) -> m [RdrName]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [RdrName]) -> m [RdrName])
-> (HscEnv -> m [RdrName]) -> m [RdrName]
forall a b. (a -> b) -> a -> b
$ \hsc_env :: 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 = (GlobalRdrElt -> [RdrName]) -> [GlobalRdrElt] -> [RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GlobalRdrElt -> [RdrName]
greRdrNames ([GlobalRdrElt] -> [RdrName]) -> [GlobalRdrElt] -> [RdrName]
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
gbl_rdrenv
  -- Exclude internally generated names; see e.g. Trac #11328
  [RdrName] -> m [RdrName]
forall (m :: * -> *) a. Monad m => a -> m a
return ((RdrName -> Bool) -> [RdrName] -> [RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RdrName -> Bool) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName (OccName -> Bool) -> (RdrName -> OccName) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc) [RdrName]
gbl_names)


-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
parseName :: GhcMonad m => String -> m [Name]
parseName :: String -> m [Name]
parseName str :: String
str = (HscEnv -> m [Name]) -> m [Name]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [Name]) -> m [Name])
-> (HscEnv -> m [Name]) -> m [Name]
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> IO [Name] -> m [Name]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Name] -> m [Name]) -> IO [Name] -> m [Name]
forall a b. (a -> b) -> a -> b
$
   do { Located RdrName
lrdr_name <- HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier HscEnv
hsc_env String
str
      ; HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName HscEnv
hsc_env Located RdrName
lrdr_name }

-- | Returns @True@ if passed string is a statement.
isStmt :: DynFlags -> String -> Bool
isStmt :: DynFlags -> String -> Bool
isStmt dflags :: DynFlags
dflags stmt :: String
stmt =
  case P (Maybe (GhciLStmt GhcPs))
-> DynFlags -> String -> ParseResult (Maybe (GhciLStmt GhcPs))
forall thing. P thing -> DynFlags -> String -> ParseResult thing
parseThing P (Maybe (GhciLStmt GhcPs))
Parser.parseStmt DynFlags
dflags String
stmt of
    Lexer.POk _ _ -> Bool
True
    Lexer.PFailed _ _ _ -> Bool
False

-- | Returns @True@ if passed string has an import declaration.
hasImport :: DynFlags -> String -> Bool
hasImport :: DynFlags -> String -> Bool
hasImport dflags :: DynFlags
dflags stmt :: String
stmt =
  case P (Located (HsModule GhcPs))
-> DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
forall thing. P thing -> DynFlags -> String -> ParseResult thing
parseThing P (Located (HsModule GhcPs))
Parser.parseModule DynFlags
dflags String
stmt of
    Lexer.POk _ thing :: Located (HsModule GhcPs)
thing -> Located (HsModule GhcPs) -> Bool
hasImports Located (HsModule GhcPs)
thing
    Lexer.PFailed _ _ _ -> Bool
False
  where
    hasImports :: Located (HsModule GhcPs) -> Bool
hasImports = Bool -> Bool
not (Bool -> Bool)
-> (Located (HsModule GhcPs) -> Bool)
-> Located (HsModule GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LImportDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([LImportDecl GhcPs] -> Bool)
-> (Located (HsModule GhcPs) -> [LImportDecl GhcPs])
-> Located (HsModule GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports (HsModule GhcPs -> [LImportDecl GhcPs])
-> (Located (HsModule GhcPs) -> HsModule GhcPs)
-> Located (HsModule GhcPs)
-> [LImportDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsModule GhcPs) -> HsModule GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

-- | Returns @True@ if passed string is an import declaration.
isImport :: DynFlags -> String -> Bool
isImport :: DynFlags -> String -> Bool
isImport dflags :: DynFlags
dflags stmt :: String
stmt =
  case P (LImportDecl GhcPs)
-> DynFlags -> String -> ParseResult (LImportDecl GhcPs)
forall thing. P thing -> DynFlags -> String -> ParseResult thing
parseThing P (LImportDecl GhcPs)
Parser.parseImport DynFlags
dflags String
stmt of
    Lexer.POk _ _ -> Bool
True
    Lexer.PFailed _ _ _ -> Bool
False

-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: DynFlags -> String -> Bool
isDecl :: DynFlags -> String -> Bool
isDecl dflags :: DynFlags
dflags stmt :: String
stmt = do
  case P (LHsDecl GhcPs)
-> DynFlags -> String -> ParseResult (LHsDecl GhcPs)
forall thing. P thing -> DynFlags -> String -> ParseResult thing
parseThing P (LHsDecl GhcPs)
Parser.parseDeclaration DynFlags
dflags String
stmt of
    Lexer.POk _ thing :: LHsDecl GhcPs
thing ->
      case LHsDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsDecl GhcPs
thing of
        SpliceD _ _ -> Bool
False
        _ -> Bool
True
    Lexer.PFailed _ _ _ -> Bool
False

parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
parseThing :: P thing -> DynFlags -> String -> ParseResult thing
parseThing parser :: P thing
parser dflags :: DynFlags
dflags stmt :: String
stmt = do
  let buf :: StringBuffer
buf = String -> StringBuffer
stringToStringBuffer String
stmt
      loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit "<interactive>") 1 1

  P thing -> PState -> ParseResult thing
forall a. P a -> PState -> ParseResult a
Lexer.unP P thing
parser (DynFlags -> StringBuffer -> RealSrcLoc -> PState
Lexer.mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc)

getDocs :: GhcMonad m
        => Name
        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
           -- TODO: What about docs for constructors etc.?
getDocs :: Name
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
getDocs name :: Name
name =
  (HscEnv
 -> m (Either
         GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv
  -> m (Either
          GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
 -> m (Either
         GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> (HscEnv
    -> m (Either
            GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
     case Name -> Maybe Module
nameModule_maybe Name
name of
       Nothing -> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
forall a b. a -> Either a b
Left (Name -> GetDocsFailure
NameHasNoModule Name
name))
       Just mod :: Module
mod -> do
         if Module -> Bool
isInteractiveModule Module
mod
           then Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
forall a b. a -> Either a b
Left GetDocsFailure
InteractiveName)
           else do
             ModIface { mi_doc_hdr :: ModIface -> Maybe HsDocString
mi_doc_hdr = Maybe HsDocString
mb_doc_hdr
                      , mi_decl_docs :: ModIface -> DeclDocMap
mi_decl_docs = DeclDocMap dmap :: Map Name HsDocString
dmap
                      , mi_arg_docs :: ModIface -> ArgDocMap
mi_arg_docs = ArgDocMap amap :: Map Name (Map Int HsDocString)
amap
                      } <- IO ModIface -> m ModIface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModIface -> m ModIface) -> IO ModIface -> m ModIface
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env Module
mod
             if Maybe HsDocString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe HsDocString
mb_doc_hdr Bool -> Bool -> Bool
&& Map Name HsDocString -> Bool
forall k a. Map k a -> Bool
Map.null Map Name HsDocString
dmap Bool -> Bool -> Bool
&& Map Name (Map Int HsDocString) -> Bool
forall k a. Map k a -> Bool
Map.null Map Name (Map Int HsDocString)
amap
               then Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetDocsFailure
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
forall a b. a -> Either a b
Left (Module -> Bool -> GetDocsFailure
NoDocsInIface Module
mod Bool
compiled))
               else Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe HsDocString, Map Int HsDocString)
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
forall a b. b -> Either a b
Right ( Name -> Map Name HsDocString -> Maybe HsDocString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap
                                , Map Int HsDocString
-> Name -> Map Name (Map Int HsDocString) -> Map Int HsDocString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Int HsDocString
forall k a. Map k a
Map.empty Name
name Map Name (Map Int 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 -> MsgDoc
ppr (NameHasNoModule name :: Name
name) =
    MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "has no module where we could look for docs."
  ppr (NoDocsInIface mod :: Module
mod compiled :: Bool
compiled) = [MsgDoc] -> MsgDoc
vcat
    [ String -> MsgDoc
text "Can't find any documentation for" MsgDoc -> MsgDoc -> MsgDoc
<+> Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Module
mod MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char '.'
    , String -> MsgDoc
text "This is probably because the module was"
        MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (if Bool
compiled then "compiled" else "loaded")
        MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "without '-haddock',"
    , String -> MsgDoc
text "but it's also possible that the module contains no documentation."
    , String -> MsgDoc
text ""
    , if Bool
compiled
        then String -> MsgDoc
text "Try re-compiling with '-haddock'."
        else String -> MsgDoc
text "Try running ':set -haddock' and :load the file again."
        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
    ]
  ppr InteractiveName =
    String -> MsgDoc
text "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 :: TcRnExprMode -> String -> m Kind
exprType mode :: TcRnExprMode
mode expr :: String
expr = (HscEnv -> m Kind) -> m Kind
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Kind) -> m Kind) -> (HscEnv -> m Kind) -> m Kind
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
   Kind
ty <- IO Kind -> m Kind
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Kind -> m Kind) -> IO Kind -> m Kind
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRnExprMode -> String -> IO Kind
hscTcExpr HscEnv
hsc_env TcRnExprMode
mode String
expr
   Kind -> m Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> m Kind) -> Kind -> m Kind
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 :: Bool -> String -> m (Kind, Kind)
typeKind normalise :: Bool
normalise str :: String
str = (HscEnv -> m (Kind, Kind)) -> m (Kind, Kind)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Kind, Kind)) -> m (Kind, Kind))
-> (HscEnv -> m (Kind, Kind)) -> m (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
   IO (Kind, Kind) -> m (Kind, Kind)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Kind, Kind) -> m (Kind, Kind))
-> IO (Kind, Kind) -> m (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Bool -> String -> IO (Kind, Kind)
hscKcType HscEnv
hsc_env Bool
normalise String
str

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

-- | Compile an expression, run it, and deliver the resulting HValue.
compileExpr :: GhcMonad m => String -> m HValue
compileExpr :: String -> m HValue
compileExpr expr :: String
expr = do
  LHsExpr GhcPs
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  LHsExpr GhcPs -> m HValue
forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
parsed_expr

-- | Compile an expression, run it, and deliver the resulting HValue.
compileExprRemote :: GhcMonad m => String -> m ForeignHValue
compileExprRemote :: String -> m ForeignHValue
compileExprRemote expr :: String
expr = do
  LHsExpr GhcPs
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  LHsExpr GhcPs -> m ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote LHsExpr GhcPs
parsed_expr

-- | Compile a parsed expression (before renaming), run it, and deliver
-- the resulting HValue.
compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote :: LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote expr :: LHsExpr GhcPs
expr@(L loc :: SrcSpan
loc _) = (HscEnv -> m ForeignHValue) -> m ForeignHValue
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ForeignHValue) -> m ForeignHValue)
-> (HscEnv -> m ForeignHValue) -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
  -- > 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 "_compileParsedExpr"
      expr_name :: Name
expr_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
expr_fs) (FastString -> OccName
mkTyVarOccFS FastString
expr_fs) SrcSpan
loc
      let_stmt :: GenLocated SrcSpan (StmtLR GhcPs GhcPs body)
let_stmt = SrcSpan
-> StmtLR GhcPs GhcPs body
-> GenLocated SrcSpan (StmtLR GhcPs GhcPs body)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR GhcPs GhcPs body
 -> GenLocated SrcSpan (StmtLR GhcPs GhcPs body))
-> (HsValBindsLR GhcPs GhcPs -> StmtLR GhcPs GhcPs body)
-> HsValBindsLR GhcPs GhcPs
-> GenLocated SrcSpan (StmtLR GhcPs GhcPs body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XLetStmt GhcPs GhcPs body
-> LHsLocalBindsLR GhcPs GhcPs -> StmtLR GhcPs GhcPs body
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs body
NoExt
noExt (LHsLocalBindsLR GhcPs GhcPs -> StmtLR GhcPs GhcPs body)
-> (HsValBindsLR GhcPs GhcPs -> LHsLocalBindsLR GhcPs GhcPs)
-> HsValBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> HsLocalBindsLR GhcPs GhcPs -> LHsLocalBindsLR GhcPs GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBindsLR GhcPs GhcPs)
-> (HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs)
-> HsValBindsLR GhcPs GhcPs
-> LHsLocalBindsLR GhcPs GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
NoExt
noExt) (HsValBindsLR GhcPs GhcPs
 -> GenLocated SrcSpan (StmtLR GhcPs GhcPs body))
-> HsValBindsLR GhcPs GhcPs
-> GenLocated SrcSpan (StmtLR GhcPs GhcPs body)
forall a b. (a -> b) -> a -> b
$
        XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExt
noExt
                     (LHsBind GhcPs -> LHsBindsLR GhcPs GhcPs
forall a. a -> Bag a
unitBag (LHsBind GhcPs -> LHsBindsLR GhcPs GhcPs)
-> LHsBind GhcPs -> LHsBindsLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
expr_name) LHsExpr GhcPs
expr) []

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

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

compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr :: LHsExpr GhcPs -> m HValue
compileParsedExpr expr :: LHsExpr GhcPs
expr = do
   ForeignHValue
fhv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote LHsExpr GhcPs
expr
   DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
   IO HValue -> m HValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HValue -> m HValue) -> IO HValue -> m HValue
forall a b. (a -> b) -> a -> b
$ DynFlags -> ForeignHValue -> IO HValue
forall a. DynFlags -> ForeignRef a -> IO a
wormhole DynFlags
dflags ForeignHValue
fhv

-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr :: String -> m Dynamic
dynCompileExpr expr :: String
expr = do
  LHsExpr GhcPs
parsed_expr <- String -> m (LHsExpr GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (LHsExpr GhcPs)
parseExpr String
expr
  -- > Data.Dynamic.toDyn expr
  let loc :: SrcSpan
loc = LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
parsed_expr
      to_dyn_expr :: LHsExpr GhcPs
to_dyn_expr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcPs -> LHsExpr GhcPs)
-> (RdrName -> HsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (Located RdrName -> HsExpr GhcPs)
-> (RdrName -> Located RdrName) -> RdrName -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RdrName -> LHsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
toDynName)
                            LHsExpr GhcPs
parsed_expr
  HValue
hval <- LHsExpr GhcPs -> m HValue
forall (m :: * -> *). GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr LHsExpr GhcPs
to_dyn_expr
  Dynamic -> m Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue -> Dynamic
unsafeCoerce# HValue
hval :: Dynamic)

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

showModule :: GhcMonad m => ModSummary -> m String
showModule :: ModSummary -> m String
showModule mod_summary :: ModSummary
mod_summary =
    (HscEnv -> m String) -> m String
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m String) -> m String)
-> (HscEnv -> m String) -> m String
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
        Bool
interpreted <- ModSummary -> m Bool
forall (m :: * -> *). GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable ModSummary
mod_summary
        let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg DynFlags
dflags (DynFlags -> HscTarget
hscTarget DynFlags
dflags) Bool
interpreted ModSummary
mod_summary)

moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable :: ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable mod_summary :: ModSummary
mod_summary = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \hsc_env :: 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
        Nothing       -> String -> m Bool
forall a. String -> a
panic "missing linkable"
        Just mod_info :: HomeModInfo
mod_info -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info of
          Nothing       -> Bool
True
          Just linkable :: Linkable
linkable -> Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
linkable)

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

obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal :: HscEnv -> Int -> Bool -> Kind -> a -> IO Term
obtainTermFromVal hsc_env :: HscEnv
hsc_env bound :: Int
bound force :: Bool
force ty :: Kind
ty x :: a
x
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
  = GhcException -> IO Term
forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError
      "this operation requires -fno-external-interpreter")
  | Bool
otherwise
  = HscEnv -> Int -> Bool -> Kind -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
bound Bool
force Kind
ty (a -> ForeignHValue
unsafeCoerce# a
x)

obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env :: HscEnv
hsc_env bound :: Int
bound force :: Bool
force id :: Id
id =  do
  ForeignHValue
hv <- HscEnv -> Name -> IO ForeignHValue
Linker.getHValue HscEnv
hsc_env (Id -> Name
varName Id
id)
  HscEnv -> Int -> Bool -> Kind -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
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 -> Int -> Id -> IO (Maybe Kind)
reconstructType hsc_env :: HscEnv
hsc_env bound :: Int
bound id :: Id
id = do
  ForeignHValue
hv <- HscEnv -> Name -> IO ForeignHValue
Linker.getHValue HscEnv
hsc_env (Id -> Name
varName Id
id)
  HscEnv -> Int -> Kind -> ForeignHValue -> IO (Maybe Kind)
cvReconstructType HscEnv
hsc_env Int
bound (Id -> Kind
idType Id
id) ForeignHValue
hv

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