Implement tab completion

This provides the GHCi Repl inside GHCiTUI with basic tab completion.
This is slightly more advanced than the standard GHCi tab completion,
but not by much.

This commit also moves around some error and parsing code to help
in this effort.

Co-authored-by: CrystalSplitter <crystal@crystalwobsite.gay>

ghcitui.cabal

@@ -82,6 +82,8 @@ library
     exposed-modules:    Ghcitui.Ghcid.Daemon
                         , Ghcitui.Ghcid.LogConfig
                         , Ghcitui.Ghcid.ParseContext
+                        , Ghcitui.Ghcid.ParseError
+                        , Ghcitui.Ghcid.ParseTabCompletions
                         , Ghcitui.Loc
                         , Ghcitui.NameBinding
                         , Ghcitui.Util

lib/ghcitui-brick/Ghcitui/Brick/Events.hs

@@ -9,6 +9,7 @@ import qualified Brick.Types as B
 import qualified Brick.Widgets.Edit as BE
 import Control.Error (atDef, fromMaybe, lastDef, note)
 import Control.Monad.IO.Class (MonadIO (..))
+import Data.List (foldl')
 import qualified Data.Text as T
 import qualified Data.Text.Zipper as T
 import qualified Graphics.Vty as V
@@ -89,39 +90,57 @@ handleInterpreterEvent ev = do
     case ev of
         B.VtyEvent (V.EvKey V.KEnter []) -> do
             let cmd = T.strip (T.unlines (editorContents appState))
-
             -- Actually run the command.
             (newAppState1, output) <- runDaemon2 (Daemon.execCleaned cmd) appState
-
             let newEditor =
                     BE.applyEdit
                         (T.killToEOF . T.gotoBOF)
                         (appState ^. liveEditor)
-            -- TODO: Should be configurable?
-            let interpreterLogLimit = 1000
-            let formattedWithPrompt = appState.appConfig.getInterpreterPrompt <> cmd
-            let combinedLogs = reverse output <> (formattedWithPrompt : interpLogs appState)
             let newAppState2 =
                     writeDebugLog ("Handled Enter: Ran '" <> cmd <> "'")
                         . Lens.set (appInterpState . AIS.viewLock) True
-                        . Lens.over appInterpState (AIS.pushHistory (editorContents appState))
-                        $ newAppState1
-                            { interpLogs =
-                                take interpreterLogLimit combinedLogs
-                            }
+                        . Lens.over appInterpState (AIS.pushHistory [cmd])
+                        $ appendToLogs output cmd newAppState1
             let appStateFinalIO = updateSourceMap (Lens.set liveEditor newEditor newAppState2)
             B.put =<< liftIO appStateFinalIO
             -- Invalidate the entire render state of the application
             -- because we don't know what's actually changed here now.
             B.invalidateCache
         B.VtyEvent (V.EvKey (V.KChar '\t') []) -> do
-            -- Tab completion?
-            let cmd = T.strip (T.unlines (editorContents appState))
-            (newAppState1, _output) <-
-                runDaemon2
-                    (Daemon.execCleaned (":complete " <> cmd))
-                    appState
-            B.put newAppState1
+            -- We want to preserve spaces, but not trailing newlines.
+            let cmd = T.dropWhileEnd ('\n' ==) . T.unlines . editorContents $ appState
+            -- Tab completion expects input to be 'show'n in quotes.
+            -- There's probably a better way of doing this!
+            (newAppState, (prefix, completions)) <- runDaemon2 (Daemon.tabComplete cmd) appState
+            let maxCompletionLen = maximum $ T.length <$> completions
+            let columnPadding = 1
+            extent <-
+                B.lookupExtent LiveInterpreterViewport >>= \case
+                    Just e -> pure e
+                    Nothing -> error "Could not find extent of LiveInterpreterViewport"
+            let interpWidth = fst . B.extentSize $ extent
+            let completionColWidth = min (interpWidth - 2) maxCompletionLen + columnPadding
+            let numCols = interpWidth `div` completionColWidth
+            let updateCompletions cs s = case cs of
+                    -- Only one completion, just replace the entire buffer with it.
+                    [c] -> replaceCommandBuffer (prefix <> c <> " ") s
+                    -- No completions. Just go to a new prompt.
+                    [] -> appendToLogs [] cmd s
+                    -- Replace the buffer with the longest possible prefix among options, and
+                    -- print the remaining.
+                    _ ->
+                        replaceCommandBuffer (prefix <> commonPrefixes cs)
+                            . appendToLogs (reflowText numCols completionColWidth cs) cmd
+                            $ s
+            B.put
+                . writeDebugLog
+                    ( "Handled Tab, Prefix was: '"
+                        <> cmd
+                        <> "' Completions were: "
+                        <> showT completions
+                    )
+                . updateCompletions completions
+                $ newAppState
         B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->
             -- Toggle out of the interpreter.
             leaveInterpreter
@@ -131,6 +150,8 @@ handleInterpreterEvent ev = do
                     B.put (Lens.set (appInterpState . AIS.viewLock) True appState)
                 else -- Also toggle out of the interpreter.
                     leaveInterpreter
+
+        -- Selecting previous commands.
         B.VtyEvent (V.EvKey V.KUp _) -> do
             let maybeStoreBuffer s =
                     if not (AIS.isScanningHist (getAis s))
@@ -162,6 +183,8 @@ handleInterpreterEvent ev = do
                         . Lens.over appInterpState AIS.futHistoryPos -- Go forward in time.
                         $ appState
             B.put appState'
+
+        -- Scrolling back through the logs.
         B.VtyEvent (V.EvKey V.KPageDown _) ->
             B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Down
         B.VtyEvent (V.EvKey V.KPageUp _) -> do
@@ -204,6 +227,59 @@ handleInterpreterEvent ev = do
       where
         cmd = T.unlines . getCommandAtHist (AIS.historyPos _appInterpState) $ s
 
+appendToLogs
+    :: [T.Text]
+    -- ^ Logs between commands.
+    -> T.Text
+    -- ^ The command sent to produce the logs.
+    -> AppState n
+    -- ^ State to update.
+    -> AppState n
+    -- ^ Updated state.
+appendToLogs logs promptEntry state = state{interpLogs = take interpreterLogLimit combinedLogs}
+  where
+    combinedLogs = reverse logs <> (formattedWithPrompt : interpLogs state)
+    formattedWithPrompt = getInterpreterPrompt (appConfig state) <> promptEntry
+    -- TODO: Should be configurable?
+    interpreterLogLimit = 1000
+
+-- | Reflow entries of text into columns.
+reflowText
+    :: Int
+    -- ^ Num columns
+    -> Int
+    -- ^ Column width
+    -> [T.Text]
+    -- ^ Text entries to reflow
+    -> [T.Text]
+    -- ^ Reflowed lines.
+reflowText numCols colWidth = go
+  where
+    go :: [T.Text] -> [T.Text]
+    go [] = []
+    go entries' = makeLine toMakeLine : go rest
+      where
+        (toMakeLine, rest) = splitAt numCols entries'
+    maxTextLen = colWidth - 1
+    makeLine xs = T.concat (T.justifyLeft colWidth ' ' . shortenText maxTextLen <$> xs)
+
+shortenText :: Int -> T.Text -> T.Text
+shortenText maxLen text
+    | len <= maxLen = text
+    | otherwise = T.take (maxLen - 1) text <> "…"
+  where
+    len = T.length text
+
+-- | Return the shared prefix among all the input Texts.
+commonPrefixes :: [T.Text] -> T.Text
+commonPrefixes [] = ""
+commonPrefixes (t : ts) = foldl' folder t ts
+  where
+    folder :: T.Text -> T.Text -> T.Text
+    folder acc t' = case T.commonPrefixes acc t' of
+        Just (p, _, _) -> p
+        _ -> ""
+
 -- | Replace the command buffer with the given strings of Text.
 replaceCommandBuffer
     :: T.Text

lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs

@@ -45,6 +45,9 @@ module Ghcitui.Ghcid.Daemon
     , trace
     , history
 
+      -- * Tab completion
+    , tabComplete
+
       -- * Misc
     , isExecuting
     , BreakpointArg (..)
@@ -65,6 +68,7 @@ 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
@@ -318,6 +322,31 @@ trace = execMuted ":trace"
 load :: (Monoid a) => FilePath -> InterpState a -> DaemonIO (InterpState a)
 load filepath = execMuted (T.pack $ ":load " <> 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 providedPrefix state = do
+    -- Tab completion expects input to be 'show'n in quotes.
+    -- There's probably a better way of doing this!
+    let escapedPrefix = Util.showT providedPrefix
+    let cmd = ":complete repl " <> escapedPrefix
+    (newState, outputLines) <- execCleaned cmd state
+    (prefix, completions) <- case ParseTabCompletions.parseCompletionsWithHeader outputLines of
+        Right c -> pure c
+        Left (ParseTabCompletions.ParseError er) -> throwE (GenericError er)
+    pure (newState, (prefix, 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'.
@@ -353,6 +382,10 @@ execCleaned cmd state = do
   where
     cleaner (s, ls) = (s, T.lines (ParseContext.cleanResponse ls))
 
+-- ------------------------------------------------------------------------------------------------
+-- Breakpoint handling
+-- ------------------------------------------------------------------------------------------------
+
 -- | Location info passed to breakpoint functions.
 data BreakpointArg
     = -- | Location in the current file.
@@ -382,7 +415,9 @@ toggleBreakpointLine loc state
             ModLoc ml -> handleModLoc ml
 
     invalidLoc :: Loc.ModuleLoc -> Either DaemonError a
-    invalidLoc ml = Left $ BreakpointError [i|Cannot locate breakpoint position '#{ml}' in module without source|]
+    invalidLoc ml =
+        Left $
+            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)

lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs

@@ -27,6 +27,7 @@ import qualified Data.Text as T
 import Text.Regex.TDFA (MatchResult (..), (=~~))
 import qualified Text.Regex.TDFA as Regex
 
+import Ghcitui.Ghcid.ParseError (ParseError (..)) -- Re-export.
 import qualified Ghcitui.Loc as Loc
 import Ghcitui.NameBinding
 import Ghcitui.Util
@@ -34,8 +35,6 @@ import Ghcitui.Util
 ghcidPrompt :: T.Text
 ghcidPrompt = "#~GHCID-START~#"
 
-newtype ParseError = ParseError T.Text deriving (Show, Eq)
-
 -- | Output record datatype for 'parseContext'.
 data ParseContextOut = ParseContextOut
     { func :: !T.Text

lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs

@@ -0,0 +1,6 @@
+module Ghcitui.Ghcid.ParseError (ParseError (..)) where
+
+import qualified Data.Text as T
+
+-- | Type to describe parsing errors.
+newtype ParseError = ParseError T.Text deriving (Show, Eq)

lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Ghcitui.Ghcid.ParseTabCompletions (ParseError (..), parseCompletionsWithHeader) where
+
+import Control.Error (readMay)
+import Data.Array ((!))
+import Data.String.Interpolate (i)
+import qualified Data.Text as T
+import Text.Regex.TDFA (MatchResult (..), (=~~))
+
+import Ghcitui.Ghcid.ParseError (ParseError (..)) -- Re-export.
+
+{- | Parse a completion result which begins with a header.
+
+    Example input:
+    [ "4 4 \"hello \""
+    , "\"world\""
+    , "\"wyvern\""
+    , "\"withers\""
+    , "\"wonderbolts\""]
+
+    See https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#ghci-cmd-:complete
+-}
+parseCompletionsWithHeader
+    :: [T.Text]
+    -- ^ Full :complete output to parse.
+    -> Either ParseError (T.Text, [T.Text])
+    -- ^ Failure message (Left) or Completion possibilities (Right)
+parseCompletionsWithHeader (headerLine : rest) = do
+    sharedPrefix <- eSharedPrefix
+    completions <- parseCompletions rest
+    pure (sharedPrefix, completions)
+  where
+    eSharedPrefix = case (headerLine =~~ reg :: Maybe (MatchResult T.Text)) of
+        Just match -> Right (mrSubs match ! 1)
+        Nothing -> Left $ ParseError [i|Failed to parse ':complete' header line: '#{headerLine}'|]
+    reg = ".* \"(.*)\"$" :: T.Text
+parseCompletionsWithHeader _ = Left $ ParseError "Failed to parse completions with no header line"
+
+parseCompletions
+    :: [T.Text]
+    -- ^ Completion lines.
+    -> Either ParseError [T.Text]
+    -- ^ Completion possibilities.
+parseCompletions = mapM mapper
+  where
+    mapper x =
+        maybe
+            (Left $ ParseError [i|Failed to parse ':completion' entry '#{x}'|])
+            (Right . T.pack)
+            (readMay . T.unpack $ x)