diff options
| -rw-r--r-- | src/GDB.hs | 21 | ||||
| -rw-r--r-- | src/Output.hs | 19 |
2 files changed, 30 insertions, 10 deletions
@@ -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 |