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

import Prelude hiding (mod)
import Data.Function
import qualified Data.Foldable as Foldable
import System.Exit
import System.IO
import System.FilePath (normalise)
import System.Directory (makeAbsolute)
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.Unit.Module.ModSummary as GHC
import GHC.Utils.Outputable 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.Driver.Env

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

import Control.Monad.Reader

import GHC.Debugger.Interface.Messages
import GHC.Debugger.Runtime.Term.Key
import GHC.Debugger.Runtime.Term.Cache
import GHC.Debugger.Session
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.
 (?callStack::CallStack, Exception e) =>
 e -> Debugger a)
-> MonadThrow Debugger
forall e a. (?callStack::CallStack, Exception e) => e -> Debugger a
forall (m :: * -> *).
Monad m =>
(forall e a. (?callStack::CallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (?callStack::CallStack, Exception e) => e -> Debugger a
throwM :: forall e a. (?callStack::CallStack, Exception e) => e -> Debugger a
MonadThrow, MonadThrow Debugger
MonadThrow Debugger =>
(forall e a.
 (?callStack::CallStack, Exception e) =>
 Debugger a -> (e -> Debugger a) -> Debugger a)
-> MonadCatch Debugger
forall e a.
(?callStack::CallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (?callStack::CallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(?callStack::CallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
catch :: forall e a.
(?callStack::CallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
MonadCatch, MonadCatch Debugger
MonadCatch Debugger =>
(forall b.
 (?callStack::CallStack) =>
 ((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b)
-> (forall b.
    (?callStack::CallStack) =>
    ((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b)
-> (forall a b c.
    (?callStack::CallStack) =>
    Debugger a
    -> (a -> ExitCase b -> Debugger c)
    -> (a -> Debugger b)
    -> Debugger (b, c))
-> MonadMask Debugger
forall b.
(?callStack::CallStack) =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
forall a b c.
(?callStack::CallStack) =>
Debugger a
-> (a -> ExitCase b -> Debugger c)
-> (a -> Debugger b)
-> Debugger (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b.
 (?callStack::CallStack) =>
 ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    (?callStack::CallStack) =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    (?callStack::CallStack) =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
(?callStack::CallStack) =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
mask :: forall b.
(?callStack::CallStack) =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
$cuninterruptibleMask :: forall b.
(?callStack::CallStack) =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
uninterruptibleMask :: forall b.
(?callStack::CallStack) =>
((forall a. Debugger a -> Debugger a) -> Debugger b) -> Debugger b
$cgeneralBracket :: forall a b c.
(?callStack::CallStack) =>
Debugger a
-> (a -> ExitCase b -> Debugger c)
-> (a -> Debugger b)
-> Debugger (b, c)
generalBracket :: forall a b c.
(?callStack::CallStack) =>
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 TermKey, TermKeyMap Int)
varReferences     :: IORef (IM.IntMap TermKey, TermKeyMap Int)
      -- ^ 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.
      --
      -- The TermKeyMap map is a reverse lookup map to find which references
      -- already exist for given names

      , DebuggerState -> IORef TermCache
termCache         :: IORef TermCache
      -- ^ TermCache

      , 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   -- ^ Cradle root directory
            -> FilePath   -- ^ Component root directory
            -> 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)
            -> FilePath   -- ^ Path to the main function
            -> 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
-> [FilePath]
-> [FilePath]
-> FilePath
-> RunDebuggerSettings
-> Debugger a
-> IO a
runDebugger Handle
dbg_out FilePath
rootDir FilePath
compDir FilePath
libdir [FilePath]
units [FilePath]
ghcInvocation' FilePath
mainFp 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)

    -- TODO: this is weird, we set the session dynflags now to initialise
    -- the hsc_interp.
    -- This is incredibly dubious
    _ <- GHC.setSessionDynFlags dflags1

    -- Initialise plugins here because the plugin author might already expect this
    -- subsequent call to `getLogger` to be affected by a plugin.
    GHC.initializeSessionPlugins

    flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir
    setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)

    dflags6 <- GHC.getSessionDynFlags

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

    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.IIModule . GHC.ms_mod) 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
      mms <- FilePath -> Debugger (Either FilePath ModSummary)
getModuleByPath FilePath
file
      case mms of
        Right ModSummary
ms ->
          [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
            , Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms
            , Int
bix <- IntMap (BreakpointStatus, BreakpointKind) -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap (BreakpointStatus, BreakpointKind)
im
            -- assert: status is always > disabled
            ]
        Left FilePath
e -> do
          [FilePath] -> Debugger ()
displayWarnings [FilePath
e]
          [BreakpointId] -> Debugger [BreakpointId]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    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. (?callStack::CallStack) => 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 (Either String ModSummary)
getModuleByPath :: FilePath -> Debugger (Either FilePath ModSummary)
getModuleByPath FilePath
path = do
  -- do this every time as the loaded modules may have changed
  lms <- Debugger [ModSummary]
forall (m :: * -> *). GhcMonad m => m [ModSummary]
getAllLoadedModules
  absPath <- liftIO $ makeAbsolute path
  let matches ModSummary
ms = FilePath -> FilePath
normalise (ModSummary -> FilePath
msHsFilePath ModSummary
ms) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath
normalise FilePath
absPath
  return $ case filter matches lms of
    [ModSummary
x] -> ModSummary -> Either FilePath ModSummary
forall a b. b -> Either a b
Right ModSummary
x
    [] -> FilePath -> Either FilePath ModSummary
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ModSummary)
-> FilePath -> Either FilePath 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) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n. Perhaps you've set a breakpoint on a module that isn't loaded into the session?"
    [ModSummary]
xs -> FilePath -> Either FilePath ModSummary
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ModSummary)
-> FilePath -> Either FilePath 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 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Please report a bug at https://github.com/well-typed/ghc-debugger."

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

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

-- | Finds or creates an integer var reference for the given 'TermKey'.
-- TODO: Arguably, this mapping should be part of the debug-adapter, and
-- ghc-debugger should deal in 'TermKey' terms only.
getVarReference :: TermKey -> Debugger Int
getVarReference :: TermKey -> Debugger Int
getVarReference TermKey
key = do
  ioref     <- (DebuggerState -> IORef (IntMap TermKey, TermKeyMap Int))
-> Debugger (IORef (IntMap TermKey, TermKeyMap Int))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (IntMap TermKey, TermKeyMap Int)
varReferences
  (rm, tkm) <- readIORef ioref & liftIO
  (i, tkm') <- case lookupTermKeyMap key tkm of
    Maybe Int
Nothing -> do
      new_i <- Debugger Int
freshInt
      return (new_i, insertTermKeyMap key new_i tkm)
    Just Int
existing_i ->
      (Int, TermKeyMap Int) -> Debugger (Int, TermKeyMap Int)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
existing_i, TermKeyMap Int
tkm)
  let rm' = Int -> TermKey -> IntMap TermKey -> IntMap TermKey
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i TermKey
key IntMap TermKey
rm
  writeIORef ioref (rm', tkm') & liftIO
  return i

-- | Whenever we run a request that continues execution from the current
-- suspended state, such as Next,Step,Continue, this function should be called
-- to delete the variable references that become invalid as we leave the
-- suspended state.
--
-- In particular, @'varReferences'@ is reset.
--
-- See also section "Lifetime of Objects References" in the DAP specification.
leaveSuspendedState :: Debugger ()
leaveSuspendedState :: Debugger ()
leaveSuspendedState = do
  ioref <- (DebuggerState -> IORef (IntMap TermKey, TermKeyMap Int))
-> Debugger (IORef (IntMap TermKey, TermKeyMap Int))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (IntMap TermKey, TermKeyMap Int)
varReferences
  liftIO $ writeIORef ioref mempty

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

defaultDepth :: Int
defaultDepth :: Int
defaultDepth =  Int
2 -- the depth determines how much of the runtime structure is traversed.
                  -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures
                  -- so we only depth enough to get to the next level of subterms.

-- | 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
        forceThunks = Bool
False {- whether to force the thunk subterms -}
        forceDepth  = Int
defaultDepth
      cvObtainTerm hsc_env forceDepth forceThunks ty val
    NewtypeWrap{Term
wrapped_term :: Term
wrapped_term :: Term -> Term
wrapped_term} -> do
      wrapped_term' <- Term -> Debugger Term
seqTerm Term
wrapped_term
      return term{wrapped_term=wrapped_term'}
    Term
_ -> Term -> Debugger Term
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term

-- | Evaluate a Term to NF
deepseqTerm :: Term -> Debugger Term
deepseqTerm :: Term -> Debugger Term
deepseqTerm Term
t = case Term
t of
  Suspension{}   -> do t' <- Term -> Debugger Term
seqTerm Term
t
                       deepseqTerm t'
  Term{[Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms} -> do subTerms' <- (Term -> Debugger Term) -> [Term] -> Debugger [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> Debugger Term
deepseqTerm [Term]
subTerms
                       return t{subTerms = subTerms'}
  NewtypeWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term}
                 -> do wrapped_term' <- Term -> Debugger Term
deepseqTerm Term
wrapped_term
                       return t{wrapped_term = wrapped_term'}
  Term
_              -> do Term -> Debugger Term
seqTerm Term
t


-- | 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 TermKey, TermKeyMap Int)
-> IORef TermCache
-> IORef Int
-> DebuggerState
DebuggerState (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind)))
 -> IORef (IntMap TermKey, TermKeyMap Int)
 -> IORef TermCache
 -> IORef Int
 -> DebuggerState)
-> Ghc
     (IORef (ModuleEnv (IntMap (BreakpointStatus, BreakpointKind))))
-> Ghc
     (IORef (IntMap TermKey, TermKeyMap Int)
      -> IORef TermCache -> 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 TermKey, TermKeyMap Int)
   -> IORef TermCache -> IORef Int -> DebuggerState)
-> Ghc (IORef (IntMap TermKey, TermKeyMap Int))
-> Ghc (IORef TermCache -> 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 TermKey, TermKeyMap Int))
-> Ghc (IORef (IntMap TermKey, TermKeyMap Int))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IntMap TermKey, TermKeyMap Int)
-> IO (IORef (IntMap TermKey, TermKeyMap Int))
forall a. a -> IO (IORef a)
newIORef (IntMap TermKey, TermKeyMap Int)
forall a. Monoid a => a
mempty)
                                     Ghc (IORef TermCache -> IORef Int -> DebuggerState)
-> Ghc (IORef TermCache) -> 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 TermCache) -> Ghc (IORef TermCache)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TermCache -> IO (IORef TermCache)
forall a. a -> IO (IORef a)
newIORef TermCache
forall a. Monoid a => a
mempty)
                                     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

--------------------------------------------------------------------------------

type Warning = String

displayWarnings :: [Warning] -> Debugger ()
displayWarnings :: [FilePath] -> Debugger ()
displayWarnings = IO () -> Debugger ()
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Debugger ())
-> ([FilePath] -> IO ()) -> [FilePath] -> Debugger ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
putStrLn (FilePath -> IO ())
-> ([FilePath] -> FilePath) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines

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