From e1f38caa3c4aa03ce6486c84c7796f7937ace214 Mon Sep 17 00:00:00 2001 From: Brad Neimann Date: Sat, 3 Feb 2024 20:00:58 +1100 Subject: [PATCH] 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 --- ghcitui.cabal | 2 + lib/ghcitui-brick/Ghcitui/Brick/Events.hs | 112 +++++++++++++++--- lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs | 37 +++++- .../Ghcitui/Ghcid/ParseContext.hs | 3 +- lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs | 6 + .../Ghcitui/Ghcid/ParseTabCompletions.hs | 51 ++++++++ 6 files changed, 190 insertions(+), 21 deletions(-) create mode 100644 lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs create mode 100644 lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs diff --git a/ghcitui.cabal b/ghcitui.cabal index 41f23fb..33c2c08 100644 --- a/ghcitui.cabal +++ b/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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/Events.hs b/lib/ghcitui-brick/Ghcitui/Brick/Events.hs index 421bb2a..a253f27 100644 --- a/lib/ghcitui-brick/Ghcitui/Brick/Events.hs +++ b/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 diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs b/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs index 22799fa..03fa8de 100644 --- a/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs +++ b/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 ""@ + 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) diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs b/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs index 6dddc25..483fa7c 100644 --- a/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs +++ b/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 diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs b/lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs new file mode 100644 index 0000000..813939a --- /dev/null +++ b/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) diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs b/lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs new file mode 100644 index 0000000..5981647 --- /dev/null +++ b/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)