{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, NamedFieldPuns, TupleSections, LambdaCase, OverloadedRecordDot #-}
module GHC.Debugger.Monad where

import Prelude hiding (mod)
import Data.Function
import System.Exit
import System.IO
import System.FilePath (normalise)
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception (assert)

import Control.Monad.Catch

import GHC
import qualified GHCi.BreakArray as BA
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Phases as GHC
import GHC.Driver.Pipeline as GHC
import GHC.Driver.Config.Logger as GHC
import GHC.Driver.Session.Units as GHC
import GHC.Unit.Module.ModSummary as GHC
import GHC.Utils.Outputable as GHC
import GHC.Utils.Monad as GHC
import GHC.Utils.Logger as GHC
import GHC.Types.Unique.Supply as GHC
import GHC.Runtime.Loader as GHC
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Heap.Inspect
import GHC.Unit.Module.Env as GHC
import GHC.Tc.Utils.TcType
import GHC.Driver.Env

import Data.IORef
import Data.Maybe
import qualified Data.List.NonEmpty as NE
import qualified Data.List as List
import qualified Data.IntMap as IM

import Control.Monad.Reader

import GHC.Debugger.Interface.Messages
import System.Posix.Signals

-- | A debugger action.
newtype Debugger a = Debugger { forall a. Debugger a -> ReaderT DebuggerState Ghc a
unDebugger :: ReaderT DebuggerState GHC.Ghc a }
  deriving ( (forall a b. (a -> b) -> Debugger a -> Debugger b)
-> (forall a b. a -> Debugger b -> Debugger a) -> Functor Debugger
forall a b. a -> Debugger b -> Debugger a
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Debugger a -> Debugger b
fmap :: forall a b. (a -> b) -> Debugger a -> Debugger b
$c<$ :: forall a b. a -> Debugger b -> Debugger a
<$ :: forall a b. a -> Debugger b -> Debugger a
Functor, Functor Debugger
Functor Debugger =>
(forall a. a -> Debugger a)
-> (forall a b. Debugger (a -> b) -> Debugger a -> Debugger b)
-> (forall a b c.
    (a -> b -> c) -> Debugger a -> Debugger b -> Debugger c)
-> (forall a b. Debugger a -> Debugger b -> Debugger b)
-> (forall a b. Debugger a -> Debugger b -> Debugger a)
-> Applicative Debugger
forall a. a -> Debugger a
forall a b. Debugger a -> Debugger b -> Debugger a
forall a b. Debugger a -> Debugger b -> Debugger b
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall a b c.
(a -> b -> c) -> Debugger a -> Debugger b -> Debugger c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Debugger a
pure :: forall a. a -> Debugger a
$c<*> :: forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
<*> :: forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Debugger a -> Debugger b -> Debugger c
liftA2 :: forall a b c.
(a -> b -> c) -> Debugger a -> Debugger b -> Debugger c
$c*> :: forall a b. Debugger a -> Debugger b -> Debugger b
*> :: forall a b. Debugger a -> Debugger b -> Debugger b
$c<* :: forall a b. Debugger a -> Debugger b -> Debugger a
<* :: forall a b. Debugger a -> Debugger b -> Debugger a
Applicative, Applicative Debugger
Applicative Debugger =>
(forall a b. Debugger a -> (a -> Debugger b) -> Debugger b)
-> (forall a b. Debugger a -> Debugger b -> Debugger b)
-> (forall a. a -> Debugger a)
-> Monad Debugger
forall a. a -> Debugger a
forall a b. Debugger a -> Debugger b -> Debugger b
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
>>= :: forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
$c>> :: forall a b. Debugger a -> Debugger b -> Debugger b
>> :: forall a b. Debugger a -> Debugger b -> Debugger b
$creturn :: forall a. a -> Debugger a
return :: forall a. a -> Debugger a
Monad, Monad Debugger
Monad Debugger =>
(forall a. IO a -> Debugger a) -> MonadIO Debugger
forall a. IO a -> Debugger a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Debugger a
liftIO :: forall a. IO a -> Debugger a
MonadIO
           , Monad Debugger
Monad Debugger =>
(forall e a. (HasCallStack, Exception e) => e -> Debugger a)
-> MonadThrow Debugger
forall e a. (HasCallStack, Exception e) => e -> Debugger a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> Debugger a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Debugger a
MonadThrow, MonadThrow Debugger
MonadThrow Debugger =>
(forall e a.
 (HasCallStack, Exception e) =>
 Debugger a -> (e -> Debugger a) -> Debugger a)
-> MonadCatch Debugger
forall e a.
(HasCallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
catch :: forall e a.
(HasCallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
MonadCatch, MonadCatch Debugger
MonadCatch Debugger =>
(forall b.
 HasCallStack =>
 ((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b)
-> (forall b.
    HasCallStack =>
    ((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b)
-> (forall a b c.
    HasCallStack =>
    Debugger a
    -> (a -> ExitCase b -> Debugger c)
    -> (a -> Debugger b)
    -> Debugger (b, c))
-> MonadMask Debugger
forall b.
HasCallStack =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
forall a b c.
HasCallStack =>
Debugger a
-> (a -> ExitCase b -> Debugger c)
-> (a -> Debugger b)
-> Debugger (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
mask :: forall b.
HasCallStack =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
$cgeneralBracket :: forall a b c.
HasCallStack =>
Debugger a
-> (a -> ExitCase b -> Debugger c)
-> (a -> Debugger b)
-> Debugger (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Debugger a
-> (a -> ExitCase b -> Debugger c)
-> (a -> Debugger b)
-> Debugger (b, c)
MonadMask
           , Debugger DynFlags
Debugger DynFlags -> HasDynFlags Debugger
forall (m :: * -> *). m DynFlags -> HasDynFlags m
$cgetDynFlags :: Debugger DynFlags
getDynFlags :: Debugger DynFlags
GHC.HasDynFlags, MonadReader DebuggerState )

-- | State required to run the debugger.
--
-- - Keep track of active breakpoints to easily unset them all.
data DebuggerState = DebuggerState
      { DebuggerState
-> IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
activeBreakpoints :: IORef (ModuleEnv (IM.IntMap (BreakpointStatus, BreakpointKind)))
        -- ^ Maps a 'BreakpointId' in Trie representation to the
        -- 'BreakpointStatus' it was activated with.
      , DebuggerState -> IORef (IntMap (Name, Term))
varReferences     :: IORef (IM.IntMap (Name, Term))
      -- ^ When we're stopped at a breakpoint, this maps variable reference to
      -- Terms to allow further inspection and forcing by reference.
      --
      -- This map is only valid while stopped in this context. After stepping
      -- or resuming evaluation in any available way, this map becomes invalid
      -- and should therefore be cleaned.
      , DebuggerState -> IORef Int
genUniq           :: IORef Int
      -- ^ Generates unique ints
      }

-- | Enabling/Disabling a breakpoint
data BreakpointStatus
      -- | Breakpoint is disabled
      --
      -- Note: this must be the first constructor s.t.
      --  @BreakpointDisabled < {BreakpointEnabled, BreakpointAfterCount}@
      = BreakpointDisabled
      -- | Breakpoint is enabled
      | BreakpointEnabled
      -- | Breakpoint is disabled the first N times and enabled afterwards
      | BreakpointAfterCount Int
      deriving (BreakpointStatus -> BreakpointStatus -> Bool
(BreakpointStatus -> BreakpointStatus -> Bool)
-> (BreakpointStatus -> BreakpointStatus -> Bool)
-> Eq BreakpointStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BreakpointStatus -> BreakpointStatus -> Bool
== :: BreakpointStatus -> BreakpointStatus -> Bool
$c/= :: BreakpointStatus -> BreakpointStatus -> Bool
/= :: BreakpointStatus -> BreakpointStatus -> Bool
Eq, Eq BreakpointStatus
Eq BreakpointStatus =>
(BreakpointStatus -> BreakpointStatus -> Ordering)
-> (BreakpointStatus -> BreakpointStatus -> Bool)
-> (BreakpointStatus -> BreakpointStatus -> Bool)
-> (BreakpointStatus -> BreakpointStatus -> Bool)
-> (BreakpointStatus -> BreakpointStatus -> Bool)
-> (BreakpointStatus -> BreakpointStatus -> BreakpointStatus)
-> (BreakpointStatus -> BreakpointStatus -> BreakpointStatus)
-> Ord BreakpointStatus
BreakpointStatus -> BreakpointStatus -> Bool
BreakpointStatus -> BreakpointStatus -> Ordering
BreakpointStatus -> BreakpointStatus -> BreakpointStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BreakpointStatus -> BreakpointStatus -> Ordering
compare :: BreakpointStatus -> BreakpointStatus -> Ordering
$c< :: BreakpointStatus -> BreakpointStatus -> Bool
< :: BreakpointStatus -> BreakpointStatus -> Bool
$c<= :: BreakpointStatus -> BreakpointStatus -> Bool
<= :: BreakpointStatus -> BreakpointStatus -> Bool
$c> :: BreakpointStatus -> BreakpointStatus -> Bool
> :: BreakpointStatus -> BreakpointStatus -> Bool
$c>= :: BreakpointStatus -> BreakpointStatus -> Bool
>= :: BreakpointStatus -> BreakpointStatus -> Bool
$cmax :: BreakpointStatus -> BreakpointStatus -> BreakpointStatus
max :: BreakpointStatus -> BreakpointStatus -> BreakpointStatus
$cmin :: BreakpointStatus -> BreakpointStatus -> BreakpointStatus
min :: BreakpointStatus -> BreakpointStatus -> BreakpointStatus
Ord)

--------------------------------------------------------------------------------
-- Operations
--------------------------------------------------------------------------------

-- | Additional settings configuring the debugger
data RunDebuggerSettings = RunDebuggerSettings
      { RunDebuggerSettings -> Bool
supportsANSIStyling :: Bool
      , RunDebuggerSettings -> Bool
supportsANSIHyperlinks :: Bool
      }

-- | Run a 'Debugger' action on a session constructed from a given GHC invocation.
runDebugger :: Handle     -- ^ The handle to which GHC's output is logged. The debuggee output is not affected by this parameter.
            -> FilePath   -- ^ The libdir (given with -B as an arg)
            -> [String]   -- ^ The list of units included in the invocation
            -> [String]   -- ^ The full ghc invocation (as constructed by hie-bios flags)
            -> RunDebuggerSettings -- ^ Other debugger run settings
            -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation
            -> IO a
runDebugger :: forall a.
Handle
-> FilePath
-> [FilePath]
-> [FilePath]
-> RunDebuggerSettings
-> Debugger a
-> IO a
runDebugger Handle
dbg_out FilePath
libdir [FilePath]
units [FilePath]
ghcInvocation' RunDebuggerSettings
conf (Debugger ReaderT DebuggerState Ghc a
action) = do
  let ghcInvocation :: [FilePath]
ghcInvocation = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\case (Char
'-':Char
'B':FilePath
_) -> Bool
False; FilePath
_ -> Bool
True) [FilePath]
ghcInvocation'

  Maybe FilePath -> Ghc a -> IO a
forall a. Maybe FilePath -> Ghc a -> IO a
GHC.runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    -- Workaround #4162
    _ <- IO Handler -> Ghc Handler
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> Ghc Handler) -> IO Handler -> Ghc Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
    dflags0 <- GHC.getSessionDynFlags

    let dflags1 = DynFlags
dflags0
          { GHC.ghcMode = GHC.CompManager
          , GHC.backend = GHC.interpreterBackend
          , GHC.ghcLink = GHC.LinkInMemory
          , GHC.verbosity = 1
          , GHC.canUseColor = conf.supportsANSIStyling
          , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks
          }
          -- Default GHCi settings
          DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_ImplicitImportQualified
          DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_IgnoreOptimChanges
          DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_IgnoreHpcChanges
          DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_UseBytecodeRatherThanObjects
          DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_InsertBreakpoints

    GHC.modifyLogger $
      -- Override the logger to output to the given handle
      GHC.pushLogHook (const $ debuggerLoggerAction dbg_out)

    logger1 <- GHC.getLogger
    let logger2 = Logger -> LogFlags -> Logger
GHC.setLogFlags Logger
logger1 (DynFlags -> LogFlags
GHC.initLogFlags DynFlags
dflags1)

          -- The rest of the arguments are "dynamic"
          -- Leftover ones are presumably files
    (dflags4, fileish_args, _dynamicFlagWarnings) <-
        GHC.parseDynamicFlags logger2 dflags1 (map (GHC.mkGeneralLocated "on ghc-debugger command arg") ghcInvocation)

    let (dflags5, srcs, objs) = GHC.parseTargetFiles dflags4 (map GHC.unLoc fileish_args)

    -- we've finished manipulating the DynFlags, update the session
    _ <- GHC.setSessionDynFlags dflags5

    dflags6 <- GHC.getSessionDynFlags

    -- Should this be done in GHC=
    liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6)

    -- Initialise plugins here because the plugin author might already expect this
    -- subsequent call to `getLogger` to be affected by a plugin.
    GHC.initializeSessionPlugins
    hsc_env <- GHC.getSession
    
    hs_srcs <- case NE.nonEmpty units of
      Just NonEmpty FilePath
ne_units -> do
        NonEmpty FilePath
-> (DynFlags
    -> [(FilePath, Maybe Phase)] -> [FilePath] -> [FilePath] -> IO ())
-> Ghc [(FilePath, Maybe UnitId, Maybe Phase)]
GHC.initMulti NonEmpty FilePath
ne_units (\DynFlags
_ [(FilePath, Maybe Phase)]
_ [FilePath]
_ [FilePath]
_ -> {-no options extra check-} () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      Maybe (NonEmpty FilePath)
Nothing -> do
        case [(FilePath, Maybe Phase)]
srcs of
          [] -> [(FilePath, Maybe UnitId, Maybe Phase)]
-> Ghc [(FilePath, Maybe UnitId, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          [(FilePath, Maybe Phase)]
_  -> do
            let ([(FilePath, Maybe Phase)]
hs_srcs, [(FilePath, Maybe Phase)]
non_hs_srcs) = ((FilePath, Maybe Phase) -> Bool)
-> [(FilePath, Maybe Phase)]
-> ([(FilePath, Maybe Phase)], [(FilePath, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (FilePath, Maybe Phase) -> Bool
GHC.isHaskellishTarget [(FilePath, Maybe Phase)]
srcs

            -- if we have no haskell sources from which to do a dependency
            -- analysis, then just do one-shot compilation and/or linking.
            -- This means that "ghc Foo.o Bar.o -o baz" links the program as
            -- we expect.
            if ([(FilePath, Maybe Phase)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, Maybe Phase)]
hs_srcs)
               then IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> StopPhase -> [(FilePath, Maybe Phase)] -> IO ()
GHC.oneShot HscEnv
hsc_env StopPhase
GHC.NoStop [(FilePath, Maybe Phase)]
srcs) Ghc ()
-> Ghc [(FilePath, Maybe UnitId, Maybe Phase)]
-> Ghc [(FilePath, Maybe UnitId, Maybe Phase)]
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(FilePath, Maybe UnitId, Maybe Phase)]
-> Ghc [(FilePath, Maybe UnitId, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return []
               else do
                 o_files <- ((FilePath, Maybe Phase) -> Ghc (Maybe FilePath))
-> [(FilePath, Maybe Phase)] -> Ghc [FilePath]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
GHC.mapMaybeM (\(FilePath, Maybe Phase)
x -> IO (Maybe FilePath) -> Ghc (Maybe FilePath)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> Ghc (Maybe FilePath))
-> IO (Maybe FilePath) -> Ghc (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
GHC.compileFile HscEnv
hsc_env StopPhase
GHC.NoStop (FilePath, Maybe Phase)
x) [(FilePath, Maybe Phase)]
non_hs_srcs
                 dflags7 <- GHC.getSessionDynFlags
                 let dflags' = DynFlags
dflags7 { GHC.ldInputs = map (GHC.FileOption "") o_files ++ GHC.ldInputs dflags7 }
                 _ <- GHC.setSessionDynFlags dflags'
                 return $ map (uncurry (,Nothing,)) hs_srcs

    targets' <- mapM (\(FilePath
src, Maybe UnitId
uid, Maybe Phase
phase) -> FilePath -> Maybe UnitId -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget FilePath
src Maybe UnitId
uid Maybe Phase
phase) hs_srcs
    GHC.setTargets targets'
    ok_flag <- GHC.load GHC.LoadAllTargets
    when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1))

    -- TODO: Shouldn't initLoaderState be called somewhere?

    -- Set interactive context to import all loaded modules
    -- TODO: Think about Note [GHCi and local Preludes] and what is done in `getImplicitPreludeImports`
    let preludeImp = ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> (ModuleName -> ImportDecl GhcPs)
-> ModuleName
-> InteractiveImport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl (ModuleName -> InteractiveImport)
-> ModuleName -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ FilePath -> ModuleName
GHC.mkModuleName FilePath
"Prelude"
    mss <- getAllLoadedModules
    GHC.setContext $ preludeImp : map (GHC.IIDecl . GHC.simpleImportDecl . GHC.ms_mod_name) mss

    runReaderT action =<< initialDebuggerState

-- | The logger action used to log GHC output
debuggerLoggerAction :: Handle -> LogAction
debuggerLoggerAction :: Handle -> LogAction
debuggerLoggerAction Handle
h LogFlags
a MessageClass
b SrcSpan
c SDoc
d = do
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8 -- GHC output uses utf8
  Handle -> Handle -> LogAction
defaultLogActionWithHandles Handle
h Handle
h LogFlags
a MessageClass
b SrcSpan
c SDoc
d

-- | Registers or deletes a breakpoint in the GHC session and from the list of
-- active breakpoints that is kept in 'DebuggerState', depending on the
-- 'BreakpointStatus' being set.
--
-- Returns @True@ when the breakpoint status is changed.
registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint :: BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint bp :: BreakpointId
bp@GHC.BreakpointId
                    { bi_tick_mod :: BreakpointId -> Module
GHC.bi_tick_mod = Module
mod
                    , bi_tick_index :: BreakpointId -> Int
GHC.bi_tick_index = Int
bid } BreakpointStatus
status BreakpointKind
kind = do

  -- Set breakpoint in GHC session
  let breakpoint_count :: Int
breakpoint_count = BreakpointStatus -> Int
breakpointStatusInt BreakpointStatus
status
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  GHC.setupBreakpoint hsc_env bp breakpoint_count

  -- Register breakpoint in Debugger state
  brksRef <- asks activeBreakpoints
  oldBrks <- liftIO $ readIORef brksRef
  let
    (newBrks, changed) = case status of
      -- Disabling the breakpoint; using the `Maybe` monad:
      -- * If we reach the return stmt then the breakpoint is active and we delete it.
      -- * Any other case, return False and change Nothing
      BreakpointStatus
BreakpointDisabled -> (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
-> Maybe
     (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
-> (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
forall a. a -> Maybe a -> a
fromMaybe (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks, Bool
False) (Maybe
   (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
 -> (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool))
-> Maybe
     (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
-> (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)), Bool)
forall a b. (a -> b) -> a -> b
$ do
        im <- ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module -> Maybe (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod
        _status <- IM.lookup bid im
        let im'  = Int
-> IntMap (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
bid IntMap (BreakpointStatus, BreakpointKind)
im
            brks = ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module
-> IntMap (BreakpointStatus, BreakpointKind)
-> ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod IntMap (BreakpointStatus, BreakpointKind)
im'
        return (brks, True)

      -- We're enabling the breakpoint:
      BreakpointStatus
_ -> case ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module -> Maybe (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod of
        Maybe (IntMap (BreakpointStatus, BreakpointKind))
Nothing ->
          let im :: IntMap (BreakpointStatus, BreakpointKind)
im   = Int
-> (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
forall a. Int -> a -> IntMap a
IM.singleton Int
bid (BreakpointStatus
status, BreakpointKind
kind)
              brks :: ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks = ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module
-> IntMap (BreakpointStatus, BreakpointKind)
-> ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod IntMap (BreakpointStatus, BreakpointKind)
im
           in (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks, Bool
True)
        Just IntMap (BreakpointStatus, BreakpointKind)
im -> case Int
-> IntMap (BreakpointStatus, BreakpointKind)
-> Maybe (BreakpointStatus, BreakpointKind)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bid IntMap (BreakpointStatus, BreakpointKind)
im of
          Maybe (BreakpointStatus, BreakpointKind)
Nothing ->
            -- Not yet in IntMap, extend with new Breakpoint
            let im' :: IntMap (BreakpointStatus, BreakpointKind)
im' = Int
-> (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
bid (BreakpointStatus
status, BreakpointKind
kind) IntMap (BreakpointStatus, BreakpointKind)
im
                brks :: ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks = ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module
-> IntMap (BreakpointStatus, BreakpointKind)
-> ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod IntMap (BreakpointStatus, BreakpointKind)
im'
             in (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks, Bool
True)
          Just (BreakpointStatus
status', BreakpointKind
_kind) ->
            -- Found in IntMap
            if BreakpointStatus
status' BreakpointStatus -> BreakpointStatus -> Bool
forall a. Eq a => a -> a -> Bool
== BreakpointStatus
status then
              (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks, Bool
False)
            else
              let im' :: IntMap (BreakpointStatus, BreakpointKind)
im'  = Int
-> (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
-> IntMap (BreakpointStatus, BreakpointKind)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
bid (BreakpointStatus
status, BreakpointKind
kind) IntMap (BreakpointStatus, BreakpointKind)
im
                  brks :: ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks = ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> Module
-> IntMap (BreakpointStatus, BreakpointKind)
-> ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
oldBrks Module
mod IntMap (BreakpointStatus, BreakpointKind)
im'
               in (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
brks, Bool
True)

  -- no races since the debugger execution is run in a single thread
  liftIO $ writeIORef brksRef newBrks
  return changed

-- | Get a list with all currently active breakpoints on the given module (by path)
--
-- If the path argument is @Nothing@, get all active function breakpoints instead
getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.BreakpointId]
getActiveBreakpoints :: Maybe FilePath -> Debugger [BreakpointId]
getActiveBreakpoints Maybe FilePath
mfile = do
  m <- (DebuggerState
 -> IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> Debugger
     (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState
-> IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
activeBreakpoints Debugger
  (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
    -> Debugger
         (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> Debugger (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
-> Debugger (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
 -> Debugger
      (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
    -> IO (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
-> Debugger (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
-> IO (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
forall a. IORef a -> IO a
readIORef
  case mfile of
    Just FilePath
file -> do
      ms <- FilePath -> Debugger ModSummary
getModuleByPath FilePath
file
      return $
        [ GHC.BreakpointId mod bix
        | (mod, im) <- moduleEnvToList m
        , mod == ms_mod ms
        , bix <- IM.keys im
        -- assert: status is always > disabled
        ]
    Maybe FilePath
Nothing -> do
      [BreakpointId] -> Debugger [BreakpointId]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BreakpointId] -> Debugger [BreakpointId])
-> [BreakpointId] -> Debugger [BreakpointId]
forall a b. (a -> b) -> a -> b
$
        [ Module -> Int -> BreakpointId
GHC.BreakpointId Module
mod Int
bix
        | (Module
mod, IntMap (BreakpointStatus, BreakpointKind)
im) <- ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> [(Module, IntMap (BreakpointStatus, BreakpointKind))]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
m
        , (Int
bix, (BreakpointStatus
status, BreakpointKind
kind)) <- IntMap (BreakpointStatus, BreakpointKind)
-> [(Int, (BreakpointStatus, BreakpointKind))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (BreakpointStatus, BreakpointKind)
im

        -- Keep only function breakpoints in this case
        , BreakpointKind
FunctionBreakpointKind BreakpointKind -> BreakpointKind -> Bool
forall a. Eq a => a -> a -> Bool
== BreakpointKind
kind

        , Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (BreakpointStatus
status BreakpointStatus -> BreakpointStatus -> Bool
forall a. Ord a => a -> a -> Bool
> BreakpointStatus
BreakpointDisabled) Bool
True
        ]

-- | List all loaded modules 'ModSummary's
getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
getAllLoadedModules :: forall (m :: * -> *). GhcMonad m => m [ModSummary]
getAllLoadedModules =
  (ModuleGraph -> [ModSummary]
GHC.mgModSummaries (ModuleGraph -> [ModSummary]) -> m ModuleGraph -> m [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
GHC.getModuleGraph) m [ModSummary]
-> ([ModSummary] -> m [ModSummary]) -> m [ModSummary]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (ModSummary -> m Bool) -> [ModSummary] -> m [ModSummary]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\ModSummary
ms -> UnitId -> ModuleName -> m Bool
forall (m :: * -> *). GhcMonad m => UnitId -> ModuleName -> m Bool
GHC.isLoadedModule (ModSummary -> UnitId
GHC.ms_unitid ModSummary
ms) (ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
ms))

-- | Get a 'ModSummary' of a loaded module given its 'FilePath'
getModuleByPath :: FilePath -> Debugger ModSummary
getModuleByPath :: FilePath -> Debugger ModSummary
getModuleByPath FilePath
path = do
  -- do this everytime as the loaded modules may have changed
  lms <- Debugger [ModSummary]
forall (m :: * -> *). GhcMonad m => m [ModSummary]
getAllLoadedModules
  let matches ModSummary
ms = FilePath -> FilePath
normalise (ModSummary -> FilePath
msHsFilePath ModSummary
ms) FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` FilePath
path
  case filter matches lms of
    [ModSummary
x] -> ModSummary -> Debugger ModSummary
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
x
    [] -> do
      FilePath -> Debugger ModSummary
forall a. HasCallStack => FilePath -> a
error (FilePath -> Debugger ModSummary)
-> FilePath -> Debugger ModSummary
forall a b. (a -> b) -> a -> b
$ FilePath
"No Module matched " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".\nLoaded modules:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((ModSummary -> FilePath) -> [ModSummary] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> FilePath
msHsFilePath [ModSummary]
lms)
    [ModSummary]
xs -> FilePath -> Debugger ModSummary
forall a. HasCallStack => FilePath -> a
error (FilePath -> Debugger ModSummary)
-> FilePath -> Debugger ModSummary
forall a b. (a -> b) -> a -> b
$ FilePath
"Too many modules (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [ModSummary] -> FilePath
forall a. Outputable a => a -> FilePath
showPprUnsafe [ModSummary]
xs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") matched " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path

--------------------------------------------------------------------------------
-- Variable references
--------------------------------------------------------------------------------

-- | Find a variable's associated Term and Name by reference ('Int')
lookupVarByReference :: Int -> Debugger (Maybe (Name, Term))
lookupVarByReference :: Int -> Debugger (Maybe (Name, Term))
lookupVarByReference Int
i = do
  ioref <- (DebuggerState -> IORef (IntMap (Name, Term)))
-> Debugger (IORef (IntMap (Name, Term)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (IntMap (Name, Term))
varReferences
  rm <- readIORef ioref & liftIO
  return $ IM.lookup i rm

-- | Inserts a mapping from the given variable reference to the variable's
-- associated Term and the Name it is bound to for display
insertVarReference :: Int -> Name -> Term -> Debugger ()
insertVarReference :: Int -> Name -> Term -> Debugger ()
insertVarReference Int
i Name
name Term
term = do
  ioref <- (DebuggerState -> IORef (IntMap (Name, Term)))
-> Debugger (IORef (IntMap (Name, Term)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (IntMap (Name, Term))
varReferences
  rm <- readIORef ioref & liftIO
  let
    rm' = Int -> (Name, Term) -> IntMap (Name, Term) -> IntMap (Name, Term)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i (Name
name, Term
term) IntMap (Name, Term)
rm
  writeIORef ioref rm' & liftIO

--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------

-- | Evaluate a suspended Term to WHNF.
--
-- Used in @'getVariables'@ to reply to a variable introspection request.
seqTerm :: Term -> Debugger Term
seqTerm :: Term -> Debugger Term
seqTerm Term
term = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  let
    interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
    unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
  case term of
    Suspension{ForeignHValue
val :: ForeignHValue
val :: Term -> ForeignHValue
val, RttiType
ty :: RttiType
ty :: Term -> RttiType
ty} -> IO Term -> Debugger Term
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> Debugger Term) -> IO Term -> Debugger Term
forall a b. (a -> b) -> a -> b
$ do
      r <- Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
GHCi.seqHValue Interp
interp UnitEnv
unit_env ForeignHValue
val
      () <- fromEvalResult r
      let
        deepForce
          -- fully evaluate strings because displaying them as linked lists is too noisy and not particularly useful
          = RttiType -> Bool
isStringTy RttiType
ty
        forceDepth
          | Bool
deepForce = Int
50
          | Bool
otherwise = Int
5
      cvObtainTerm hsc_env forceDepth deepForce ty val
    -- TODO: Newtype, etc
    Term
_ -> Term -> Debugger Term
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term

-- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.
--
-- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.
continueToCompletion :: Debugger GHC.ExecResult
continueToCompletion :: Debugger ExecResult
continueToCompletion = do
  execr <- SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
GHC.resumeExec SingleStep
GHC.RunToCompletion Maybe Int
forall a. Maybe a
Nothing
  case execr of
    GHC.ExecBreak{} -> Debugger ExecResult
continueToCompletion
    GHC.ExecComplete{} -> ExecResult -> Debugger ExecResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ExecResult
execr

-- | Turn a 'BreakpointStatus' into its 'Int' representation for 'BreakArray'
breakpointStatusInt :: BreakpointStatus -> Int
breakpointStatusInt :: BreakpointStatus -> Int
breakpointStatusInt = \case
  BreakpointStatus
BreakpointEnabled      -> Int
BA.breakOn  -- 0
  BreakpointStatus
BreakpointDisabled     -> Int
BA.breakOff -- -1
  BreakpointAfterCount Int
n -> Int
n           -- n

-- | Generate a new unique 'Int'
freshInt :: Debugger Int
freshInt :: Debugger Int
freshInt = do
  ioref <- (DebuggerState -> IORef Int) -> Debugger (IORef Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef Int
genUniq
  i <- readIORef ioref & liftIO
  let !i' = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
  writeIORef ioref i'  & liftIO
  return i

-- | Initialize a 'DebuggerState'
initialDebuggerState :: GHC.Ghc DebuggerState
initialDebuggerState :: Ghc DebuggerState
initialDebuggerState = IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
-> IORef (IntMap (Name, Term)) -> IORef Int -> DebuggerState
DebuggerState (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
 -> IORef (IntMap (Name, Term)) -> IORef Int -> DebuggerState)
-> Ghc
     (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> Ghc (IORef (IntMap (Name, Term)) -> IORef Int -> DebuggerState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> Ghc
     (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
-> IO
     (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
forall a. a -> IO (IORef a)
newIORef ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))
forall a. ModuleEnv a
emptyModuleEnv)
                                     Ghc (IORef (IntMap (Name, Term)) -> IORef Int -> DebuggerState)
-> Ghc (IORef (IntMap (Name, Term)))
-> Ghc (IORef Int -> DebuggerState)
forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (IORef (IntMap (Name, Term)))
-> Ghc (IORef (IntMap (Name, Term)))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IntMap (Name, Term) -> IO (IORef (IntMap (Name, Term)))
forall a. a -> IO (IORef a)
newIORef IntMap (Name, Term)
forall a. IntMap a
IM.empty)
                                     Ghc (IORef Int -> DebuggerState)
-> Ghc (IORef Int) -> Ghc DebuggerState
forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (IORef Int) -> Ghc (IORef Int)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)

-- | Lift a 'Ghc' action into a 'Debugger' one.
liftGhc :: GHC.Ghc a -> Debugger a
liftGhc :: forall a. Ghc a -> Debugger a
liftGhc = ReaderT DebuggerState Ghc a -> Debugger a
forall a. ReaderT DebuggerState Ghc a -> Debugger a
Debugger (ReaderT DebuggerState Ghc a -> Debugger a)
-> (Ghc a -> ReaderT DebuggerState Ghc a) -> Ghc a -> Debugger a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebuggerState -> Ghc a) -> ReaderT DebuggerState Ghc a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((DebuggerState -> Ghc a) -> ReaderT DebuggerState Ghc a)
-> (Ghc a -> DebuggerState -> Ghc a)
-> Ghc a
-> ReaderT DebuggerState Ghc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ghc a -> DebuggerState -> Ghc a
forall a b. a -> b -> a
const

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

instance GHC.HasLogger Debugger where
  getLogger :: Debugger Logger
getLogger = Ghc Logger -> Debugger Logger
forall a. Ghc a -> Debugger a
liftGhc Ghc Logger
forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger

instance GHC.GhcMonad Debugger where
  getSession :: Debugger HscEnv
getSession = Ghc HscEnv -> Debugger HscEnv
forall a. Ghc a -> Debugger a
liftGhc Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  setSession :: HscEnv -> Debugger ()
setSession HscEnv
s = Ghc () -> Debugger ()
forall a. Ghc a -> Debugger a
liftGhc (Ghc () -> Debugger ()) -> Ghc () -> Debugger ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
GHC.setSession HscEnv
s