summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-01-25 20:23:28 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-01-25 20:23:28 +0100
commitaa440ae072ca3dffab6fc2efb96b141de9d944dd (patch)
tree9be8beb9beb86c9084a6d2627fa231a02df5756f
parent29b263f350ea7dccb243ec28f6af7fc5c41f578e (diff)
GDB command completion and history
-rw-r--r--src/GDB.hs21
-rw-r--r--src/Output.hs19
2 files changed, 30 insertions, 10 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index 3c60457..ad8ff84 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -22,6 +22,7 @@ import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
+import System.Console.Haskeline.Completion
import System.Process
import Output
@@ -163,10 +164,14 @@ addInferior gdb process = do
gdbCommand gdb $ "-target-attach --thread-group " <> tgid <> " " <> T.pack (show pid)
gdbCommand gdb $ "-exec-continue --thread-group " <> tgid
+gdbCommandRes :: MonadIO m => GDB -> Text -> m (ResultClass, [(Text, MiValue)])
+gdbCommandRes gdb cmd = do
+ send (gdbProcess gdb) cmd
+ liftIO (takeMVar (gdbResult gdb))
+
gdbCommand :: MonadOutput m => GDB -> Text -> m ()
gdbCommand gdb cmd = do
- send (gdbProcess gdb) cmd
- liftIO (takeMVar (gdbResult gdb)) >>= \case
+ gdbCommandRes gdb cmd >>= \case
(Done, _) -> return ()
(Connected, _) -> outProc OutputChildInfo (gdbProcess gdb) "result connected"
(Error, _) -> outProc OutputError (gdbProcess gdb) $ "command error: " <> cmd
@@ -175,13 +180,21 @@ gdbCommand gdb cmd = do
gdbSession :: MonadOutput m => GDB -> m ()
gdbSession gdb = loop ""
where
- loop prev = outPromptGetLine "gdb> " >>= \case
+ loop prev = outPromptGetLineCompletion (gdbCompletion gdb) "gdb> " >>= \case
Just line -> do
let cmd = if T.null line then prev else line
gdbCommand gdb ("-interpreter-exec console \"" <> cmd <> "\"")
loop cmd
Nothing -> return ()
+gdbCompletion :: GDB -> CompletionFunc IO
+gdbCompletion gdb (revcmd, _) = do
+ gdbCommandRes gdb ("-complete " <> T.pack (show (reverse revcmd))) >>= \case
+ (Done, resp)
+ | Just (MiList matches) <- lookup "matches" resp -> do
+ return ("", map (\(MiString m) -> Completion (T.unpack m) (T.unpack m) False) matches)
+ _ -> return ("", [])
+
type MiParser = ParsecT Void MiStream Identity
@@ -199,7 +212,7 @@ miOutputRecord = choice
]
miResultRecord :: MiParser MiRecord
-miResultRecord = char '^' >> ResultRecord <$> resultClass <*> many result
+miResultRecord = char '^' >> ResultRecord <$> resultClass <*> many (char ',' *> result)
miExecAsync, miStatusAsync, miNotifyAsync :: MiParser MiRecord
miExecAsync = char '*' >> ExecAsyncOutput <$> miString <*> many (char ',' *> result)
diff --git a/src/Output.hs b/src/Output.hs
index 412e7b4..8c913b2 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -6,6 +6,7 @@ module Output (
startOutput,
outLine,
outPromptGetLine,
+ outPromptGetLineCompletion,
) where
import Control.Concurrent.MVar
@@ -18,6 +19,7 @@ import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
import System.Console.Haskeline
+import System.Console.Haskeline.History
data Output = Output
{ outState :: MVar OutputState
@@ -29,8 +31,8 @@ data OutputConfig = OutputConfig
}
data OutputState = OutputState
- { outCurPrompt :: Maybe Text
- , outPrint :: TL.Text -> IO ()
+ { outPrint :: TL.Text -> IO ()
+ , outHistory :: History
}
data OutputType = OutputChildStdout
@@ -51,7 +53,7 @@ instance MonadIO m => MonadOutput (ReaderT Output m) where
startOutput :: Bool -> IO Output
startOutput verbose = Output
- <$> newMVar OutputState { outCurPrompt = Nothing, outPrint = TL.putStrLn }
+ <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
<*> pure OutputConfig { outVerbose = verbose }
outColor :: OutputType -> Text
@@ -104,13 +106,18 @@ outLine otype prompt line = ioWithOutput $ \out ->
]
outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
-outPromptGetLine prompt = ioWithOutput $ \out -> do
+outPromptGetLine = outPromptGetLineCompletion noCompletion
+
+outPromptGetLineCompletion :: MonadOutput m => CompletionFunc IO -> Text -> m (Maybe Text)
+outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do
st <- takeMVar (outState out)
- (x, st') <- runInputT defaultSettings $ do
+ (x, st') <- runInputT (setComplete compl defaultSettings) $ do
p <- getExternalPrint
+ putHistory $ outHistory st
liftIO $ putMVar (outState out) st { outPrint = p . TL.unpack . (<>"\n") }
x <- getInputLine $ T.unpack prompt
st' <- liftIO $ takeMVar (outState out)
- return (x, st' { outPrint = outPrint st })
+ hist' <- getHistory
+ return (x, st' { outPrint = outPrint st, outHistory = hist' })
putMVar (outState out) st'
return $ fmap T.pack x