{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE QuasiQuotes #-}
module Ghcitui.Ghcid.Daemon
(
InterpState
( func
, pauseLoc
, moduleFileMap
, breakpoints
, bindings
, logLevel
, logOutput
, execHist
, traceHist
)
, emptyInterpreterState
, startup
, StartupConfig (..)
, quit
, exec
, execCleaned
, execMuted
, step
, stepInto
, load
, continue
, getBpInCurModule
, getBpInFile
, toggleBreakpointLine
, setBreakpointLine
, deleteBreakpointLine
, trace
, history
, tabComplete
, 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
, forall a. InterpState a -> Maybe Text
func :: !(Maybe T.Text)
, forall a. InterpState a -> Maybe FileLoc
pauseLoc :: !(Maybe Loc.FileLoc)
, forall a. InterpState a -> ModuleFileMap
moduleFileMap :: !Loc.ModuleFileMap
, forall a. InterpState a -> [Text]
stack :: ![T.Text]
, forall a. InterpState a -> [(Int, ModuleLoc)]
breakpoints :: ![(Int, Loc.ModuleLoc)]
, forall a. InterpState a -> Either DaemonError [NameBinding Text]
bindings :: !(Either DaemonError [NameBinding.NameBinding T.Text])
, forall a. InterpState a -> Either Text a
status :: !(Either T.Text a)
, forall a. InterpState a -> LogLevel
logLevel :: !LogLevel
, forall a. InterpState a -> LogOutput
logOutput :: !LogOutput
, forall a. InterpState a -> [Text]
execHist :: ![T.Text]
, forall a. InterpState a -> [Text]
traceHist :: ![T.Text]
}
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
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
}
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
}
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}
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
startup
:: String
-> FilePath
-> StartupConfig
-> DaemonIO (InterpState ())
startup :: String -> String -> StartupConfig -> DaemonIO (InterpState ())
startup String
cmd String
wd StartupConfig
logOutput = do
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)
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
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
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}
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
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
}
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}|]
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}
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"
stepInto
:: (Monoid a)
=> T.Text
-> InterpState a
-> ExceptT DaemonError IO (InterpState a)
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)
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
(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
(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)
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"
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"
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)
tabComplete
:: (Monoid a)
=> T.Text
-> InterpState a
-> DaemonIO (InterpState a, (T.Text, [T.Text]))
tabComplete :: forall a.
Monoid a =>
Text -> InterpState a -> DaemonIO (InterpState a, (Text, [Text]))
tabComplete Text
providedPrefix InterpState a
state = do
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))
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
(
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)
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
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))
data BreakpointArg
=
LocalLine !Int
|
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)
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|]
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)
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) =
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
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}|])
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
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 :: (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)
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
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
-> T.Text
-> T.Text
-> 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]
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)
type DaemonIO r = ExceptT DaemonError IO r
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