mirror of
https://github.com/CrystalSplitter/ghcitui.git
synced 2024-09-11 10:55:29 +03:00
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>
This commit is contained in:
parent
4344d0988c
commit
e1f38caa3c
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
6
lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs
Normal file
6
lib/ghcitui-core/Ghcitui/Ghcid/ParseError.hs
Normal file
@ -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)
|
51
lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs
Normal file
51
lib/ghcitui-core/Ghcitui/Ghcid/ParseTabCompletions.hs
Normal file
@ -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)
|
Loading…
Reference in New Issue
Block a user