{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultilineStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NondecreasingIndentation #-}

module GHC.Debugger.Monad where

import Control.Concurrent
import Control.Exception
import qualified Data.Foldable as Foldable
import Control.Monad
import Control.Monad.Catch as MC
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Function
import Data.IORef
import Data.Maybe
import qualified Data.Set as Set
import Data.Version (makeVersion, showVersion)
import Prelude hiding (mod)
#ifdef MIN_VERSION_unix
import System.Posix.Signals
#endif
import qualified Data.List as L
import qualified Data.List.NonEmpty as NonEmpty
import qualified GHC.Conc.Sync as C

import GHC
import GHC.Data.StringBuffer
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Logger
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Env as GHC
import GHC.Driver.Monad
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Ppr
import GHC.Driver.Session (parseDynamicFlagsCmdLine)
import GHC.Runtime.Eval
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Loader as GHC
import GHC.Runtime.Context as GHCi
import GHC.Types.Error
import GHC.Types.SourceError
import GHC.Unit.Module.Graph
import GHC.Unit.State
import GHC.Unit.Types
import qualified GHC.Utils.Logger as GHC
import GHC.Utils.Outputable as GHC
import qualified GHC.LanguageExtensions as LangExt

import GHC.Debugger.Interface.Messages
import GHC.Debugger.Session
import GHC.Debugger.Session.Builtin
import GHC.Debugger.Session.Interactive
import GHC.Debugger.Runtime.Compile.Cache
import qualified GHC.Debugger.Breakpoint.Map as BM
import qualified GHC.Debugger.Runtime.Thread.Map as TM

import Colog.Core as Logger

import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)
import GHC.Stack.Annotation
import GHC.Platform.Ways
import GHC.Unit.Home.Graph
import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`
import System.Directory (getCurrentDirectory)
import GHC.Debugger.Debuggee
import GHC.Plugins (HasCallStack)
import Data.Bifunctor
import qualified GHC.Unit.Module.Graph as GHC

-- | 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)
-> (forall e a.
    Exception e =>
    ExceptionWithContext e -> Debugger a)
-> MonadThrow Debugger
forall e a. (HasCallStack, Exception e) => e -> Debugger a
forall e a. Exception e => ExceptionWithContext e -> Debugger a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> (forall e a. Exception e => ExceptionWithContext 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
$crethrowM :: forall e a. Exception e => ExceptionWithContext e -> Debugger a
rethrowM :: forall e a. Exception e => ExceptionWithContext e -> Debugger a
MonadThrow, MonadThrow Debugger
MonadThrow Debugger =>
(forall e a.
 (HasCallStack, Exception e) =>
 Debugger a -> (e -> Debugger a) -> Debugger a)
-> (forall e a.
    Exception e =>
    Debugger a -> (ExceptionWithContext e -> Debugger a) -> Debugger a)
-> MonadCatch Debugger
forall e a.
(HasCallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
forall e a.
Exception e =>
Debugger a -> (ExceptionWithContext e -> Debugger a) -> Debugger a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> (forall e a.
    Exception e =>
    m a -> (ExceptionWithContext 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
$ccatchNoPropagate :: forall e a.
Exception e =>
Debugger a -> (ExceptionWithContext e -> Debugger a) -> Debugger a
catchNoPropagate :: forall e a.
Exception e =>
Debugger a -> (ExceptionWithContext 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 )

data BreakpointInfo = BreakpointInfo
  { BreakpointInfo -> BreakpointStatus
bpInfoStatus :: !BreakpointStatus
  , BreakpointInfo -> BreakpointKind
bpInfoKind   :: !BreakpointKind
  , BreakpointInfo -> BreakpointAction
bpInfoAction :: !BreakpointAction
  }
  deriving (BreakpointInfo -> BreakpointInfo -> Bool
(BreakpointInfo -> BreakpointInfo -> Bool)
-> (BreakpointInfo -> BreakpointInfo -> Bool) -> Eq BreakpointInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BreakpointInfo -> BreakpointInfo -> Bool
== :: BreakpointInfo -> BreakpointInfo -> Bool
$c/= :: BreakpointInfo -> BreakpointInfo -> Bool
/= :: BreakpointInfo -> BreakpointInfo -> Bool
Eq,Int -> BreakpointInfo -> ShowS
[BreakpointInfo] -> ShowS
BreakpointInfo -> String
(Int -> BreakpointInfo -> ShowS)
-> (BreakpointInfo -> String)
-> ([BreakpointInfo] -> ShowS)
-> Show BreakpointInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BreakpointInfo -> ShowS
showsPrec :: Int -> BreakpointInfo -> ShowS
$cshow :: BreakpointInfo -> String
show :: BreakpointInfo -> String
$cshowList :: [BreakpointInfo] -> ShowS
showList :: [BreakpointInfo] -> ShowS
Show)

-- | State required to run the debugger.
--
-- - Keep track of active breakpoints to easily unset them all.
data DebuggerState = DebuggerState
      { DebuggerState -> IORef (BreakpointMap BreakpointInfo)
activeBreakpoints :: IORef (BM.BreakpointMap BreakpointInfo)
        -- ^ Maps a 'InternalBreakpointId' in Trie representation (map of Module to map of Int) to the
        -- 'BreakpointStatus' it was activated with.

      , DebuggerState -> IORef RuntimeInstancesCache
rtinstancesCache  :: IORef RuntimeInstancesCache
      -- ^ RuntimeInstancesCache

      , DebuggerState -> IORef ThreadMap
threadMap         :: IORef TM.ThreadMap
      -- ^ 'ThreadMap' for threads spawned by the debuggee

      , DebuggerState -> IORef CompCache
compCache         :: IORef CompCache
      -- ^ Cache loaded and compiled expressions.

      , DebuggerState -> Maybe UnitId
hsDbgViewUnitId   :: Maybe UnitId
      -- ^ The unit-id of the companion @haskell-debugger-view@ unit, used for
      -- user-defined and built-in custom debug visualisations of values (e.g.
      -- for Strings or IntMap).
      --
      -- If the user depends on @haskell-debugger-view@ in its transitive
      -- closure, then we should use that exact unit which was solved by Cabal.
      -- The built-in instances and additional instances be available for the
      -- 'DebugView' class found in that unit. We can find the exact unit of
      -- the module by looking for @haskell-debugger-view@ in the module graph.
      --
      -- If the user does not depend on @haskell-debugger-view@ in any way,
      -- then we create our own unit and try to load the
      -- @haskell-debugger-view@ modules directly into it. As long as loading
      -- succeeds, the 'DebugView' class from this custom unit can be used to
      -- find the built-in instances for types like @'String'@
      --
      -- If the user explicitly disabled custom views, use @Nothing@.

      , DebuggerState -> LogAction Debugger DebuggerLog
dbgLogger :: LogAction Debugger DebuggerLog
      -- ^ See Note [Debugger, debuggee, and DAP logs]
      }

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

-- | 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
      -- | Breakpoint is enabled when condition evaluates to true
      | BreakpointWhenCond String
      -- | Breakpoint is disabled the first N times the condition evaluates to
      -- true and enabled in the next time it is true
      | BreakpointAfterCountCond Int String
      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, Int -> BreakpointStatus -> ShowS
[BreakpointStatus] -> ShowS
BreakpointStatus -> String
(Int -> BreakpointStatus -> ShowS)
-> (BreakpointStatus -> String)
-> ([BreakpointStatus] -> ShowS)
-> Show BreakpointStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BreakpointStatus -> ShowS
showsPrec :: Int -> BreakpointStatus -> ShowS
$cshow :: BreakpointStatus -> String
show :: BreakpointStatus -> String
$cshowList :: [BreakpointStatus] -> ShowS
showList :: [BreakpointStatus] -> ShowS
Show)

instance Outputable BreakpointStatus where ppr :: BreakpointStatus -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (BreakpointStatus -> String) -> BreakpointStatus -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BreakpointStatus -> String
forall a. Show a => a -> String
show

-- | What to do when a breakpoint is enabled
data BreakpointAction
      -- | Evaluation is stopped, typical behaviour
      = BreakpointStop
      {- | A log message is printed and then evaluation resumes.
        The @String@ is an expression that takes care of interpolation and printing the log message.
      -}
      | BreakpointLogAndResume String
      deriving (BreakpointAction -> BreakpointAction -> Bool
(BreakpointAction -> BreakpointAction -> Bool)
-> (BreakpointAction -> BreakpointAction -> Bool)
-> Eq BreakpointAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BreakpointAction -> BreakpointAction -> Bool
== :: BreakpointAction -> BreakpointAction -> Bool
$c/= :: BreakpointAction -> BreakpointAction -> Bool
/= :: BreakpointAction -> BreakpointAction -> Bool
Eq, Eq BreakpointAction
Eq BreakpointAction =>
(BreakpointAction -> BreakpointAction -> Ordering)
-> (BreakpointAction -> BreakpointAction -> Bool)
-> (BreakpointAction -> BreakpointAction -> Bool)
-> (BreakpointAction -> BreakpointAction -> Bool)
-> (BreakpointAction -> BreakpointAction -> Bool)
-> (BreakpointAction -> BreakpointAction -> BreakpointAction)
-> (BreakpointAction -> BreakpointAction -> BreakpointAction)
-> Ord BreakpointAction
BreakpointAction -> BreakpointAction -> Bool
BreakpointAction -> BreakpointAction -> Ordering
BreakpointAction -> BreakpointAction -> BreakpointAction
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 :: BreakpointAction -> BreakpointAction -> Ordering
compare :: BreakpointAction -> BreakpointAction -> Ordering
$c< :: BreakpointAction -> BreakpointAction -> Bool
< :: BreakpointAction -> BreakpointAction -> Bool
$c<= :: BreakpointAction -> BreakpointAction -> Bool
<= :: BreakpointAction -> BreakpointAction -> Bool
$c> :: BreakpointAction -> BreakpointAction -> Bool
> :: BreakpointAction -> BreakpointAction -> Bool
$c>= :: BreakpointAction -> BreakpointAction -> Bool
>= :: BreakpointAction -> BreakpointAction -> Bool
$cmax :: BreakpointAction -> BreakpointAction -> BreakpointAction
max :: BreakpointAction -> BreakpointAction -> BreakpointAction
$cmin :: BreakpointAction -> BreakpointAction -> BreakpointAction
min :: BreakpointAction -> BreakpointAction -> BreakpointAction
Ord, Int -> BreakpointAction -> ShowS
[BreakpointAction] -> ShowS
BreakpointAction -> String
(Int -> BreakpointAction -> ShowS)
-> (BreakpointAction -> String)
-> ([BreakpointAction] -> ShowS)
-> Show BreakpointAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BreakpointAction -> ShowS
showsPrec :: Int -> BreakpointAction -> ShowS
$cshow :: BreakpointAction -> String
show :: BreakpointAction -> String
$cshowList :: [BreakpointAction] -> ShowS
showList :: [BreakpointAction] -> ShowS
Show)

instance Outputable BreakpointAction where ppr :: BreakpointAction -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (BreakpointAction -> String) -> BreakpointAction -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BreakpointAction -> String
forall a. Show a => a -> String
show

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

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

-- | Run a 'Debugger' action on a session constructed by a 'DebugRunner'
--
--  INVARIANT: The initUniqSupply has already been initialized.
--
--  Users of hdb-as-a-library will have to call `initUniqSupply` at their leisure,
--  special care needed if they supply any loaded units/modules to us via the DebugRunner,
--  as those will contain `Unique`s.
--
--  See Note [UniqueSupply is process global].
runDebugger :: LogAction IO DebuggerLog -> DebugRunner Ghc a -> RunDebuggerSettings -> Debugger a -> IO a
runDebugger :: forall a.
LogAction IO DebuggerLog
-> DebugRunner Ghc a -> RunDebuggerSettings -> Debugger a -> IO a
runDebugger LogAction IO DebuggerLog
l DebugRunner Ghc a
debugRunner RunDebuggerSettings
conf Debugger a
action = IO a -> IO a
forall a. HasCallStack => IO a -> IO a
annotateCallStackIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  DebugRunner Ghc a
debugRunner DebugRunner Ghc a -> DebugRunner Ghc a
forall a b. (a -> b) -> a -> b
$ \ String
rootDir [String]
extraGhcArgs Ghc ()
loadHomeUnit -> LogAction IO DebuggerLog
-> String
-> [String]
-> RunDebuggerSettings
-> Ghc ()
-> Debugger a
-> Ghc a
forall a.
LogAction IO DebuggerLog
-> String
-> [String]
-> RunDebuggerSettings
-> Ghc ()
-> Debugger a
-> Ghc a
runDebuggerAction LogAction IO DebuggerLog
l String
rootDir [String]
extraGhcArgs RunDebuggerSettings
conf Ghc ()
loadHomeUnit Debugger a
action

type DebugSession m a
  =  FilePath -- ^ project root dir
  -> [String] -- ^ extra ghc args
  -> m ()   -- ^ action to load debugee home units
  -> Ghc a

type DebugRunner m a = DebugSession m a -> IO a

data ProjectDebugSpec = ProjectDebugSpec
      { ProjectDebugSpec -> String
rootDir :: FilePath
      -- ^ Project root directory
      , ProjectDebugSpec -> String
componentDir :: FilePath
      -- ^ Root dir of the loaded 'ComponentOptions'.
      -- Important for multi-package cabal projects, as packages are not in the
      -- root of the cradle, but in some sub-directory.
      , ProjectDebugSpec -> String
libdir :: FilePath
        -- ^ The libdir (given with -B as an arg)
      , ProjectDebugSpec -> [String]
units :: [String]
        -- ^ The list of units included in the invocation
      , ProjectDebugSpec -> [String]
ghcInvocation :: [String]
      -- ^ The full ghc invocation (as constructed by hie-bios flags)
      , ProjectDebugSpec -> String
absEntryFile :: FilePath
      -- ^ Path to the main function
      , ProjectDebugSpec -> [String]
extraGhcArgs :: [String]
      }

-- | Construct a session from paths and flags inferred from the debugee's project.
withProjectDebugSession
  :: GhcMonad m
  => ProjectDebugSpec
  -> DebugRunner m a
withProjectDebugSession :: forall (m :: * -> *) a.
GhcMonad m =>
ProjectDebugSpec -> DebugRunner m a
withProjectDebugSession ProjectDebugSpec{ghcInvocation :: ProjectDebugSpec -> [String]
ghcInvocation = [String]
ghcI, String
[String]
rootDir :: ProjectDebugSpec -> String
componentDir :: ProjectDebugSpec -> String
libdir :: ProjectDebugSpec -> String
units :: ProjectDebugSpec -> [String]
absEntryFile :: ProjectDebugSpec -> String
extraGhcArgs :: ProjectDebugSpec -> [String]
rootDir :: String
componentDir :: String
libdir :: String
units :: [String]
absEntryFile :: String
extraGhcArgs :: [String]
..} DebugSession m a
k = do
  let ghcInvocation :: [String]
ghcInvocation = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\case (Char
'-':Char
'B':String
_) -> Bool
False; String
_ -> Bool
True) [String]
ghcI
  Maybe String -> Ghc a -> IO a
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
#ifdef MIN_VERSION_unix
  -- Workaround #4162
  -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it.
    _ <- 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
    _ <- liftIO $ installHandler sigQUIT Default Nothing
    _ <- liftIO $ installHandler sigTERM Default Nothing
    _ <- liftIO $ installHandler sigHUP Default Nothing
#endif
    k rootDir extraGhcArgs $ do
    dflags2 <- getSessionDynFlags

    -- Discover the user-given flags and targets
    flagsAndTargets <- parseHomeUnitArguments absEntryFile componentDir units ghcInvocation dflags2 rootDir


    let setVerbosity DynFlags
dflags = DynFlags
dflags {verbosity = verbosity dflags2}
    -- Setup HomeUnitGraph with debugee and interactiveGhcDebugger units
    setupHomeUnitGraph (map (first setVerbosity) $ NonEmpty.toList flagsAndTargets)

    debugee_mod_graph <- doDownsweep Nothing

    if_cache <- Just <$> liftIO newIfaceCache
    success <- doLoad if_cache GHC.LoadAllTargets debugee_mod_graph

    when (GHC.failed success) $ liftIO $
      throwM DebuggerFailedToLoad

runDebuggerAction :: forall a. LogAction IO DebuggerLog
  -> FilePath -- ^ rootDir
  -> [String] -- ^ extraGhcArgs
  -> RunDebuggerSettings
  -> Ghc () -- ^ load home units action
  -> Debugger a
  -> Ghc a
runDebuggerAction :: forall a.
LogAction IO DebuggerLog
-> String
-> [String]
-> RunDebuggerSettings
-> Ghc ()
-> Debugger a
-> Ghc a
runDebuggerAction LogAction IO DebuggerLog
l String
rootDir [String]
extraGhcArgs RunDebuggerSettings
conf Ghc ()
loadHomeUnit (Debugger ReaderT DebuggerState Ghc a
action)
  = (Ghc a -> Ghc () -> Ghc a) -> Ghc () -> Ghc a -> Ghc a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ghc a -> Ghc () -> Ghc a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
MC.finally Ghc ()
cleanupInterp (Ghc a -> Ghc a) -> Ghc a -> Ghc a
forall a b. (a -> b) -> a -> b
$
          -- See Note [Shutting down the external interpreter]
  do
  dflags0 <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let dflags1 = DynFlags
dflags0
        { GHC.ghcMode = GHC.CompManager
        , GHC.ghcLink = GHC.LinkInMemory
        , GHC.verbosity = 1
        , GHC.canUseColor = conf.supportsANSIStyling
        , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks
        }
        -- Default debugger settings
        DynFlags -> Extension -> DynFlags
`GHC.xopt_set` Extension
LangExt.TypeApplications
        DynFlags -> Extension -> DynFlags
`GHC.xopt_set` Extension
LangExt.PackageImports
        DynFlags -> Extension -> DynFlags
`GHC.xopt_set` Extension
LangExt.MagicHash -- needed for some of the expressions we compile
        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

        DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& InterpreterSettings -> DynFlags -> DynFlags
interpreterFlags RunDebuggerSettings
conf.interpreterSettings
        -- Really important to force -dynamic if host is dynamic
        -- See Note [Dynamic Debuggee for dynamic debugger]
        DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& DynFlags -> DynFlags
enableDynamicDebuggee

        DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& DynFlags -> DynFlags
setBytecodeBackend
        DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& DynFlags -> DynFlags
enableByteCodeGeneration

  GHC.modifyLogger $
    -- Override the logger to output to the given handle
    GHC.pushLogHook $ const $ ghcLogAction l

  dflags2 <- getLogger >>= \Logger
logger -> do
    -- Set the extra GHC arguments for ALL units by setting them early in
    -- dynflags. This is important to make sure unfoldings for interfaces
    -- loaded because of the built-in loaded classes (like
    -- GHC.Debugger.View.Class) behave the same as if they were loaded for
    -- the user program. Otherwise we may run into the problem which
    -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be
    -- reverted)
    (dflags2, fileish_args, warns)
      <- String
-> Logger
-> DynFlags
-> [Located String]
-> Ghc (DynFlags, [Located String], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
String
-> Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlagsWithRootDir String
rootDir Logger
logger DynFlags
dflags1 ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall e. e -> Located e
noLoc [String]
extraGhcArgs)
    liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)
    forM_ fileish_args $ \Located String
fish_arg -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
      Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
GHC.logMsg Logger
logger MessageClass
MCOutput SrcSpan
noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Ignoring extraGhcArg which isn't a recognized flag:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Located String -> String
forall l e. GenLocated l e -> e
unLoc Located String
fish_arg)
      Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags2) (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags2) (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages DriverMessage
warns)
    return dflags2

  interpreterSetup conf.interpreterSettings l dflags2 $ do
      -- Initializes interpreter!
      _ <- GHC.setSessionDynFlags dflags2

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

      preservingThreadLabel loadHomeUnit

      fixHomeUnitsDynFlagsForIIDecl


      -- Ensure all the home units are built with same Ways and return them.
      buildWays       <- do
        hug_dflags <- fmap homeUnitEnv_dflags . Foldable.toList . hsc_HUG <$> getSession
        liftIO $ validateUnitsWays $ case hug_dflags of
            [] -> String -> NonEmpty DynFlags
forall a. HasCallStack => String -> a
error String
"No units"
            (DynFlags
x:[DynFlags]
xs) -> DynFlags
x DynFlags -> [DynFlags] -> NonEmpty DynFlags
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [DynFlags]
xs

#ifndef DEBUG_WITH_GHC
      -- Find haskell-debugger-view in (deps of) home units, or load one from
      -- in-memory sources.
      (hdv_uid, loadedBuiltinModNames) <- do
        preservingThreadLabel $
          findOrLoadHaskellDebuggerView l buildWays
#else
      let hdv_uid = hsDebuggerViewInMemoryUnitId
      let loadedBuiltinModNames = [] :: [ModuleName]
#endif

#if !MIN_VERSION_ghc(9,14,2)
      loadFFIInspect l buildWays
#endif

      -- Loaded later so it can depend on FFIInspect if needed.
      loadInternal l buildWays


      -- See Note [Must explicitly expose module graph units]
      exposeModGraphUnitsInInteractiveGhcDebuggerUnit

      -- Set interactive context to import all loaded modules
      let preludeImp = ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl (ModuleName -> ImportDecl GhcPs) -> ModuleName -> ImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ String -> ModuleName
GHC.mkModuleName String
"Prelude"

      hsc_env_new <- getSession

      -- dbgView should always be available, either because we manually loaded it
      -- or because it's in the transitive closure.
      let dbgViewImps
            = (ModuleName -> ImportDecl GhcPs)
-> [ModuleName] -> [ImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (PackageQualifier -> ModuleName -> ImportDecl GhcPs
packageImportDecl PackageQualifier
hvd_pkgName) [ModuleName]
loadedBuiltinModNames
            where
              hvd_pkgName :: PackageQualifier
hvd_pkgName = PackageQualifier -> Maybe PackageQualifier -> PackageQualifier
forall a. a -> Maybe a -> a
fromMaybe (String -> PackageQualifier
forall a. HasCallStack => String -> a
error (String -> PackageQualifier) -> String -> PackageQualifier
forall a b. (a -> b) -> a -> b
$ String
"No package name for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
unitIdString UnitId
hdv_uid) (Maybe PackageQualifier -> PackageQualifier)
-> Maybe PackageQualifier -> PackageQualifier
forall a b. (a -> b) -> a -> b
$
                HscEnv -> UnitId -> Maybe PackageQualifier
lookupUnitPackageQualifier HscEnv
hsc_env_new UnitId
hdv_uid

      mss <- getAllLoadedModules

      let
        imports
          = (ImportDecl GhcPs -> InteractiveImport)
-> [ImportDecl GhcPs] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl ([ImportDecl GhcPs] -> [InteractiveImport])
-> [ImportDecl GhcPs] -> [InteractiveImport]
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
preludeImp ImportDecl GhcPs -> [ImportDecl GhcPs] -> [ImportDecl GhcPs]
forall a. a -> [a] -> [a]
:
#if MIN_VERSION_ghc(10,1,0)
            [ i { ideclImportList = Just (Exactly, []) }
            | i <- instancesOnly ]
#else
            [ ImportDecl GhcPs
i { ideclImportList = Just (Exactly, L noAnn []) }
            | ImportDecl GhcPs
i <- [ImportDecl GhcPs]
instancesOnly ]
#endif

        -- We import (only the instances of) all the home unit
        -- modules to bring any orphan DebugView instances in scope.
        instancesOnly =
            [ImportDecl GhcPs]
dbgViewImps [ImportDecl GhcPs] -> [ImportDecl GhcPs] -> [ImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++
            [ PackageQualifier -> ModuleName -> ImportDecl GhcPs
packageImportDecl PackageQualifier
pkgName (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
modl)
            | GenModule Unit
modl <- (ModuleNodeInfo -> GenModule Unit)
-> [ModuleNodeInfo] -> [GenModule Unit]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNodeInfo -> GenModule Unit
moduleNodeInfoModule [ModuleNodeInfo]
mss
            , let uid :: UnitId
uid = GenModule Unit -> UnitId
moduleUnitId GenModule Unit
modl
            , let pkgName :: PackageQualifier
pkgName = PackageQualifier -> Maybe PackageQualifier -> PackageQualifier
forall a. a -> Maybe a -> a
fromMaybe (String -> PackageQualifier
forall a. HasCallStack => String -> a
error (String -> PackageQualifier) -> String -> PackageQualifier
forall a b. (a -> b) -> a -> b
$ String
"No package name for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
unitIdString UnitId
uid) (Maybe PackageQualifier -> PackageQualifier)
-> Maybe PackageQualifier -> PackageQualifier
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitId -> Maybe PackageQualifier
lookupUnitPackageQualifier HscEnv
hsc_env_new UnitId
uid
            ]


      GHC.setContext imports

      -- See Note [External interpreter buffering]
      hscInterp <$> GHC.getSession >>= \Interp
interp -> Ghc () -> Ghc ()
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
        code <- String -> Ghc ForeignHValue
forall (m :: * -> *). GhcMonad m => String -> m ForeignHValue
compileExprRemote (String -> Ghc ForeignHValue) -> String -> Ghc ForeignHValue
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
debuggerRuntimeInternalModName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".setLineBuffering"
        liftIO $ evalIO interp code

      noPrint <- defineNoPrint
      modifySession (\HscEnv
hsc_env -> HscEnv
hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint})

      runReaderT action
        =<< initialDebuggerState (liftLogIO l)
            (if loadedBuiltinModNames == []
              then Nothing
              else Just hdv_uid)

preservingThreadLabel :: HasCallStack => Ghc a -> Ghc a
preservingThreadLabel :: forall a. HasCallStack => Ghc a -> Ghc a
preservingThreadLabel Ghc a
m = do
  thId <- IO ThreadId -> Ghc ThreadId
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Ghc ThreadId) -> IO ThreadId -> Ghc ThreadId
forall a b. (a -> b) -> a -> b
$ IO ThreadId
myThreadId
  mlbl <- liftIO $ C.threadLabel thId
  case mlbl of
    Maybe String
Nothing -> Ghc a
m
    Just String
lbl -> do
      Ghc a -> Ghc a
forall a. HasCallStack => Ghc a -> Ghc a
annotateCallStackGhc (Ghc a -> Ghc a) -> Ghc a -> Ghc a
forall a b. (a -> b) -> a -> b
$ do
        x <- Ghc a
m
        liftIO $ C.labelThread thId lbl
        pure x

-- | Throws exception when module fails to load.
loadInternal
  :: LogAction IO DebuggerLog
  -> Ways
  -> Ghc ()
loadInternal :: LogAction IO DebuggerLog -> Ways -> Ghc ()
loadInternal LogAction IO DebuggerLog
l Ways
buildWays = do
  let ghcLog :: LogAction Ghc DebuggerLog
ghcLog = LogAction IO DebuggerLog -> LogAction Ghc DebuggerLog
forall (m :: * -> *) msg.
MonadIO m =>
LogAction IO msg -> LogAction m msg
liftLogIO LogAction IO DebuggerLog
l

  dflags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  addInMemoryDebuggerInternalUnit (setDynFlagWays buildWays dflags)
  let uid = UnitId
debuggerInternalUnitId
  successes <- loadInMemoryModules l uid modsToLoad
  forM_ (zip successes modsToLoad) $ \case
    (SuccessFlag
Failed,(ModuleName
modName,StringBuffer
_)) -> do
      LogAction Ghc DebuggerLog
ghcLog LogAction Ghc DebuggerLog -> DebuggerLog -> Ghc ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug
        (ModuleName -> DebuggerMessage
LogFailedToCompileBuiltinModule ModuleName
modName)
      IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Failed to load DebuggerInternal Module"
    (SuccessFlag
Succeeded,(ModuleName, StringBuffer)
_) ->
      () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    modsToLoad :: [(ModuleName, StringBuffer)]
modsToLoad =
      [(ModuleName
debuggerRuntimeInternalModName,StringBuffer
debuggerRuntimeInternalContents)]

#if !MIN_VERSION_ghc(9,14,2)
data FailedToLoadFFIInspectModule = FailedToLoadFFIInspectModule
  deriving Int -> FailedToLoadFFIInspectModule -> ShowS
[FailedToLoadFFIInspectModule] -> ShowS
FailedToLoadFFIInspectModule -> String
(Int -> FailedToLoadFFIInspectModule -> ShowS)
-> (FailedToLoadFFIInspectModule -> String)
-> ([FailedToLoadFFIInspectModule] -> ShowS)
-> Show FailedToLoadFFIInspectModule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailedToLoadFFIInspectModule -> ShowS
showsPrec :: Int -> FailedToLoadFFIInspectModule -> ShowS
$cshow :: FailedToLoadFFIInspectModule -> String
show :: FailedToLoadFFIInspectModule -> String
$cshowList :: [FailedToLoadFFIInspectModule] -> ShowS
showList :: [FailedToLoadFFIInspectModule] -> ShowS
Show
instance Exception FailedToLoadFFIInspectModule

-- | Throws exception when module fails to load.
--   Needed for GHC.Debugger.Runtime.Interpreter.Legacy
loadFFIInspect
  :: LogAction IO DebuggerLog
  -> Ways
  -> Ghc ()
loadFFIInspect :: LogAction IO DebuggerLog -> Ways -> Ghc ()
loadFFIInspect LogAction IO DebuggerLog
l Ways
buildWays = do
  let ghcLog :: LogAction Ghc DebuggerLog
ghcLog = LogAction IO DebuggerLog -> LogAction Ghc DebuggerLog
forall (m :: * -> *) msg.
MonadIO m =>
LogAction IO msg -> LogAction m msg
liftLogIO LogAction IO DebuggerLog
l

  dflags <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  uid <- addInMemoryFFIInspectUnit [baseUnitId dflags] (setDynFlagWays buildWays dflags)

  successes <- loadInMemoryModules l uid modsToLoad
  forM_ (zip successes modsToLoad) $ \case
    (SuccessFlag
Failed,(ModuleName
modName,StringBuffer
_)) -> do
      LogAction Ghc DebuggerLog
ghcLog LogAction Ghc DebuggerLog -> DebuggerLog -> Ghc ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug
        (ModuleName -> DebuggerMessage
LogFailedToCompileBuiltinModule ModuleName
modName)
      IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FailedToLoadFFIInspectModule -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO FailedToLoadFFIInspectModule
FailedToLoadFFIInspectModule
    (SuccessFlag
Succeeded,(ModuleName, StringBuffer)
_) ->
      () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    modsToLoad :: [(ModuleName, StringBuffer)]
modsToLoad =
      [(ModuleName
debuggerRuntimeFFIInspectModName,StringBuffer
debuggerRuntimeFFIInspectContents)]
#endif

findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog
             -> Ways
             -> Ghc (UnitId, [ModuleName])
findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog -> Ways -> Ghc (UnitId, [ModuleName])
findOrLoadHaskellDebuggerView LogAction IO DebuggerLog
l Ways
buildWays = do
  let ghcLog :: LogAction Ghc DebuggerLog
ghcLog = LogAction IO DebuggerLog -> LogAction Ghc DebuggerLog
forall (m :: * -> *) msg.
MonadIO m =>
LogAction IO msg -> LogAction m msg
liftLogIO LogAction IO DebuggerLog
l
  hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

  -- Try to find or load the built-in classes from `haskell-debugger-view`
  findHsDebuggerViewUnitId >>= \case
    Maybe UnitId
Nothing -> (UnitId
hsDebuggerViewInMemoryUnitId,) ([ModuleName] -> (UnitId, [ModuleName]))
-> Ghc [ModuleName] -> Ghc (UnitId, [ModuleName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      -- Not imported by any module: no custom views. Therefore, the builtin
      -- ones haven't been loaded. In this case, we will load the package ourselves.

      -- Add the custom unit to the HUG
      let base_dep_uids :: [UnitId]
base_dep_uids = HscEnv -> [UnitId]
graphsUnits HscEnv
hsc_env
      [UnitId] -> DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => [UnitId] -> DynFlags -> m ()
addInMemoryHsDebuggerViewUnit [UnitId]
base_dep_uids (DynFlags -> Ghc ())
-> (DynFlags -> DynFlags) -> DynFlags -> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ways -> DynFlags -> DynFlags
setDynFlagWays Ways
buildWays (DynFlags -> Ghc ()) -> Ghc DynFlags -> Ghc ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

      -- Load unit modules using in-memory contents.
      let
        -- Don't try to load instances whose packages are not even in the
        -- module graph.
        ([(ModuleName, StringBuffer, String)]
instanceMods,[(ModuleName, StringBuffer, String)]
skipped) = ((ModuleName, StringBuffer, String) -> Bool)
-> [(ModuleName, StringBuffer, String)]
-> ([(ModuleName, StringBuffer, String)],
    [(ModuleName, StringBuffer, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\ (ModuleName
_modName,StringBuffer
_modContent,String
pkgName) -> (UnitId -> Bool) -> [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
pkgName String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf`) (String -> Bool) -> (UnitId -> String) -> UnitId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> String
unitIdString) [UnitId]
base_dep_uids)
            [(ModuleName, StringBuffer, String)]
debuggerViewInstancesMods
        modsToLoad :: [(ModuleName, StringBuffer)]
modsToLoad =
          (ModuleName
debuggerViewClassModName,StringBuffer
debuggerViewClassContents)
          (ModuleName, StringBuffer)
-> [(ModuleName, StringBuffer)] -> [(ModuleName, StringBuffer)]
forall a. a -> [a] -> [a]
: [ (ModuleName
modName,StringBuffer
modContent)
            | (ModuleName
modName, StringBuffer
modContent, String
_pkgName) <- [(ModuleName, StringBuffer, String)]
instanceMods]

      [(ModuleName, StringBuffer, String)]
-> ((ModuleName, StringBuffer, String) -> Ghc ()) -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ModuleName, StringBuffer, String)]
skipped (((ModuleName, StringBuffer, String) -> Ghc ()) -> Ghc ())
-> ((ModuleName, StringBuffer, String) -> Ghc ()) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \(ModuleName
modName,StringBuffer
_,String
pkgName) ->
        LogAction Ghc DebuggerLog
ghcLog LogAction Ghc DebuggerLog -> DebuggerLog -> Ghc ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug
          (ModuleName -> String -> [String] -> DebuggerMessage
LogSkippingViewModuleNoPkg ModuleName
modName String
pkgName ((UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
unitIdString [UnitId]
base_dep_uids))

      successes <- LogAction IO DebuggerLog
-> UnitId -> [(ModuleName, StringBuffer)] -> Ghc [SuccessFlag]
loadInMemoryModules LogAction IO DebuggerLog
l UnitId
hsDebuggerViewInMemoryUnitId [(ModuleName, StringBuffer)]
modsToLoad

      fmap catMaybes . forM (zip successes modsToLoad) $ \case
        (SuccessFlag
Failed,(ModuleName
modName,StringBuffer
_)) -> do
          LogAction Ghc DebuggerLog
ghcLog LogAction Ghc DebuggerLog -> DebuggerLog -> Ghc ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug
            (ModuleName -> DebuggerMessage
LogFailedToCompileBuiltinModule ModuleName
modName)
          Maybe ModuleName -> Ghc (Maybe ModuleName)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModuleName -> Ghc (Maybe ModuleName))
-> Maybe ModuleName -> Ghc (Maybe ModuleName)
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName
forall a. Maybe a
Nothing
        (SuccessFlag
Succeeded,(ModuleName
modName,StringBuffer
_)) ->
          Maybe ModuleName -> Ghc (Maybe ModuleName)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModuleName -> Ghc (Maybe ModuleName))
-> Maybe ModuleName -> Ghc (Maybe ModuleName)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
modName

    Just UnitId
uid -> do
      -- TODO: We assume for now that if you depended on
      -- @haskell-debugger-view@, then you also depend on all its transitive
      -- dependencies (containers, text, ...), thus can load all custom
      -- views. Hence all `debuggerViewBuiltinMods`. In the future, we
      -- may want to guard all dependencies behind cabal flags that the user
      -- can tweak when depending on `haskell-debugger-view`.
      (UnitId, [ModuleName]) -> Ghc (UnitId, [ModuleName])
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
uid, ((ModuleName, StringBuffer) -> ModuleName)
-> [(ModuleName, StringBuffer)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, StringBuffer) -> ModuleName
forall a b. (a, b) -> a
fst [(ModuleName, StringBuffer)]
debuggerViewBuiltinMods)

{-
Note [Shutting down the external interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Ghc monad execution (under `runGhc`) sometimes terminates abruptly:
- When the DebugAdapter exits (e.g. disconnect, terminate, error, ...), it
  calls `destroyDebugSession`, which will *kill* the thread running the
  debugger/Ghc session.
- When there is some exception thrown in the Ghc monad itself

GHC wraps the `Ghc` action run with `withCleanupSession`, which is responsible
for e.g. removing temporary files and cleanly terminating the external
interpreter process, if one is being used.

GHC first checks with `getProcessExitCode` the status of the external
interpreter, does nothing if there is some exit status, and kills the external
process otherwise.

However, this check is incorrect(!) when the external interpreter process is
not a child of this process (which will happen in the runInTerminal external
interpreter case). `getProcessExitCode` should error with `ECHILD` in this case
(see `man 2 wait`), even if it doesn't yet (see process#359).

Therefore, the debugger must step in and make sure the external interpreter is
exited cleanly, WITHOUT resorting to `getProcessExitCode`. To this effect, we
add our own `MC.finally cleanupInterp` call which sends the `Shutdown` message
to the external interpreter before propagating the exception further (to GHC's
`withCleanupSession`, which will now do Nothing because we set `InterpPending`,
and beyond).

Note [Must explicitly expose module graph units]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`interactiveGhcDebugger` is our "current home unit", so its
`UnitState{moduleNameProvidersMap}` will determine which modules we can import
interactively (i.e. with GHC.setContext).

The `moduleNameProvidersMap` has so far only been required to expose, with
`ExposePackage` flags, the other home units. However, exposing a package **does
not** imply exposing its dependencies, so `mkUnitState` was free to choose
versions/abis for us, e.g., expose haskell-debugger-view-0.2.1.0-... and hide
haskell-debugger-view-0.2.0.0-..., while the latter is the one in the graph. We
noticed with `hdv` but the above can happen with any dep of the debuggee,
causing problems at the prompt.

Here we explicitly grab the units from the graph and make them exposed, so if we
find a unit in the graph we should be able to import exposed modules from it,
and importing modules at the prompt should use the versions the debuggee depends
on.

An alternative, closer to what ghci does, would be to copy the `packageFlags`
from the debuggee units, however doing so doesn't take care of fixing a unitId
for dependencies of dependencies.

Note [Package Qualified Imports]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Package qualified imports have a quirky behaviour: the source string qualifier gets converted into a `PkgQual` on the way, which can be one of these two:
- `ThisPkg unitId` interpreted as a home unit
- `OtherPkg unitId` interpreted as an external package

We get each under these conditions:
- ThisPkg
  - qualifier is the literal "this" or the **package name** of the active home unit or any of its home unit dependencies.
- OtherPkg
  - qualifier is the **package name** of a non-hidden external unit which exports the module we are importing.
  - None of the above apply, and the qualifier itself is interpreted as a `UnitId`.
When choosing between multiple units that satisfy a condition, the first found is committed to.

The upshot is that `UnitId`s normally only work as qualifiers for external packages, unless you change the package names of home units as described in  Note [ Ambiguous Package Qualified Imports Workaround ].

At the same time doing a PackageImport with a plain PackageName can succeed while resolving to an installed unit while we meant one of the loaded units, resulting in subtly wrong interactive sessions, where the
package-qualified imported module shadows the loaded module. Perhaps GHC could
warn about this. Cabal-repl and ghci also suffer from this subtle interaction.

In light of this, when the debugger imports the `haskell-debugger-view` modules,
it is imperative that if the `haskell-debugger-view` unit is in the home units
(e.g. if `haskell-debugger-view` is listed in the cabal.project, like it is in
the debugger tree), we rely on Note [ Ambiguous Package Qualified Imports Workaround ].

On the other hand, if the `haskell-debugger-view` package is not in the
home-units, we *should* package-qualify it to make sure we reference the right
one.

See also #283
-}

-- | See Note [Shutting down the external interpreter]
cleanupInterp :: Ghc ()
cleanupInterp :: Ghc ()
cleanupInterp = do
  interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> Ghc HscEnv -> Ghc Interp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  case interpInstance interp of
    InterpInstance
InternalInterp -> () -> Ghc ()
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExternalInterp ExtInterp
ext -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExtInterp -> (forall d. ExtInterpStatusVar d -> IO ()) -> IO ()
forall {k} (m :: k -> *) (a :: k).
ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
withExtInterpStatus ExtInterp
ext ((forall d. ExtInterpStatusVar d -> IO ()) -> IO ())
-> (forall d. ExtInterpStatusVar d -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ExtInterpStatusVar d
mstate -> do
      ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_restore -> ExtInterpStatusVar d
-> (InterpStatus (ExtInterpInstance d)
    -> IO (InterpStatus (ExtInterpInstance d)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ExtInterpStatusVar d
mstate ((InterpStatus (ExtInterpInstance d)
  -> IO (InterpStatus (ExtInterpInstance d)))
 -> IO ())
-> (InterpStatus (ExtInterpInstance d)
    -> IO (InterpStatus (ExtInterpInstance d)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \InterpStatus (ExtInterpInstance d)
state -> do
        case InterpStatus (ExtInterpInstance d)
state of
          InterpStatus (ExtInterpInstance d)
InterpPending    -> InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpStatus (ExtInterpInstance d)
state -- already stopped
          InterpRunning ExtInterpInstance d
i  -> do
            -- Can't use  `getProcessExitCode` because the interp process is
            -- not necessarily a child of this process (runInTerminal case).
            -- Just unconditionally try to send the message.
            ExtInterpInstance d -> Message () -> IO ()
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
i Message ()
Shutdown
            InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpStatus (ExtInterpInstance d)
forall inst. InterpStatus inst
InterpPending

annotateDebuggerStackString :: String -> Debugger a -> Debugger a
annotateDebuggerStackString :: forall a. String -> Debugger a -> Debugger a
annotateDebuggerStackString String
s (Debugger ReaderT DebuggerState Ghc a
m) = ReaderT DebuggerState Ghc a -> Debugger a
forall a. ReaderT DebuggerState Ghc a -> Debugger a
Debugger (ReaderT DebuggerState Ghc a -> Debugger a)
-> ReaderT DebuggerState Ghc a -> Debugger a
forall a b. (a -> b) -> a -> b
$ do
  r <- (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)
-> (DebuggerState -> Ghc a) -> ReaderT DebuggerState Ghc a
forall a b. (a -> b) -> a -> b
$ \DebuggerState
val -> do
    ((Ghc a -> IO a) -> IO a) -> Ghc a
forall b a. ((Ghc b -> IO b) -> IO a) -> Ghc a
withUnliftGhc (((Ghc a -> IO a) -> IO a) -> Ghc a)
-> ((Ghc a -> IO a) -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \ Ghc a -> IO a
unlift ->
      String -> IO a -> IO a
forall b. String -> IO b -> IO b
annotateStackStringIO String
s (Ghc a -> IO a
unlift (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ ReaderT DebuggerState Ghc a -> DebuggerState -> Ghc a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DebuggerState Ghc a
m DebuggerState
val)
  pure r

-- | Variant of GHC's parseDynamicFlags which interprets paths relative to first arg.
parseDynamicFlagsWithRootDir
    :: MonadIO m
    => FilePath
    -> Logger
    -> DynFlags
    -> [Located String]
    -> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlagsWithRootDir :: forall (m :: * -> *).
MonadIO m =>
String
-> Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlagsWithRootDir String
rootDir Logger
logger DynFlags
dflags [Located String]
cmdline = do
  (dflags1', leftovers, warns) <- Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlagsCmdLine Logger
logger DynFlags
dflags [Located String]
cmdline
  -- flags that have just been read are used by the logger when loading package
  -- env
  let dflags1 = String -> DynFlags -> DynFlags
makeDynFlagsAbsoluteOverall String
rootDir DynFlags
dflags1'
  let logger1 = Logger -> LogFlags -> Logger
GHC.setLogFlags Logger
logger (DynFlags -> LogFlags
initLogFlags DynFlags
dflags1)
  dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1
  return (dflags2, leftovers, warns)


{-
Note [Custom external interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We compile a custom external interpreter server with custom commands which make
certain debugger operations possible in the remote process directly.
This allows us to avoid excessive `Term` parsing and remote execution.
(Note: we don't have custom commands just yet, but that is the vision)

The custom external interpreter is the same executable as the debugger but invoked as:

  hdb <write-fd> <read-fd> --external-interpreter

(Note: external-interpreter is not the first argument because all `-opti`s are
always inserted after the write-fd and read-fd.)

When setting up the debugger session, we essentially set by default:
  - Enable -fexternal-interpreter
  - Set -pgmi=hdb and -opti=--external-interpreter
This can be switched off by toggling `--internal-interpreter`

With GHC 9.14, we have to override the `createProcess` executable call because
of ghc's c94aaacd4c4 (GHC looks for a `-dyn` suffixed version of the custom
external `-pgmi`, in this case `hdb` (but we do not have an `hdb-dyn`).
In GHC 9.16 it is sufficient to specify the -pgmi.

We can't use the on-the-fly external interpreter from GHC 9.14 because it is
not compiled with -threaded (with 9.16 in principle could, but we really want
the custom commands)

Note: The custom external interpreter must be compiled with -fkeep-cafs!
Why that is necessary is described in the GHC source code.

Note [Dynamic Debuggee for dynamic debugger]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A really really important point is that the debuggee MUST be linked dynamically
if the debugger was compiled dynamically (checked with `hostIsDynamic`).

Not doing this resulted in days upon days of suffering caused by a SIGILL fault.

The bug surfaces when we load a non-PIC static object of the debuggee into a
debugger that was linked dynamically with PIC. The runtime object linker does
not handle this correctly and something goes very wrong with the relocated
debuggee code.

Notably, this bug didn't surface on macOS because the static objects are also
compiled with -fPIC, and it didn't show up when using the distributed iserv
executables because that has very few dyn-link-time dependencies and for some
reason that doesn't trigger the bug. Adding more unused package dependencies
was sufficient to re-trigger it on windows.

Therefore, we always use -dynamic for compiling and loading the debuggee if the
debugger is dynamic (`hostIsDynamic`).

On Windows, the debugger will be static and we'll resort to statically linking
the debuggee too. There won't be a PIC mismatch so this should work fine.

Note [External interpreter buffering]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we launch the external interpreter process, we create pipes for
stdin/stdout/stderr instead of inheriting the current process' handles.
This allows us to cleanly separate the debuggee output from the debugger
output, without needing to redirect handles or the like.

However, using a pipe instead of a handle connected to a TTY means that, by
default, the line buffering will be block based rather than line buffered.

> Newly opened streams are normally fully buffered, with one exception: a
  stream connected to an interactive device such as a terminal is initially
  line buffered.^[1]

We depend on line buffering to forward output from these handles to the
debugger output (see `forwardHandleToLogger`).

Therefore, after loading the modules, we evaluate on the remote process:

  hSetBuffering stdout LineBuffering
  hSetBuffering stderr LineBuffering

When launching the external interpreter directly attached to the user's
terminal (via runInTerminal), the handles will indeed be connected to a TTY.

[1] https://ftp.gnu.org/old-gnu/Manuals/glibc-2.2.5/html_node/Buffering-Concepts.html

Note [Dynamic dependencies for dynamic debugger]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the external interpreter running the debuggee is a dynamically-linked
program compiled with -fPIC, it is of utmost importance that the libraries we
load (e.g. base, ghc-internal, etc) are ALSO compiled with -fPIC. Otherwise, we
end up with the same SIGILL scenario of Note [Dynamic Debuggee for dynamic debugger].

In #260, we battled with another SIGILL for over a week because of this.
Namely, we forgot to configure the external interpreter's
IServConfig.iservConfDynamic (and had hardcoded it to False!!).

When loading a package to the external interpreter, GHC will consult
`iservConfDynamic` on whether to LoadDLL (dynamic lib) or LoadArchive (static
archive). This setting must definitely match the way in which the external
interpreter was compiled (checked with `hostIsDynamic`, since the external
interpreter and the debugger, while not necessarily the same process, are the
same executable). Ditto for `iservConfProfiled` (with `hostIsProfiled`).

Note [UniqueSupply is process global]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The generation of `Unique`s is controlled by two global pointers declared in the
`ghc` package. The same two pointers are shared by all sessions, since the host
ghc library is only loaded once.

If the pointers get re-initialized while a session is active, that session might generate
the same Unique again and we randomly get panics about identifiers out of scope or
which do not match their expected type and so on.

GHC calls the initialization function in main, with a comment saying it should be done
before initializing plugins.

The only safe time to initialize is if there are no existing Uniques that are still relevant,
and since it's also cheap we do it right away in `main`, for the `cli` or `server` commands.

Contrary to ghc itself, this means we do not honor the `initialUnique` and `uniqueIncrement`
fields of DynFlags, but they seem to be there for testing anyway.

Users of hdb-as-a-library, e.g. using runHDBServer, will have to do the initialization themselves,
especially if they supply any loaded units/modules to us via the DebugRunner,
as those will contain `Unique`s.

-}
--------------------------------------------------------------------------------

-- | Run downsweep on the currently set targets (see @hsc_targets@)
doDownsweep :: GhcMonad m
            => Maybe ModuleGraph -- ^ Re-use existing module graph which was already summarised
            -> m ModuleGraph -- ^ Module graph constructed from current set targets
doDownsweep :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModuleGraph -> m ModuleGraph
doDownsweep Maybe ModuleGraph
reuse_mg = do
  hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let msg = Messager
batchMultiMsg
  (errs_base, mod_graph) <- liftIO $
    downsweep
      hsc_env mkUnknownDiagnostic (Just msg)
      (maybe [] mgModSummaries reuse_mg)
#if MIN_VERSION_ghc(10,1,0)
      reuse_mg
#endif
      [] False
  when (not $ null errs_base) $ do
    -- Print the errors to the user, rather than just throwing. When using DAP,
    -- outputting to the logger the error is what displays it in the "Debug
    -- Console" rather than "Output" DAP log.
    logger <- getLogger
    dflags <- hsc_dflags <$> getSession
    let ghc_errs = (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage ([Messages DriverMessage] -> Messages DriverMessage
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [Messages DriverMessage]
errs_base)
    liftIO $ printMessages logger (initPrintConfig dflags) (initDiagOpts dflags) ghc_errs
#if MIN_VERSION_ghc(9,15,0)
    throwErrors (initSourceErrorContext dflags) ghc_errs
#else
    throwErrors ghc_errs
#endif
  return mod_graph

doLoad :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> ModuleGraph -> m SuccessFlag
doLoad :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> ModuleGraph -> m SuccessFlag
doLoad Maybe ModIfaceCache
if_cache LoadHowMuch
how_much ModuleGraph
mg = do
  let msg :: Messager
msg = Messager
batchMultiMsg
  Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
load' Maybe ModIfaceCache
if_cache LoadHowMuch
how_much GhcMessage -> AnyGhcDiagnostic
forall a. (Typeable a, Diagnostic a) => a -> UnknownDiagnosticFor a
mkUnknownDiagnostic (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mg


loadInMemoryModules ::
  LogAction IO DebuggerLog
  -> UnitId
  -> [(ModuleName,StringBuffer)] -> Ghc [SuccessFlag]
loadInMemoryModules :: LogAction IO DebuggerLog
-> UnitId -> [(ModuleName, StringBuffer)] -> Ghc [SuccessFlag]
loadInMemoryModules LogAction IO DebuggerLog
l UnitId
uid [(ModuleName, StringBuffer)]
ts = do
  tgts <- [(ModuleName, StringBuffer)]
-> ((ModuleName, StringBuffer) -> Ghc Target) -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ModuleName, StringBuffer)]
ts (((ModuleName, StringBuffer) -> Ghc Target) -> Ghc [Target])
-> ((ModuleName, StringBuffer) -> Ghc Target) -> Ghc [Target]
forall a b. (a -> b) -> a -> b
$  \(ModuleName
modName,StringBuffer
modContents) ->
    IO Target -> Ghc Target
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Target -> Ghc Target) -> IO Target -> Ghc Target
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleName -> StringBuffer -> IO Target
makeInMemoryTarget UnitId
uid ModuleName
modName StringBuffer
modContents
  GHC.setTargets tgts
  mod_graph <- hsc_mod_graph <$> GHC.getSession
  dvc_mod_graph <- doDownsweep (Just mod_graph)
  let new_mod_graph
#if MIN_VERSION_ghc(10,1,0)
        -- new API allows extending an existing graph.
        = dvc_mod_graph
#else
        = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph ([ModuleGraphNode] -> ModuleGraph)
-> [ModuleGraphNode] -> ModuleGraph
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mg_mss ModuleGraph
dvc_mod_graph [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ ModuleGraph -> [ModuleGraphNode]
mg_mss ModuleGraph
mod_graph
#endif
  modifySession $ GHC.setModuleGraph new_mod_graph

  restore_logger <- GHC.getLogger
  dflags <- getSessionDynFlags
  GHC.modifyLogger $
    -- Emit it all as Debug-level debugger logs
    GHC.pushLogHook $ const $ \LogFlags
_ MessageClass
_ SrcSpan
_ SDoc
sdoc ->
      LogAction IO DebuggerLog
l LogAction IO DebuggerLog -> DebuggerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug (DynFlags -> SDoc -> DebuggerMessage
LogSDoc DynFlags
dflags SDoc
sdoc)

  -- Might not make sense to keep going if the first fails, but we expect all of
  -- them to succeed, and it's not that many more modules.
  s <- forM tgts $ \ Target
tgt -> Target -> Ghc (Maybe SourceError)
compileModuleWithDepsInHpt Target
tgt Ghc (Maybe SourceError)
-> (Maybe SourceError -> Ghc SuccessFlag) -> Ghc SuccessFlag
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe SourceError
Nothing -> SuccessFlag -> Ghc SuccessFlag
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
Succeeded
        Just SourceError
e -> do
          LogAction IO DebuggerLog -> LogAction Ghc DebuggerLog
forall (m :: * -> *) msg.
MonadIO m =>
LogAction IO msg -> LogAction m msg
liftLogIO LogAction IO DebuggerLog
l LogAction Ghc DebuggerLog -> DebuggerLog -> Ghc ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Severity -> DebuggerMessage -> DebuggerLog
DebuggerLog Severity
Logger.Debug (DynFlags -> SDoc -> DebuggerMessage
LogSDoc DynFlags
dflags (SDoc -> DebuggerMessage) -> SDoc -> DebuggerMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (SourceError -> String
forall a. Show a => a -> String
show SourceError
e))
          SuccessFlag -> Ghc SuccessFlag
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
Failed

  -- Restore logger
  GHC.modifyLogger $
    GHC.pushLogHook (const $ GHC.putLogMsg restore_logger)

  return s

--------------------------------------------------------------------------------
-- * Finding Debugger View
--------------------------------------------------------------------------------

-- | Fetch the @haskell-debugger-view@ unit-id from the environment.
-- @Nothing@ means custom debugger views are disabled.
getHsDebuggerViewUid :: Debugger (Maybe UnitId)
getHsDebuggerViewUid :: Debugger (Maybe UnitId)
getHsDebuggerViewUid = (DebuggerState -> Maybe UnitId) -> Debugger (Maybe UnitId)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> Maybe UnitId
hsDbgViewUnitId

-- | Try to find the @haskell-debugger-view@ unit-id in the transitive closure,
-- or, otherwise, return the a custom unit for which we'll load the
-- @haskell-debugger-view@ modules in it (essentially preparing an in-memory
-- version of the library to find the built-in instances in).
--
-- See also comment on the @'hsDbgViewUnitId'@ field of @'DebuggerState'@
findHsDebuggerViewUnitId :: GHC.Ghc (Maybe UnitId)
findHsDebuggerViewUnitId :: Ghc (Maybe UnitId)
findHsDebuggerViewUnitId = do
  hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let unitState = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env

  -- Note: linear in the module graph but only happens once.
  let potential_units = HscEnv -> [UnitId]
graphsUnits HscEnv
hsc_env
  -- Note: the intermediate set is expected to be small (<= 2).
  let hskl_dbgr_vws = Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList (Set UnitId -> [UnitId])
-> ([UnitId] -> Set UnitId) -> [UnitId] -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$
        [ UnitId
uid
        | UnitId
uid <- [UnitId]
potential_units
        , let uid_s :: String
uid_s = UnitId -> String
unitIdString UnitId
uid
        , String
"haskell-debugger-view" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
uid_s
            Bool -> Bool -> Bool
|| String
"hskll-dbggr-vw" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
uid_s
            Bool -> Bool -> Bool
|| String
"haskell-debug_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
uid_s
        ]

      -- If the haskell-debugger-view is in the dependency graph, it must have
      -- one of the versions the debugger is known to support:
      supported_ranges -- [min, max(
        = [ ([Int] -> Version
makeVersion [Int
0, Int
2], [Int] -> Version
makeVersion [Int
0, Int
3]) ]

  case hskl_dbgr_vws of
    [UnitId
hdv_uid] -> do
      -- In transitive closure, use that one.
      -- Check that the version is in supported range.
      case UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
unitState (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
hdv_uid)) of
        Just UnitInfo
unitInfo -> do
          let version :: Version
version = UnitInfo -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
unitInfo
          if ((Version, Version) -> Bool) -> [(Version, Version)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Version
l,Version
h) -> Version
l Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
version Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
h) [(Version, Version)]
supported_ranges
            then Maybe UnitId -> Ghc (Maybe UnitId)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
hdv_uid)
            else UnsupportedHsDbgViewVersion -> Ghc (Maybe UnitId)
forall e a. (HasCallStack, Exception e) => e -> Ghc a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM UnsupportedHsDbgViewVersion{supportedVersions :: [(Version, Version)]
supportedVersions=[(Version, Version)]
supported_ranges, actualVersion :: Version
actualVersion=Version
version}
        Maybe UnitInfo
Nothing
          | String
"inplace" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` UnitId -> String
unitIdString UnitId
hdv_uid
          -- will be built as a target later
          -> Maybe UnitId -> Ghc (Maybe UnitId)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
hdv_uid)
        Maybe UnitInfo
Nothing ->
          String -> Ghc (Maybe UnitId)
forall a. HasCallStack => String -> a
error String
"Could not find unit info for haskell-debugger-view"
    [] -> do
      Maybe UnitId -> Ghc (Maybe UnitId)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnitId
forall a. Maybe a
Nothing
    [UnitId]
_  -> do
      String -> Ghc (Maybe UnitId)
forall a. HasCallStack => String -> a
error (String -> Ghc (Maybe UnitId)) -> String -> Ghc (Maybe UnitId)
forall a b. (a -> b) -> a -> b
$ String
"Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SDoc -> String
showSDocUnsafe (PprStyle -> SDoc -> SDoc
withPprStyle (NamePprCtx -> PprStyle
PprDump NamePprCtx
alwaysQualify) ([UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
hskl_dbgr_vws))

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

-- | Initialize a 'DebuggerState'
initialDebuggerState :: LogAction Debugger DebuggerLog -> Maybe UnitId -> GHC.Ghc DebuggerState
initialDebuggerState :: LogAction Debugger DebuggerLog -> Maybe UnitId -> Ghc DebuggerState
initialDebuggerState LogAction Debugger DebuggerLog
l Maybe UnitId
hsDbgViewUid =
  IORef (BreakpointMap BreakpointInfo)
-> IORef RuntimeInstancesCache
-> IORef ThreadMap
-> IORef CompCache
-> Maybe UnitId
-> LogAction Debugger DebuggerLog
-> DebuggerState
DebuggerState (IORef (BreakpointMap BreakpointInfo)
 -> IORef RuntimeInstancesCache
 -> IORef ThreadMap
 -> IORef CompCache
 -> Maybe UnitId
 -> LogAction Debugger DebuggerLog
 -> DebuggerState)
-> Ghc (IORef (BreakpointMap BreakpointInfo))
-> Ghc
     (IORef RuntimeInstancesCache
      -> IORef ThreadMap
      -> IORef CompCache
      -> Maybe UnitId
      -> LogAction Debugger DebuggerLog
      -> DebuggerState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef (BreakpointMap BreakpointInfo))
-> Ghc (IORef (BreakpointMap BreakpointInfo))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BreakpointMap BreakpointInfo
-> IO (IORef (BreakpointMap BreakpointInfo))
forall a. a -> IO (IORef a)
newIORef BreakpointMap BreakpointInfo
forall a. BreakpointMap a
BM.empty)
                Ghc
  (IORef RuntimeInstancesCache
   -> IORef ThreadMap
   -> IORef CompCache
   -> Maybe UnitId
   -> LogAction Debugger DebuggerLog
   -> DebuggerState)
-> Ghc (IORef RuntimeInstancesCache)
-> Ghc
     (IORef ThreadMap
      -> IORef CompCache
      -> Maybe UnitId
      -> LogAction Debugger DebuggerLog
      -> 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 RuntimeInstancesCache)
-> Ghc (IORef RuntimeInstancesCache)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RuntimeInstancesCache -> IO (IORef RuntimeInstancesCache)
forall a. a -> IO (IORef a)
newIORef RuntimeInstancesCache
emptyRuntimeInstancesCache)
                Ghc
  (IORef ThreadMap
   -> IORef CompCache
   -> Maybe UnitId
   -> LogAction Debugger DebuggerLog
   -> DebuggerState)
-> Ghc (IORef ThreadMap)
-> Ghc
     (IORef CompCache
      -> Maybe UnitId -> LogAction Debugger DebuggerLog -> 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 ThreadMap) -> Ghc (IORef ThreadMap)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ThreadMap -> IO (IORef ThreadMap)
forall a. a -> IO (IORef a)
newIORef ThreadMap
TM.emptyThreadMap)
                Ghc
  (IORef CompCache
   -> Maybe UnitId -> LogAction Debugger DebuggerLog -> DebuggerState)
-> Ghc (IORef CompCache)
-> Ghc
     (Maybe UnitId -> LogAction Debugger DebuggerLog -> 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 CompCache) -> Ghc (IORef CompCache)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CompCache -> IO (IORef CompCache)
forall a. a -> IO (IORef a)
newIORef CompCache
emptyCompCache)
                Ghc
  (Maybe UnitId -> LogAction Debugger DebuggerLog -> DebuggerState)
-> Ghc (Maybe UnitId)
-> Ghc (LogAction Debugger DebuggerLog -> DebuggerState)
forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UnitId -> Ghc (Maybe UnitId)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UnitId
hsDbgViewUid
                Ghc (LogAction Debugger DebuggerLog -> DebuggerState)
-> Ghc (LogAction Debugger DebuggerLog) -> 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
<*> LogAction Debugger DebuggerLog
-> Ghc (LogAction Debugger DebuggerLog)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogAction Debugger DebuggerLog
l

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

data DebuggerFailedToLoad = DebuggerFailedToLoad
instance Exception DebuggerFailedToLoad
instance Show DebuggerFailedToLoad where
  show :: DebuggerFailedToLoad -> String
show DebuggerFailedToLoad
DebuggerFailedToLoad = String
"Failed to compile and load user project."

data UnsupportedHsDbgViewVersion = UnsupportedHsDbgViewVersion
  { UnsupportedHsDbgViewVersion -> [(Version, Version)]
supportedVersions :: [ (Version, Version) ]
  , UnsupportedHsDbgViewVersion -> Version
actualVersion :: Version
  }
instance Exception UnsupportedHsDbgViewVersion
instance Show UnsupportedHsDbgViewVersion where
  show :: UnsupportedHsDbgViewVersion -> String
show (UnsupportedHsDbgViewVersion [(Version, Version)]
supported Version
actual) =
    String
"Cannot use unsupported haskell-debugger-view version found in the transitive closure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
" (supported: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " (((Version, Version) -> String) -> [(Version, Version)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Version
l,Version
h) -> Version -> String
showVersion Version
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <= && < " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
h) [(Version, Version)]
supported) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

data NonFatalException = NonFatalException { NonFatalException -> String
userMessage :: String, NonFatalException -> String
debugMessage :: String }
  deriving Int -> NonFatalException -> ShowS
[NonFatalException] -> ShowS
NonFatalException -> String
(Int -> NonFatalException -> ShowS)
-> (NonFatalException -> String)
-> ([NonFatalException] -> ShowS)
-> Show NonFatalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonFatalException -> ShowS
showsPrec :: Int -> NonFatalException -> ShowS
$cshow :: NonFatalException -> String
show :: NonFatalException -> String
$cshowList :: [NonFatalException] -> ShowS
showList :: [NonFatalException] -> ShowS
Show

instance Exception NonFatalException


expectRight :: Exception e => Either e a -> Debugger a
expectRight :: forall e a. Exception e => Either e a -> Debugger a
expectRight Either e a
s = case Either e a
s of
  Left e
e -> do
    Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Error (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
e)
    IO a -> Debugger a
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Debugger a) -> IO a -> Debugger a
forall a b. (a -> b) -> a -> b
$ NonFatalException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (NonFatalException -> IO a) -> NonFatalException -> IO a
forall a b. (a -> b) -> a -> b
$ NonFatalException { userMessage :: String
userMessage = e -> String
forall e. Exception e => e -> String
displayException e
e, debugMessage :: String
debugMessage = SomeException -> String
displayExceptionWithInfo (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e }
  Right a
a -> do
    a -> Debugger a
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

--------------------------------------------------------------------------------
-- * Modules
--------------------------------------------------------------------------------

-- | List all loaded modules 'ModSummary's
getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo]
getAllLoadedModules :: forall (m :: * -> *). GhcMonad m => m [ModuleNodeInfo]
getAllLoadedModules =
  ([ModuleGraphNode] -> [ModuleNodeInfo]
mgInfos ([ModuleGraphNode] -> [ModuleNodeInfo])
-> (ModuleGraph -> [ModuleGraphNode])
-> ModuleGraph
-> [ModuleNodeInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraph -> [ModuleGraphNode]
mg_mss (ModuleGraph -> [ModuleNodeInfo])
-> m ModuleGraph -> m [ModuleNodeInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
GHC.getModuleGraph) m [ModuleNodeInfo]
-> ([ModuleNodeInfo] -> m [ModuleNodeInfo]) -> m [ModuleNodeInfo]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (ModuleNodeInfo -> m Bool)
-> [ModuleNodeInfo] -> m [ModuleNodeInfo]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\ModuleNodeInfo
ms -> UnitId -> ModuleName -> m Bool
forall (m :: * -> *). GhcMonad m => UnitId -> ModuleName -> m Bool
GHC.isLoadedModule (ModuleNodeInfo -> UnitId
moduleNodeInfoUnitId ModuleNodeInfo
ms) (ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName ModuleNodeInfo
ms))
  where
    mgInfos :: [ModuleGraphNode] -> [ModuleNodeInfo]
mgInfos [ModuleGraphNode]
xs = [ ModuleNodeInfo
info | ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
info <- [ModuleGraphNode]
xs ]

getAllLoadedModulesWithPaths :: GHC.GhcMonad m =>
  m [(AbsFilePath,GHC.ModuleNodeInfo)]
getAllLoadedModulesWithPaths :: forall (m :: * -> *).
GhcMonad m =>
m [(AbsFilePath, ModuleNodeInfo)]
getAllLoadedModulesWithPaths = do
  ghcCwd <- String -> AbsFilePath
mkAbsolute (String -> AbsFilePath) -> m String -> m AbsFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
  -- TODO: cache?
  map (\ ModuleNodeInfo
m -> (AbsFilePath -> ModuleNodeInfo -> AbsFilePath
absoluteSourcePath AbsFilePath
ghcCwd ModuleNodeInfo
m, ModuleNodeInfo
m)) <$> getAllLoadedModules
  where
    absoluteSourcePath :: AbsFilePath -> ModuleNodeInfo -> AbsFilePath
    absoluteSourcePath :: AbsFilePath -> ModuleNodeInfo -> AbsFilePath
absoluteSourcePath AbsFilePath
ghcCwdDir ModuleNodeInfo
ms
      = AbsFilePath
ghcCwdDir AbsFilePath -> String -> AbsFilePath
/> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"missing source path: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Show a => a -> String
show (ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName ModuleNodeInfo
ms)) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe String
ml_hs_file (ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation ModuleNodeInfo
ms))

--------------------------------------------------------------------------------
-- * Forcing laziness
--------------------------------------------------------------------------------

-- | 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.
defaultDepth :: Int
defaultDepth :: Int
defaultDepth =  Int
2

-- | Evaluate a suspended Term to WHNF.
--
-- Used in @'getVariables'@ to reply to a variable introspection request.
seqTerm :: HscEnv -> Term -> IO Term
seqTerm :: HscEnv -> Term -> IO Term
seqTerm HscEnv
hsc_env Term
term = do
  let
    interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
    unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
  case Term
term of
    Suspension{ForeignHValue
val :: ForeignHValue
val :: Term -> ForeignHValue
val, RttiType
ty :: RttiType
ty :: Term -> RttiType
ty} -> do
#if MIN_VERSION_ghc(9,15,0)
      r <- GHCi.seqHValue interp unit_env (hsc_logger hsc_env) val
#else
      r <- Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
GHCi.seqHValue Interp
interp UnitEnv
unit_env ForeignHValue
val
#endif
      () <- 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' <- HscEnv -> Term -> IO Term
seqTerm HscEnv
hsc_env Term
wrapped_term
      return term{wrapped_term=wrapped_term'}
    Term
_ -> Term -> IO Term
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term

-- | Evaluate a Term to NF
deepseqTerm :: HscEnv -> Term -> IO Term
deepseqTerm :: HscEnv -> Term -> IO Term
deepseqTerm HscEnv
hsc_env Term
t = case Term
t of
  Suspension{}   -> do t' <- HscEnv -> Term -> IO Term
seqTerm HscEnv
hsc_env Term
t
                       deepseqTerm hsc_env t'
  Term{[Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms} -> do subTerms' <- (Term -> IO Term) -> [Term] -> IO [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 (HscEnv -> Term -> IO Term
deepseqTerm HscEnv
hsc_env) [Term]
subTerms
                       return t{subTerms = subTerms'}
  NewtypeWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term}
                 -> do wrapped_term' <- HscEnv -> Term -> IO Term
deepseqTerm HscEnv
hsc_env Term
wrapped_term
                       return t{wrapped_term = wrapped_term'}
  Term
_              -> do HscEnv -> Term -> IO Term
seqTerm HscEnv
hsc_env Term
t


logSDoc :: Logger.Severity -> SDoc -> Debugger ()
logSDoc :: Severity -> SDoc -> Debugger ()
logSDoc Severity
sev SDoc
doc = do
  dflags <- Debugger DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  l <- asks dbgLogger
  l <& DebuggerLog sev (LogSDoc dflags doc)