{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE QuasiQuotes #-}

module Ghcitui.Ghcid.Daemon
    ( -- * The interpreter state
      InterpState
        ( func
        , pauseLoc
        , moduleFileMap
        , breakpoints
        , bindings
        , logLevel
        , logOutput
        , execHist
        , traceHist
        )
    , emptyInterpreterState

      -- * Startup and shutdown
    , startup
    , StartupConfig (..)
    , quit

      -- * Base operations with the daemon
    , exec
    , execCleaned
    , execMuted

      -- * Wrapped operations with the daemon
    , step
    , stepInto
    , load
    , continue

      -- * Breakpoints
    , getBpInCurModule
    , getBpInFile
    , toggleBreakpointLine
    , setBreakpointLine
    , deleteBreakpointLine

      -- * Tracing
    , trace
    , history

      -- * Tab completion
    , tabComplete

      -- * Misc
    , isExecuting
    , BreakpointArg (..)
    , run
    , DaemonIO
    , DaemonError
    , LogOutput (..)
    ) where

import Control.Error
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.String.Interpolate (i)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Language.Haskell.Ghcid as Ghcid
import qualified System.IO as IO

import Ghcitui.Ghcid.LogConfig (LogLevel (..), LogOutput (..))
import qualified Ghcitui.Ghcid.ParseContext as ParseContext
import qualified Ghcitui.Ghcid.ParseTabCompletions as ParseTabCompletions
import Ghcitui.Ghcid.StartupConfig (StartupConfig)
import qualified Ghcitui.Ghcid.StartupConfig as StartupConfig
import qualified Ghcitui.Loc as Loc
import qualified Ghcitui.NameBinding as NameBinding
import Ghcitui.Util (showT)
import qualified Ghcitui.Util as Util

data InterpState a = InterpState
    { forall a. InterpState a -> Ghci
_ghci :: !Ghcid.Ghci
    -- ^ GHCiD handle.
    , forall a. InterpState a -> Maybe Text
func :: !(Maybe T.Text)
    -- ^ Current pause position function name.
    , forall a. InterpState a -> Maybe FileLoc
pauseLoc :: !(Maybe Loc.FileLoc)
    -- ^ Current pause position.
    , forall a. InterpState a -> ModuleFileMap
moduleFileMap :: !Loc.ModuleFileMap
    -- ^ Mapping between modules and their filepaths.
    , forall a. InterpState a -> [Text]
stack :: ![T.Text]
    -- ^ Program stack (only available during tracing).
    , forall a. InterpState a -> [(Int, ModuleLoc)]
breakpoints :: ![(Int, Loc.ModuleLoc)]
    -- ^ Currently set breakpoint locations.
    , forall a. InterpState a -> Either DaemonError [NameBinding Text]
bindings :: !(Either DaemonError [NameBinding.NameBinding T.Text])
    -- ^ Current context value bindings.
    , forall a. InterpState a -> Either Text a
status :: !(Either T.Text a)
    -- ^ IDK? I had an idea here at one point.
    , forall a. InterpState a -> LogLevel
logLevel :: !LogLevel
    -- ^ How much should we log?
    , forall a. InterpState a -> LogOutput
logOutput :: !LogOutput
    -- ^ Where should we log to?
    , forall a. InterpState a -> [Text]
execHist :: ![T.Text]
    -- ^ What's the execution history? Note: different from trace history.
    , forall a. InterpState a -> [Text]
traceHist :: ![T.Text]
    -- ^ Trace history.
    }

instance Show (InterpState a) where
    show :: InterpState a -> String
show InterpState a
s =
        let func' :: String
func' = Maybe Text -> String
forall a. Show a => a -> String
show InterpState a
s.func
            msg :: String
msg = case InterpState a
s.pauseLoc of
                Just (Loc.FileLoc String
filepath' Loc.SourceRange{Maybe Int
startLine :: Maybe Int
startCol :: Maybe Int
endLine :: Maybe Int
endCol :: Maybe Int
$sel:startLine:SourceRange :: SourceRange -> Maybe Int
$sel:startCol:SourceRange :: SourceRange -> Maybe Int
$sel:endLine:SourceRange :: SourceRange -> Maybe Int
$sel:endCol:SourceRange :: SourceRange -> Maybe Int
..}) ->
                    let srcRngFmt :: String
                        srcRngFmt :: String
srcRngFmt =
                            [i|{sourceRange=(#{startLine},#{startCol})-(#{endLine},#{endCol})}|]
                     in [i|{func=#{func'}, filepath=#{filepath'}, #{srcRngFmt}}|]
                Maybe FileLoc
Nothing -> String
"<unknown pause location>" :: String
         in String
msg

{- | Create an empty/starting interpreter state.
     Usually you don't want to call this directly. Instead use 'startup'.
-}
emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> StartupConfig -> InterpState a
emptyInterpreterState :: forall a. Monoid a => Ghci -> StartupConfig -> InterpState a
emptyInterpreterState Ghci
ghci StartupConfig
startupConfig =
    InterpState
        { $sel:_ghci:InterpState :: Ghci
_ghci = Ghci
ghci
        , $sel:func:InterpState :: Maybe Text
func = Maybe Text
forall a. Maybe a
Nothing
        , $sel:pauseLoc:InterpState :: Maybe FileLoc
pauseLoc = Maybe FileLoc
forall a. Maybe a
Nothing
        , $sel:moduleFileMap:InterpState :: ModuleFileMap
moduleFileMap = ModuleFileMap
forall a. Monoid a => a
mempty
        , $sel:stack:InterpState :: [Text]
stack = [Text]
forall a. Monoid a => a
mempty
        , $sel:breakpoints:InterpState :: [(Int, ModuleLoc)]
breakpoints = [(Int, ModuleLoc)]
forall a. Monoid a => a
mempty
        , $sel:bindings:InterpState :: Either DaemonError [NameBinding Text]
bindings = [NameBinding Text] -> Either DaemonError [NameBinding Text]
forall a b. b -> Either a b
Right [NameBinding Text]
forall a. Monoid a => a
mempty
        , $sel:status:InterpState :: Either Text a
status = a -> Either Text a
forall a b. b -> Either a b
Right a
forall a. Monoid a => a
mempty
        , $sel:logLevel:InterpState :: LogLevel
logLevel = StartupConfig -> LogLevel
StartupConfig.logLevel StartupConfig
startupConfig
        , $sel:logOutput:InterpState :: LogOutput
logOutput = StartupConfig -> LogOutput
StartupConfig.logOutput StartupConfig
startupConfig
        , $sel:execHist:InterpState :: [Text]
execHist = [Text]
forall a. Monoid a => a
mempty
        , $sel:traceHist:InterpState :: [Text]
traceHist = [Text]
forall a. Monoid a => a
mempty
        }

-- | Reset anything context-based in a 'InterpState'.
contextReset :: (Monoid a) => InterpState a -> InterpState a
contextReset :: forall a. Monoid a => InterpState a -> InterpState a
contextReset InterpState a
state =
    InterpState a
state
        { func = Nothing
        , pauseLoc = Nothing
        , stack = mempty
        , bindings = Right mempty
        , status = Right mempty
        , traceHist = mempty
        }

-- | Append a string to the interpreter's history.
appendExecHist :: T.Text -> InterpState a -> InterpState a
appendExecHist :: forall a. Text -> InterpState a -> InterpState a
appendExecHist Text
cmd s :: InterpState a
s@InterpState{[Text]
$sel:execHist:InterpState :: forall a. InterpState a -> [Text]
execHist :: [Text]
execHist} = InterpState a
s{execHist = cmd : execHist}

-- | Is the daemon currently in the middle of an expression evaluation?
isExecuting :: InterpState a -> Bool
isExecuting :: forall a. InterpState a -> Bool
isExecuting InterpState{$sel:func:InterpState :: forall a. InterpState a -> Maybe Text
func = Maybe Text
Nothing} = Bool
False
isExecuting InterpState{$sel:func:InterpState :: forall a. InterpState a -> Maybe Text
func = Just Text
_} = Bool
True

-- | Start up the GHCi Daemon.
startup
    :: String
    -- ^ Command to run (e.g. "ghci" or "cabal repl")
    -> FilePath
    -- ^ Working directory to run the start up command in.
    -> StartupConfig
    -- ^ Where do we put the logging?
    -> DaemonIO (InterpState ())
    -- ^ The newly created interpreter handle.
startup :: String -> String -> StartupConfig -> DaemonIO (InterpState ())
startup String
cmd String
wd StartupConfig
logOutput = do
    -- We don't want any highlighting or colours.
    let realCmd :: String
realCmd = String
"env TERM='dumb' " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cmd
    let startOp :: IO (Ghci, [Load])
startOp = String
-> Maybe String -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
Ghcid.startGhci String
realCmd (String -> Maybe String
forall a. a -> Maybe a
Just String
wd) Stream -> String -> IO ()
startupStreamCallback
    (Ghci
ghci, [Load]
_) <- IO (Ghci, [Load]) -> ExceptT DaemonError IO (Ghci, [Load])
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ghci, [Load])
startOp
    let state :: InterpState ()
state = Ghci -> StartupConfig -> InterpState ()
forall a. Monoid a => Ghci -> StartupConfig -> InterpState a
emptyInterpreterState Ghci
ghci StartupConfig
logOutput
    Text -> InterpState () -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
"|startup| GHCi Daemon initted" InterpState ()
state
    InterpState () -> DaemonIO (InterpState ())
forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
updateState InterpState ()
state

startupStreamCallback :: Ghcid.Stream -> String -> IO ()
startupStreamCallback :: Stream -> String -> IO ()
startupStreamCallback Stream
stream String
msg = do
    Handle -> String -> IO ()
IO.hPutStrLn Handle
handle [i|[ghcid startup:#{prefix}] #{msg}|]
    Handle -> IO ()
IO.hFlush Handle
handle
  where
    (Handle
handle, String
prefix) = case Stream
stream of
        Stream
Ghcid.Stdout -> (Handle
IO.stdout, String
"out" :: String)
        Stream
Ghcid.Stderr -> (Handle
IO.stderr, String
"err" :: String)

-- | Shut down the GHCi Daemon.
quit :: InterpState a -> IO (InterpState a)
quit :: forall a. InterpState a -> IO (InterpState a)
quit InterpState a
state = do
    Ghci -> IO ()
Ghcid.quit InterpState a
state._ghci
    InterpState a -> IO (InterpState a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpState a
state

-- | Update the interpreter state. Wrapper around other updaters.
updateState :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
updateState :: forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
updateState InterpState a
state =
    InterpState a -> DaemonIO (InterpState a)
forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
updateContext InterpState a
state
        DaemonIO (InterpState a)
-> (InterpState a -> DaemonIO (InterpState a))
-> DaemonIO (InterpState a)
forall a b.
ExceptT DaemonError IO a
-> (a -> ExceptT DaemonError IO b) -> ExceptT DaemonError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InterpState a -> DaemonIO (InterpState a)
forall {a} {e'}. InterpState a -> ExceptT e' IO (InterpState a)
updateBindingsWithErrorHandling
        DaemonIO (InterpState a)
-> (InterpState a -> DaemonIO (InterpState a))
-> DaemonIO (InterpState a)
forall a b.
ExceptT DaemonError IO a
-> (a -> ExceptT DaemonError IO b) -> ExceptT DaemonError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InterpState a -> DaemonIO (InterpState a)
forall a. InterpState a -> DaemonIO (InterpState a)
updateModuleFileMap
        DaemonIO (InterpState a)
-> (InterpState a -> DaemonIO (InterpState a))
-> DaemonIO (InterpState a)
forall a b.
ExceptT DaemonError IO a
-> (a -> ExceptT DaemonError IO b) -> ExceptT DaemonError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InterpState a -> DaemonIO (InterpState a)
forall a. InterpState a -> DaemonIO (InterpState a)
updateBreakList
        DaemonIO (InterpState a)
-> (InterpState a -> DaemonIO (InterpState a))
-> DaemonIO (InterpState a)
forall a b.
ExceptT DaemonError IO a
-> (a -> ExceptT DaemonError IO b) -> ExceptT DaemonError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InterpState a -> DaemonIO (InterpState a)
forall a. InterpState a -> DaemonIO (InterpState a)
updateTraceHistory
  where
    -- Make a wrapper so we don't fail on updating bindings.
    -- Parsing bindings turns out to be actually impossible to solve
    -- with the current ':show bindings' output, so try our best
    -- and keep going.
    updateBindingsWithErrorHandling :: InterpState a -> ExceptT e' IO (InterpState a)
updateBindingsWithErrorHandling InterpState a
s = InterpState a -> DaemonIO (InterpState a)
forall a. InterpState a -> DaemonIO (InterpState a)
updateBindings InterpState a
s DaemonIO (InterpState a)
-> (DaemonError -> ExceptT e' IO (InterpState a))
-> ExceptT e' IO (InterpState a)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` InterpState a -> DaemonError -> ExceptT e' IO (InterpState a)
forall {f :: * -> *} {a}.
Applicative f =>
InterpState a -> DaemonError -> f (InterpState a)
catchBindings InterpState a
s
    catchBindings :: InterpState a -> DaemonError -> f (InterpState a)
catchBindings InterpState a
s DaemonError
er = InterpState a -> f (InterpState a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpState a
s{bindings = Left er}

-- | Update the current interpreter context.
updateContext :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
updateContext :: forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
updateContext state :: InterpState a
state@InterpState{Ghci
$sel:_ghci:InterpState :: forall a. InterpState a -> Ghci
_ghci :: Ghci
_ghci} = do
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
"|updateContext| CMD: :show context\n" InterpState a
state
    [String]
msgs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ExceptT DaemonError IO [String])
-> IO [String] -> ExceptT DaemonError IO [String]
forall a b. (a -> b) -> a -> b
$ Ghci -> String -> IO [String]
Ghcid.exec Ghci
_ghci String
":show context"
    let feedback :: Text
feedback = [Text] -> Text
ParseContext.cleanResponse (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
msgs)
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug
        ( Text
"|updateContext| OUT:\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
Util.linesToText [String]
msgs
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        )
        InterpState a
state
    if Text -> Bool
T.null Text
feedback
        then InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a -> DaemonIO (InterpState a))
-> InterpState a -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ InterpState a -> InterpState a
forall a. Monoid a => InterpState a -> InterpState a
contextReset InterpState a
state -- We exited everything.
        else do
            let ctx :: ParseContextReturn
ctx = Text -> ParseContextReturn
ParseContext.parseContext Text
feedback
            case ParseContextReturn
ctx of
                ParseContext.PCError ParseError
er -> do
                    let msg :: Text
msg = [i|Failed to update context: #{er}|]
                    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logError (Text
"|updateContext| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg) InterpState a
state
                    DaemonError -> DaemonIO (InterpState a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DaemonError -> DaemonIO (InterpState a))
-> DaemonError -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ Text -> DaemonError
UpdateContextError Text
msg
                ParseContextReturn
ParseContext.PCNoContext -> InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a -> DaemonIO (InterpState a))
-> InterpState a -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ InterpState a -> InterpState a
forall a. Monoid a => InterpState a -> InterpState a
contextReset InterpState a
state
                ParseContext.PCContext
                    ParseContext.ParseContextOut{Text
func :: Text
$sel:func:ParseContextOut :: ParseContextOut -> Text
func, String
filepath :: String
$sel:filepath:ParseContextOut :: ParseContextOut -> String
filepath, SourceRange
pcSourceRange :: SourceRange
$sel:pcSourceRange:ParseContextOut :: ParseContextOut -> SourceRange
pcSourceRange} ->
                        InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            InterpState a
state
                                { func = Just func
                                , pauseLoc = Just $ Loc.FileLoc filepath pcSourceRange
                                }

-- | Update the current local bindings.
updateBindings :: InterpState a -> DaemonIO (InterpState a)
updateBindings :: forall a. InterpState a -> DaemonIO (InterpState a)
updateBindings state :: InterpState a
state@InterpState{Ghci
$sel:_ghci:InterpState :: forall a. InterpState a -> Ghci
_ghci :: Ghci
_ghci} = do
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
"|updateBindings| CMD: :show bindings\n" InterpState a
state
    [String]
msgs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ghci -> String -> IO [String]
Ghcid.exec Ghci
_ghci String
":show bindings")
    let feedback :: Text
feedback = [Text] -> Text
ParseContext.cleanResponse (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
msgs)
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug
        ( Text
"|updateBindings| OUT:\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
Util.linesToText [String]
msgs
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        )
        InterpState a
state
    case Text -> Either Text [NameBinding Text]
ParseContext.parseBindings Text
feedback of
        Right [NameBinding Text]
bindings -> InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
state{bindings = pure bindings})
        Left Text
er -> do
            Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logError (Text
"|updateBingings| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg) InterpState a
state
            DaemonError -> DaemonIO (InterpState a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DaemonError -> DaemonIO (InterpState a))
-> DaemonError -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ Text -> DaemonError
UpdateBindingError Text
msg
          where
            msg :: Text
msg = [i|Failed to update bindings: #{er}|]

-- | Update the source map given any app state changes.
updateModuleFileMap :: InterpState a -> DaemonIO (InterpState a)
updateModuleFileMap :: forall a. InterpState a -> DaemonIO (InterpState a)
updateModuleFileMap state :: InterpState a
state@InterpState{Ghci
$sel:_ghci:InterpState :: forall a. InterpState a -> Ghci
_ghci :: Ghci
_ghci, ModuleFileMap
$sel:moduleFileMap:InterpState :: forall a. InterpState a -> ModuleFileMap
moduleFileMap :: ModuleFileMap
moduleFileMap} = do
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
"updateModuleFileMap|: CMD: :show modules\n" InterpState a
state
    [String]
msgs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ExceptT DaemonError IO [String])
-> IO [String] -> ExceptT DaemonError IO [String]
forall a b. (a -> b) -> a -> b
$ Ghci -> String -> IO [String]
Ghcid.exec Ghci
_ghci String
":show modules"
    let packedMsgs :: Text
packedMsgs = [String] -> Text
Util.linesToText [String]
msgs
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug [i||updateModuleFileMap|: OUT: #{packedMsgs}\n|] InterpState a
state
    [(Text, String)]
modules <- case Text -> Either ParseError [(Text, String)]
ParseContext.parseShowModules Text
packedMsgs of
        Right [(Text, String)]
modules -> [(Text, String)] -> ExceptT DaemonError IO [(Text, String)]
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, String)]
modules
        Left ParseError
er -> DaemonError -> ExceptT DaemonError IO [(Text, String)]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> DaemonError
GenericError (ParseError -> Text
forall a. Show a => a -> Text
showT ParseError
er))
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug [i||updateModuleFileMap| modules: #{modules}|] InterpState a
state
    let addedModuleMap :: ModuleFileMap
addedModuleMap = [(Text, String)] -> ModuleFileMap
Loc.moduleFileMapFromList [(Text, String)]
modules
    let newModuleFileMap :: ModuleFileMap
newModuleFileMap = ModuleFileMap
addedModuleMap ModuleFileMap -> ModuleFileMap -> ModuleFileMap
forall a. Semigroup a => a -> a -> a
<> ModuleFileMap
moduleFileMap
    InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a -> DaemonIO (InterpState a))
-> InterpState a -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ InterpState a
state{moduleFileMap = newModuleFileMap}

updateTraceHistory :: InterpState a -> DaemonIO (InterpState a)
updateTraceHistory :: forall a. InterpState a -> DaemonIO (InterpState a)
updateTraceHistory InterpState a
state = do
    (InterpState a
newState, Either Text [Text]
eTraceHist) <- InterpState a -> DaemonIO (InterpState a, Either Text [Text])
forall a.
InterpState a -> DaemonIO (InterpState a, Either Text [Text])
history InterpState a
state
    InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a -> DaemonIO (InterpState a))
-> InterpState a -> DaemonIO (InterpState a)
forall a b. (a -> b) -> a -> b
$ case Either Text [Text]
eTraceHist of
        Left Text
_ -> InterpState a
newState{traceHist = []}
        Right [Text]
traceHist -> InterpState a
newState{traceHist}

-- | Analogue to @:step@.
step :: (Monoid a) => InterpState a -> ExceptT DaemonError IO (InterpState a)
step :: forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
step = Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted Text
":step"

-- | Analogue to @:step <func>@.
stepInto
    :: (Monoid a)
    => T.Text
    -> InterpState a
    -- ^ Function name to jump to.
    -> ExceptT DaemonError IO (InterpState a)
    -- ^ New interpreter state.
stepInto :: forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
stepInto Text
func = Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted (Text
":step " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
func)

{- | Analogue to @:history@.
     Returns either a 'Left' error message, or a 'Right' list of trace breakpoints.
-}
history :: InterpState a -> DaemonIO (InterpState a, Either T.Text [T.Text])
history :: forall a.
InterpState a -> DaemonIO (InterpState a, Either Text [Text])
history InterpState a
state = do
    [String]
msgStrs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ExceptT DaemonError IO [String])
-> IO [String] -> ExceptT DaemonError IO [String]
forall a b. (a -> b) -> a -> b
$ Ghci -> String -> IO [String]
Ghcid.exec (InterpState a -> Ghci
forall a. InterpState a -> Ghci
_ghci InterpState a
state) String
":history"
    let msgs :: [Text]
msgs = Text -> [Text]
T.lines ([Text] -> Text
ParseContext.cleanResponse (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
msgStrs))
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug [i||history| OUT:\n#{T.unlines msgs}|] InterpState a
state
    case [Text]
msgs of
        [] -> DaemonError -> DaemonIO (InterpState a, Either Text [Text])
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> DaemonError
GenericError Text
"':history' unexpectedly returned nothing.")
        [Text
oneLine] ->
            if Text -> Bool
ParseContext.isHistoryFailureMsg Text
oneLine
                then -- This is probably an error message. Set it as such.
                    (InterpState a, Either Text [Text])
-> DaemonIO (InterpState a, Either Text [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
state, Text -> Either Text [Text]
forall a b. a -> Either a b
Left Text
oneLine)
                else -- This is a real trace entry... maybe.
                    (InterpState a, Either Text [Text])
-> DaemonIO (InterpState a, Either Text [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
state, [Text] -> Either Text [Text]
forall a b. b -> Either a b
Right [Text
oneLine])
        [Text]
_ -> (InterpState a, Either Text [Text])
-> DaemonIO (InterpState a, Either Text [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
state, [Text] -> Either Text [Text]
forall a b. b -> Either a b
Right [Text]
msgs)

-- | Analogue to @:continue@. Throws out any messages.
continue :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
continue :: forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
continue = Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted Text
":continue"

-- | Analogue to @:trace@, with no arguments. Throws out any messages.
trace :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)
trace :: forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
trace = Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted Text
":trace"

-- | Analogue to @:load <filepath>@. Throws out any messages.
load :: (Monoid a) => FilePath -> InterpState a -> DaemonIO (InterpState a)
load :: forall a.
Monoid a =>
String -> InterpState a -> DaemonIO (InterpState a)
load String
filepath = Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
":load " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
filepath)

{- | Return tab completions for a given prefix.
     Analog to @:complete repl "<prefix>"@
     See https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#ghci-cmd-:complete
-}
tabComplete
    :: (Monoid a)
    => T.Text
    -- ^ Text (prefix) to return autocompletions of. Does not need to be escaped.
    -> InterpState a
    -- ^ Interpreter state to use.
    -> DaemonIO (InterpState a, (T.Text, [T.Text]))
    -- ^ Resulting state, the prefix, and autocompletions.
tabComplete :: forall a.
Monoid a =>
Text -> InterpState a -> DaemonIO (InterpState a, (Text, [Text]))
tabComplete Text
providedPrefix InterpState a
state = do
    -- Tab completion expects input to be 'show'n in quotes.
    -- There's probably a better way of doing this!
    let escapedPrefix :: Text
escapedPrefix = Text -> Text
forall a. Show a => a -> Text
Util.showT Text
providedPrefix
    let cmd :: Text
cmd = Text
":complete repl " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
escapedPrefix
    (InterpState a
newState, [Text]
outputLines) <- Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
forall a.
Monoid a =>
Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
execCleaned Text
cmd InterpState a
state
    (Text
prefix, [Text]
completions) <- case [Text] -> Either ParseError (Text, [Text])
ParseTabCompletions.parseCompletionsWithHeader [Text]
outputLines of
        Right (Text, [Text])
c -> (Text, [Text]) -> ExceptT DaemonError IO (Text, [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text, [Text])
c
        Left (ParseTabCompletions.ParseError Text
er) -> DaemonError -> ExceptT DaemonError IO (Text, [Text])
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> DaemonError
GenericError Text
er)
    (InterpState a, (Text, [Text]))
-> DaemonIO (InterpState a, (Text, [Text]))
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
newState, (Text
prefix, [Text]
completions))

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

{- | Execute an arbitrary command, as if it was directly written in GHCi.
     It is unlikely you want to call this directly, and instead want to call
     one of the wrapped functions or 'execMuted' or 'execCleaned'.
-}
exec :: (Monoid a) => T.Text -> InterpState a -> ExceptT DaemonError IO (InterpState a, [T.Text])
exec :: forall a.
Monoid a =>
Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
exec Text
cmd state :: InterpState a
state@InterpState{Ghci
$sel:_ghci:InterpState :: forall a. InterpState a -> Ghci
_ghci :: Ghci
_ghci} = do
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug (Text
"|exec| CMD: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd) InterpState a
state
    [String]
msgs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ExceptT DaemonError IO [String])
-> IO [String] -> ExceptT DaemonError IO [String]
forall a b. (a -> b) -> a -> b
$ Ghci -> String -> IO [String]
Ghcid.exec Ghci
_ghci (Text -> String
T.unpack Text
cmd)
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug [i||exec| OUT:\n#{Util.linesToText msgs}\n|] InterpState a
state
    InterpState a
newState <-
        InterpState a -> DaemonIO (InterpState a)
forall a. Monoid a => InterpState a -> DaemonIO (InterpState a)
updateState
            ( -- Only append the command to the history if it has something interesting.
              if Text -> Bool
T.null Text
cmd
                then InterpState a
state
                else Text -> InterpState a -> InterpState a
forall a. Text -> InterpState a -> InterpState a
appendExecHist Text
cmd InterpState a
state
            )
    (InterpState a, [Text])
-> ExceptT DaemonError IO (InterpState a, [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a
newState, (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack [String]
msgs)

-- | 'exec', but throw out any messages.
execMuted :: (Monoid a) => T.Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted :: forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted Text
cmd InterpState a
state = (InterpState a, [Text]) -> InterpState a
forall a b. (a, b) -> a
fst ((InterpState a, [Text]) -> InterpState a)
-> ExceptT DaemonError IO (InterpState a, [Text])
-> ExceptT DaemonError IO (InterpState a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
forall a.
Monoid a =>
Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
exec Text
cmd InterpState a
state

-- | 'exec', but fully clean the message from prompt.
execCleaned
    :: (Monoid a)
    => T.Text
    -> InterpState a
    -> ExceptT DaemonError IO (InterpState a, [T.Text])
execCleaned :: forall a.
Monoid a =>
Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
execCleaned Text
cmd InterpState a
state = do
    (InterpState a, [Text])
res <- (InterpState a, [Text]) -> (InterpState a, [Text])
forall {a}. (a, [Text]) -> (a, [Text])
cleaner ((InterpState a, [Text]) -> (InterpState a, [Text]))
-> ExceptT DaemonError IO (InterpState a, [Text])
-> ExceptT DaemonError IO (InterpState a, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
forall a.
Monoid a =>
Text
-> InterpState a -> ExceptT DaemonError IO (InterpState a, [Text])
exec Text
cmd InterpState a
state
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug (Text
"|cleaned|:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
T.unlines ([Text] -> Text)
-> ((InterpState a, [Text]) -> [Text])
-> (InterpState a, [Text])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InterpState a, [Text]) -> [Text]
forall a b. (a, b) -> b
snd ((InterpState a, [Text]) -> Text)
-> (InterpState a, [Text]) -> Text
forall a b. (a -> b) -> a -> b
$ (InterpState a, [Text])
res)) InterpState a
state
    (InterpState a, [Text])
-> ExceptT DaemonError IO (InterpState a, [Text])
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpState a, [Text])
res
  where
    cleaner :: (a, [Text]) -> (a, [Text])
cleaner (a
s, [Text]
ls) = (a
s, Text -> [Text]
T.lines ([Text] -> Text
ParseContext.cleanResponse [Text]
ls))

-- ------------------------------------------------------------------------------------------------
-- Breakpoint handling
-- ------------------------------------------------------------------------------------------------

-- | Location info passed to breakpoint functions.
data BreakpointArg
    = -- | Location in the current file.
      LocalLine !Int
    | -- | Location in a module.
      ModLoc !Loc.ModuleLoc
    deriving (Int -> BreakpointArg -> ShowS
[BreakpointArg] -> ShowS
BreakpointArg -> String
(Int -> BreakpointArg -> ShowS)
-> (BreakpointArg -> String)
-> ([BreakpointArg] -> ShowS)
-> Show BreakpointArg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BreakpointArg -> ShowS
showsPrec :: Int -> BreakpointArg -> ShowS
$cshow :: BreakpointArg -> String
show :: BreakpointArg -> String
$cshowList :: [BreakpointArg] -> ShowS
showList :: [BreakpointArg] -> ShowS
Show, BreakpointArg -> BreakpointArg -> Bool
(BreakpointArg -> BreakpointArg -> Bool)
-> (BreakpointArg -> BreakpointArg -> Bool) -> Eq BreakpointArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BreakpointArg -> BreakpointArg -> Bool
== :: BreakpointArg -> BreakpointArg -> Bool
$c/= :: BreakpointArg -> BreakpointArg -> Bool
/= :: BreakpointArg -> BreakpointArg -> Bool
Eq, Eq BreakpointArg
Eq BreakpointArg =>
(BreakpointArg -> BreakpointArg -> Ordering)
-> (BreakpointArg -> BreakpointArg -> Bool)
-> (BreakpointArg -> BreakpointArg -> Bool)
-> (BreakpointArg -> BreakpointArg -> Bool)
-> (BreakpointArg -> BreakpointArg -> Bool)
-> (BreakpointArg -> BreakpointArg -> BreakpointArg)
-> (BreakpointArg -> BreakpointArg -> BreakpointArg)
-> Ord BreakpointArg
BreakpointArg -> BreakpointArg -> Bool
BreakpointArg -> BreakpointArg -> Ordering
BreakpointArg -> BreakpointArg -> BreakpointArg
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 :: BreakpointArg -> BreakpointArg -> Ordering
compare :: BreakpointArg -> BreakpointArg -> Ordering
$c< :: BreakpointArg -> BreakpointArg -> Bool
< :: BreakpointArg -> BreakpointArg -> Bool
$c<= :: BreakpointArg -> BreakpointArg -> Bool
<= :: BreakpointArg -> BreakpointArg -> Bool
$c> :: BreakpointArg -> BreakpointArg -> Bool
> :: BreakpointArg -> BreakpointArg -> Bool
$c>= :: BreakpointArg -> BreakpointArg -> Bool
>= :: BreakpointArg -> BreakpointArg -> Bool
$cmax :: BreakpointArg -> BreakpointArg -> BreakpointArg
max :: BreakpointArg -> BreakpointArg -> BreakpointArg
$cmin :: BreakpointArg -> BreakpointArg -> BreakpointArg
min :: BreakpointArg -> BreakpointArg -> BreakpointArg
Ord)

-- | Toggle a breakpoint (disable/enable) at a given location.
toggleBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
toggleBreakpointLine :: forall a.
Monoid a =>
BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
toggleBreakpointLine BreakpointArg
loc InterpState a
state
    | Right Bool
True <- Either DaemonError Bool
isSet = BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
forall a.
Monoid a =>
BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
deleteBreakpointLine BreakpointArg
loc InterpState a
state
    | Left DaemonError
x <- Either DaemonError Bool
isSet = DaemonError -> DaemonIO (InterpState a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DaemonError
x
    | Bool
otherwise = BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
forall a.
Monoid a =>
BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
setBreakpointLine BreakpointArg
loc InterpState a
state
  where
    handleModLoc :: ModuleLoc -> Either DaemonError Bool
handleModLoc ModuleLoc
ml =
        Either DaemonError FileLoc
fileLoc Either DaemonError FileLoc
-> (FileLoc -> Either DaemonError Bool) -> Either DaemonError Bool
forall a b.
Either DaemonError a
-> (a -> Either DaemonError b) -> Either DaemonError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FileLoc
fl -> case (FileLoc -> String
Loc.filepath FileLoc
fl, SourceRange -> Maybe Int
Loc.startLine (FileLoc -> SourceRange
forall a. HasSourceRange a => a -> SourceRange
Loc.sourceRange FileLoc
fl)) of
            (String
filepath, Just Int
lineno) ->
                Bool -> Either DaemonError Bool
forall a b. b -> Either a b
Right (Bool -> Either DaemonError Bool)
-> Bool -> Either DaemonError Bool
forall a b. (a -> b) -> a -> b
$ Int
lineno Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> InterpState a -> [Int]
forall a. String -> InterpState a -> [Int]
getBpInFile String
filepath InterpState a
state
            (String
_, Maybe Int
_) -> ModuleLoc -> Either DaemonError Bool
forall a. ModuleLoc -> Either DaemonError a
invalidLoc ModuleLoc
ml
      where
        fileLoc :: Either DaemonError FileLoc
fileLoc = Either DaemonError FileLoc
-> (FileLoc -> Either DaemonError FileLoc)
-> Maybe FileLoc
-> Either DaemonError FileLoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ModuleLoc -> Either DaemonError FileLoc
forall a. ModuleLoc -> Either DaemonError a
invalidLoc ModuleLoc
ml) FileLoc -> Either DaemonError FileLoc
forall a b. b -> Either a b
Right (ModuleFileMap -> ModuleLoc -> Maybe FileLoc
Loc.toFileLoc (InterpState a -> ModuleFileMap
forall a. InterpState a -> ModuleFileMap
moduleFileMap InterpState a
state) ModuleLoc
ml)

    isSet :: Either DaemonError Bool
isSet =
        case BreakpointArg
loc of
            LocalLine Int
lineno -> Bool -> Either DaemonError Bool
forall a b. b -> Either a b
Right (Bool -> Either DaemonError Bool)
-> Bool -> Either DaemonError Bool
forall a b. (a -> b) -> a -> b
$ Int
lineno Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` InterpState a -> [Int]
forall a. InterpState a -> [Int]
getBpInCurModule InterpState a
state
            ModLoc ModuleLoc
ml -> ModuleLoc -> Either DaemonError Bool
handleModLoc ModuleLoc
ml

    invalidLoc :: Loc.ModuleLoc -> Either DaemonError a
    invalidLoc :: forall a. ModuleLoc -> Either DaemonError a
invalidLoc ModuleLoc
ml =
        DaemonError -> Either DaemonError a
forall a b. a -> Either a b
Left (DaemonError -> Either DaemonError a)
-> DaemonError -> Either DaemonError a
forall a b. (a -> b) -> a -> b
$
            Text -> DaemonError
BreakpointError [i|Cannot locate breakpoint position '#{ml}' in module without source|]

-- | Set a breakpoint at a given line.
setBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
setBreakpointLine :: forall a.
Monoid a =>
BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
setBreakpointLine BreakpointArg
loc InterpState a
state = do
    Text
command <- DaemonIO Text
getCommand
    Text -> InterpState a -> DaemonIO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted Text
command InterpState a
state
  where
    getCommand :: DaemonIO T.Text
    getCommand :: DaemonIO Text
getCommand = do
        Text
breakPos <- case BreakpointArg
loc of
            LocalLine Int
pos -> Text -> DaemonIO Text
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text
forall a. Show a => a -> Text
showT Int
pos)
            ModLoc (Loc.ModuleLoc Text
mod' Loc.SourceRange{Maybe Int
$sel:startLine:SourceRange :: SourceRange -> Maybe Int
startLine :: Maybe Int
startLine, Maybe Int
$sel:startCol:SourceRange :: SourceRange -> Maybe Int
startCol :: Maybe Int
startCol}) ->
                let line :: Text
line = Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Int -> Text
forall a. Show a => a -> Text
showT Maybe Int
startLine
                    colno :: Text
colno = Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Int -> Text
forall a. Show a => a -> Text
showT Maybe Int
startCol
                 in if Text
line Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
""
                        then
                            DaemonError -> DaemonIO Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
                                (Text -> DaemonError
BreakpointError Text
"Cannot set breakpoint at unknown line number")
                        else Text -> DaemonIO Text
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [i|#{mod'} #{line} #{colno}|]
        Text -> DaemonIO Text
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
":break " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
breakPos)

-- | Delete a breakpoint at a given line.
deleteBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
deleteBreakpointLine :: forall a.
Monoid a =>
BreakpointArg -> InterpState a -> DaemonIO (InterpState a)
deleteBreakpointLine BreakpointArg
loc InterpState a
state =
    let convert :: BreakpointArg -> Maybe ModuleLoc
convert (LocalLine Int
ll) =
            -- TODO: We really should not consider LocalLines valid for this, because we don't
            -- really know whether it's local to the paused file, or local to the file
            -- we're viewing.
            -- But that's a problem for future me.
            let fakeSourceRange :: SourceRange
fakeSourceRange = Int -> SourceRange
Loc.srFromLineNo Int
ll
             in do
                    FileLoc
pauseLoc <- InterpState a
state.pauseLoc
                    ModuleFileMap -> FileLoc -> Maybe ModuleLoc
Loc.toModuleLoc
                        InterpState a
state.moduleFileMap
                        (FileLoc
pauseLoc{Loc.fSourceRange = fakeSourceRange})
        convert (ModLoc ModuleLoc
ml) = ModuleLoc -> Maybe ModuleLoc
forall a. a -> Maybe a
Just ModuleLoc
ml

        -- Get the breakpoint index if it exists.
        idxMaybe :: Maybe Int
idxMaybe =
            BreakpointArg -> Maybe ModuleLoc
convert BreakpointArg
loc Maybe ModuleLoc -> (ModuleLoc -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ModuleLoc
ml ->
                let match :: a -> a -> Bool
match a
x a
y =
                        let srX :: SourceRange
srX = a -> SourceRange
forall a. HasSourceRange a => a -> SourceRange
Loc.sourceRange a
x
                            srY :: SourceRange
srY = a -> SourceRange
forall a. HasSourceRange a => a -> SourceRange
Loc.sourceRange a
y
                         in SourceRange -> Maybe Int
Loc.startLine SourceRange
srX Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== SourceRange -> Maybe Int
Loc.startLine SourceRange
srY
                                Bool -> Bool -> Bool
&& SourceRange -> Maybe Int
Loc.endLine SourceRange
srY Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== SourceRange -> Maybe Int
Loc.endLine SourceRange
srY
                 in [Int] -> Maybe Int
forall a. [a] -> Maybe a
headMay
                        [ Int
idx
                        | (Int
idx, ModuleLoc
otherML) <- InterpState a
state.breakpoints
                        , ModuleLoc -> ModuleLoc -> Bool
forall {a} {a}.
(HasSourceRange a, HasSourceRange a) =>
a -> a -> Bool
match ModuleLoc
ml ModuleLoc
otherML
                        ]
     in case Maybe Int
idxMaybe of
            Just Int
num -> Text -> InterpState a -> DaemonIO (InterpState a)
forall a.
Monoid a =>
Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)
execMuted (Text
":delete " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
num) InterpState a
state
            Maybe Int
Nothing -> do
                Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug
                    ( [i|No breakpoint at '#{show loc}'; |]
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [i|breakpoints are found at #{show (breakpoints state)}|]
                    )
                    InterpState a
state
                InterpState a -> DaemonIO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpState a
state

updateBreakList :: InterpState a -> ExceptT DaemonError IO (InterpState a)
updateBreakList :: forall a. InterpState a -> DaemonIO (InterpState a)
updateBreakList state :: InterpState a
state@InterpState{Ghci
$sel:_ghci:InterpState :: forall a. InterpState a -> Ghci
_ghci :: Ghci
_ghci} = do
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
"|updateBreakList| CMD: :show breaks\n" InterpState a
state
    [String]
msgs <- IO [String] -> ExceptT DaemonError IO [String]
forall a. IO a -> ExceptT DaemonError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ghci -> String -> IO [String]
Ghcid.exec Ghci
_ghci String
":show breaks")
    Text -> InterpState a -> ExceptT DaemonError IO ()
forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug
        ( Text
"|updateBreakList| OUT:\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
Util.linesToText [String]
msgs
        )
        InterpState a
state
    let response :: Text
response = [Text] -> Text
ParseContext.cleanResponse (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
msgs)
    case Text -> Either Text [(Int, ModuleLoc)]
ParseContext.parseShowBreaks Text
response of
        Right [(Int, ModuleLoc)]
breakpoints -> InterpState a -> ExceptT DaemonError IO (InterpState a)
forall a. a -> ExceptT DaemonError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpState a
state{breakpoints}
        Left Text
er -> DaemonError -> ExceptT DaemonError IO (InterpState a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> DaemonError
UpdateBreakListError [i|parsing breakpoint list: #{er}|])

-- | Return a list of breakpoint line numbers in the currently paused file.
getBpInCurModule :: InterpState a -> [Int]
getBpInCurModule :: forall a. InterpState a -> [Int]
getBpInCurModule InterpState{$sel:pauseLoc:InterpState :: forall a. InterpState a -> Maybe FileLoc
pauseLoc = Maybe FileLoc
Nothing} = []
getBpInCurModule s :: InterpState a
s@InterpState{$sel:pauseLoc:InterpState :: forall a. InterpState a -> Maybe FileLoc
pauseLoc = Just Loc.FileLoc{$sel:filepath:FileLoc :: FileLoc -> String
filepath = String
fp}} = String -> InterpState a -> [Int]
forall a. String -> InterpState a -> [Int]
getBpInFile String
fp InterpState a
s

-- | Return a list of breakpoint line numbers in the given filepath.
getBpInFile :: FilePath -> InterpState a -> [Int]
getBpInFile :: forall a. String -> InterpState a -> [Int]
getBpInFile String
fp InterpState a
state =
    [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes
        [ SourceRange -> Maybe Int
Loc.startLine (FileLoc -> SourceRange
forall a. HasSourceRange a => a -> SourceRange
Loc.sourceRange FileLoc
loc)
        | FileLoc
loc <- [FileLoc]
breakpointlocs
        , FileLoc -> String
Loc.filepath FileLoc
loc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fp
        ]
  where
    -- Convert between module locations and file locations
    convert :: (Int, ModuleLoc) -> Maybe FileLoc
convert (Int
_, ModuleLoc
x) = ModuleFileMap -> ModuleLoc -> Maybe FileLoc
Loc.toFileLoc (InterpState a -> ModuleFileMap
forall a. InterpState a -> ModuleFileMap
moduleFileMap InterpState a
state) ModuleLoc
x
    breakpointlocs :: [FileLoc]
breakpointlocs = ((Int, ModuleLoc) -> Maybe FileLoc)
-> [(Int, ModuleLoc)] -> [FileLoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, ModuleLoc) -> Maybe FileLoc
convert (InterpState a -> [(Int, ModuleLoc)]
forall a. InterpState a -> [(Int, ModuleLoc)]
breakpoints InterpState a
state)

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

-- | Log a message at the Debug level.
logDebug :: (MonadIO m) => T.Text -> InterpState a -> m ()
logDebug :: forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logDebug Text
msg InterpState a
state =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InterpState a -> LogLevel
forall a. InterpState a -> LogLevel
logLevel InterpState a
state LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> LogLevel
LogLevel Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            LogOutput -> Text -> Text -> IO ()
forall (m :: * -> *).
MonadIO m =>
LogOutput -> Text -> Text -> m ()
logHelper LogOutput
output Text
"[DEBUG]: " Text
msg
  where
    output :: LogOutput
output = InterpState a -> LogOutput
forall a. InterpState a -> LogOutput
logOutput InterpState a
state

-- Log a message at the Error level.
logError :: (MonadIO m) => T.Text -> InterpState a -> m ()
logError :: forall (m :: * -> *) a. MonadIO m => Text -> InterpState a -> m ()
logError Text
msg InterpState a
state =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InterpState a -> LogLevel
forall a. InterpState a -> LogLevel
logLevel InterpState a
state LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> LogLevel
LogLevel Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            LogOutput -> Text -> Text -> IO ()
forall (m :: * -> *).
MonadIO m =>
LogOutput -> Text -> Text -> m ()
logHelper LogOutput
output Text
"[ERROR]: " Text
msg
  where
    output :: LogOutput
output = InterpState a -> LogOutput
forall a. InterpState a -> LogOutput
logOutput InterpState a
state

logHelper
    :: (MonadIO m)
    => LogOutput
    -- ^ Where to log?
    -> T.Text
    -- ^ prefix
    -> T.Text
    -- ^ Message
    -> m ()
logHelper :: forall (m :: * -> *).
MonadIO m =>
LogOutput -> Text -> Text -> m ()
logHelper LogOutput
outputLoc Text
prefix Text
msg = do
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case LogOutput
outputLoc of
        LogOutputFile String
path -> String -> Text -> IO ()
T.appendFile String
path Text
fmtMsg
        LogOutput
LogOutputStdOut -> Text -> IO ()
T.putStrLn Text
fmtMsg
        LogOutput
LogOutputStdErr -> Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr Text
fmtMsg
  where
    fmtMsg :: Text
fmtMsg = [Text] -> Text
T.unlines [Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line | Text
line <- Text -> [Text]
T.lines Text
msg]

-- ------------------------------------------------------------------------------------------------
-- Misc

data DaemonError
    = GenericError !T.Text
    | UpdateBindingError !T.Text
    | UpdateBreakListError !T.Text
    | BreakpointError !T.Text
    | UpdateContextError !T.Text
    deriving (DaemonError -> DaemonError -> Bool
(DaemonError -> DaemonError -> Bool)
-> (DaemonError -> DaemonError -> Bool) -> Eq DaemonError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DaemonError -> DaemonError -> Bool
== :: DaemonError -> DaemonError -> Bool
$c/= :: DaemonError -> DaemonError -> Bool
/= :: DaemonError -> DaemonError -> Bool
Eq, Int -> DaemonError -> ShowS
[DaemonError] -> ShowS
DaemonError -> String
(Int -> DaemonError -> ShowS)
-> (DaemonError -> String)
-> ([DaemonError] -> ShowS)
-> Show DaemonError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DaemonError -> ShowS
showsPrec :: Int -> DaemonError -> ShowS
$cshow :: DaemonError -> String
show :: DaemonError -> String
$cshowList :: [DaemonError] -> ShowS
showList :: [DaemonError] -> ShowS
Show)

{- | An IO operation that can fail into a DaemonError.
     Execute them to IO through 'run'.
-}
type DaemonIO r = ExceptT DaemonError IO r

-- | Convert Daemon operation to an IO operation.
run :: DaemonIO r -> IO (Either DaemonError r)
run :: forall r. DaemonIO r -> IO (Either DaemonError r)
run = ExceptT DaemonError IO r -> IO (Either DaemonError r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT