From aa440ae072ca3dffab6fc2efb96b141de9d944dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 25 Jan 2023 20:23:28 +0100
Subject: GDB command completion and history

---
 src/GDB.hs    | 21 +++++++++++++++++----
 src/Output.hs | 19 +++++++++++++------
 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
-- 
cgit v1.2.3