mirror of
https://github.com/CrystalSplitter/ghcitui.git
synced 2024-10-26 19:11:28 +03:00
6339be9b46
This is just to prevent further naming conflict confusions between AIS.history and Ghcid.Daemon.trace.
346 lines
14 KiB
Haskell
346 lines
14 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
module Events (handleEvent, handleCursorPosition) where
|
|
|
|
import qualified Brick.Main as B
|
|
import qualified Brick.Types as B
|
|
import qualified Brick.Util as B
|
|
import qualified Brick.Widgets.Edit as BE
|
|
import Control.Error (atDef, fromMaybe, lastDef, note)
|
|
import Control.Monad.IO.Class (MonadIO (..))
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Zipper as T
|
|
import qualified Graphics.Vty as V
|
|
import Lens.Micro ((^.))
|
|
import qualified Lens.Micro as Lens
|
|
|
|
import qualified AppInterpState as AIS
|
|
import AppState
|
|
import AppTopLevel
|
|
( AppName (..)
|
|
)
|
|
import qualified Ghcid.Daemon as Daemon
|
|
import qualified Loc
|
|
import Util (showT)
|
|
|
|
-- | Handle any Brick event and update the state.
|
|
handleEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
|
handleEvent ev = do
|
|
appState <- B.get
|
|
case appState.activeWindow of
|
|
ActiveCodeViewport -> handleViewportEvent ev
|
|
ActiveLiveInterpreter -> handleInterpreterEvent ev
|
|
_ -> pure ()
|
|
|
|
-- -------------------------------------------------------------------------------------------------
|
|
-- Interpreter Event Handling
|
|
-- -------------------------------------------------------------------------------------------------
|
|
|
|
-- | Handle events when the interpreter (live GHCi) is selected.
|
|
handleInterpreterEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
|
handleInterpreterEvent ev =
|
|
case ev of
|
|
B.VtyEvent (V.EvKey V.KEnter []) -> do
|
|
appState <- B.get
|
|
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
|
|
}
|
|
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?
|
|
appState <- B.get
|
|
let cmd = T.strip (T.unlines (editorContents appState))
|
|
(newAppState1, _output) <-
|
|
runDaemon2
|
|
(Daemon.execCleaned (":complete " <> cmd))
|
|
appState
|
|
B.put newAppState1
|
|
B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->
|
|
-- Toggle out of the interpreter.
|
|
leaveInterpreter
|
|
B.VtyEvent (V.EvKey V.KEsc _) ->
|
|
-- Also toggle out of the interpreter.
|
|
leaveInterpreter
|
|
B.VtyEvent (V.EvKey V.KUp _) -> do
|
|
let maybeStoreBuffer s =
|
|
if not (AIS.isScanningHist (getAis s))
|
|
then storeCommandBuffer s
|
|
else s
|
|
let wDebug s =
|
|
writeDebugLog
|
|
( "Handled Up; historyPos is "
|
|
<> (showT . AIS.historyPos . getAis $ s)
|
|
)
|
|
s
|
|
appState <- B.get
|
|
let appState' =
|
|
wDebug
|
|
. replaceCommandBufferWithHist -- Display the history.
|
|
. Lens.over appInterpState AIS.pastHistoryPos -- Go back in time.
|
|
. maybeStoreBuffer -- Store the buffer if we're not scanning already.
|
|
$ appState
|
|
B.put appState'
|
|
B.VtyEvent (V.EvKey V.KDown _) -> do
|
|
appState <- B.get
|
|
let wDebug s =
|
|
writeDebugLog
|
|
( "Handled Down; historyPos is "
|
|
<> (showT . AIS.historyPos . getAis $ s)
|
|
)
|
|
s
|
|
let appState' =
|
|
wDebug
|
|
. replaceCommandBufferWithHist -- Display the history.
|
|
. Lens.over appInterpState AIS.futHistoryPos -- Go forward in time.
|
|
$ appState
|
|
B.put appState'
|
|
B.VtyEvent (V.EvKey V.KPageDown _) ->
|
|
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Down
|
|
B.VtyEvent (V.EvKey V.KPageUp _) -> do
|
|
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Up
|
|
appState <- B.get
|
|
B.put (Lens.set (appInterpState . AIS.viewLock) False appState)
|
|
ev' -> do
|
|
appState <- B.get
|
|
B.put (Lens.set (appInterpState . AIS.viewLock) True appState)
|
|
-- Actually handle text input commands.
|
|
B.zoom liveEditor' $ BE.handleEditorEvent ev'
|
|
where
|
|
editorContents appState = BE.getEditContents $ appState ^. liveEditor'
|
|
storeCommandBuffer appState =
|
|
Lens.set (appInterpState . AIS.commandBuffer) (editorContents appState) appState
|
|
getAis s = s ^. appInterpState
|
|
getCommandAtHist :: Int -> AppState n -> [T.Text]
|
|
getCommandAtHist i s
|
|
| i <= 0 = s ^. appInterpState . AIS.commandBuffer
|
|
| otherwise = atDef (lastDef [] hist) hist (i - 1)
|
|
where
|
|
hist = s ^. appInterpState . Lens.to AIS.cmdHistory
|
|
|
|
leaveInterpreter = B.put . toggleActiveLineInterpreter =<< B.get
|
|
|
|
replaceCommandBufferWithHist :: AppState n -> AppState n
|
|
replaceCommandBufferWithHist s@AppState{_appInterpState} = replaceCommandBuffer cmd s
|
|
where
|
|
cmd = T.unlines . getCommandAtHist (AIS.historyPos _appInterpState) $ s
|
|
|
|
-- | Replace the command buffer with the given strings of Text.
|
|
replaceCommandBuffer
|
|
:: T.Text
|
|
-- ^ Text to replace with.
|
|
-> AppState n
|
|
-- ^ State to modify.
|
|
-> AppState n
|
|
-- ^ New state.
|
|
replaceCommandBuffer replacement s = Lens.set liveEditor' newEditor s
|
|
where
|
|
zipp :: T.TextZipper T.Text -> T.TextZipper T.Text
|
|
zipp = T.killToEOF . T.insertMany replacement . T.gotoBOF
|
|
newEditor = BE.applyEdit zipp (s ^. liveEditor')
|
|
|
|
-- -------------------------------------------------------------------------------------------------
|
|
-- Viewport Event Handling
|
|
-- -------------------------------------------------------------------------------------------------
|
|
|
|
-- TODO: Handle mouse events?
|
|
handleViewportEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
|
handleViewportEvent (B.VtyEvent (V.EvKey key ms))
|
|
| key `elem` [V.KChar 'q', V.KEsc] = do
|
|
confirmQuit
|
|
| key == V.KChar 's' = do
|
|
appState <- B.get
|
|
newState <- Daemon.step `runDaemon` appState
|
|
invalidateLineCache
|
|
B.put newState
|
|
| key == V.KChar 'c' = do
|
|
appState <- B.get
|
|
newState <- Daemon.continue `runDaemon` appState
|
|
invalidateLineCache
|
|
B.put newState
|
|
| key == V.KChar 'b' = do
|
|
appState <- B.get
|
|
insertViewportBreakpoint appState
|
|
-- j and k are the vim navigation keybindings.
|
|
| key `elem` [V.KDown, V.KChar 'j'] = do
|
|
moveSelectedLineBy 1
|
|
| key `elem` [V.KUp, V.KChar 'k'] = do
|
|
moveSelectedLineBy (-1)
|
|
| key == V.KPageDown = do
|
|
appState <- B.get
|
|
mViewport <- B.lookupViewport CodeViewport
|
|
let oldSelectedLine = selectedLine appState
|
|
let getViewportBot viewport = B._vpTop viewport + snd (B._vpSize viewport)
|
|
let newSelectedLine = case mViewport of
|
|
-- Need the + 1 due to one-indexing.
|
|
Just viewport ->
|
|
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
|
in B.clamp 1 lineCount (getViewportBot viewport + 1)
|
|
Nothing -> oldSelectedLine
|
|
invalidateCachedLine oldSelectedLine
|
|
invalidateCachedLine newSelectedLine
|
|
B.put appState{selectedLine = newSelectedLine}
|
|
let scroller = B.viewportScroll CodeViewport
|
|
B.vScrollPage scroller B.Down
|
|
| key == V.KPageUp = do
|
|
appState <- B.get
|
|
mViewport <- B.lookupViewport CodeViewport
|
|
let oldSelectedLine = selectedLine appState
|
|
let newSelectedLine = case mViewport of
|
|
Just viewport ->
|
|
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
|
in B.clamp 1 lineCount (B._vpTop viewport)
|
|
Nothing -> oldSelectedLine
|
|
invalidateCachedLine oldSelectedLine
|
|
invalidateCachedLine newSelectedLine
|
|
B.put appState{selectedLine = newSelectedLine}
|
|
let scroller = B.viewportScroll CodeViewport
|
|
B.vScrollPage scroller B.Up
|
|
| key == V.KChar 'x' && ms == [V.MCtrl] =
|
|
B.put . toggleActiveLineInterpreter =<< B.get
|
|
handleViewportEvent _ = pure ()
|
|
|
|
moveSelectedLineBy :: Int -> B.EventM AppName (AppState n) ()
|
|
moveSelectedLineBy movAmnt = do
|
|
appState <- B.get
|
|
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
|
let oldLineno = selectedLine appState
|
|
let newLineno = B.clamp 1 lineCount (oldLineno + movAmnt)
|
|
let newState = appState{selectedLine = newLineno}
|
|
-- These two lines need to be re-rendered.
|
|
invalidateCachedLine oldLineno
|
|
invalidateCachedLine newLineno
|
|
B.put newState
|
|
|
|
-- TODO: Actually confirm using a dialogue. This is a little tricky,
|
|
-- as we may need to store the dialogue structure in the app state.
|
|
-- For now, just quit cleanly.
|
|
confirmQuit :: B.EventM AppName (AppState AppName) ()
|
|
confirmQuit = do
|
|
appState <- B.get
|
|
_ <- liftIO $ Daemon.quit appState.interpState
|
|
B.halt
|
|
|
|
invalidateCachedLine :: Int -> B.EventM AppName s ()
|
|
invalidateCachedLine lineno = B.invalidateCacheEntry (CodeViewportLine lineno)
|
|
|
|
insertViewportBreakpoint :: AppState AppName -> B.EventM AppName (AppState AppName) ()
|
|
insertViewportBreakpoint appState =
|
|
case selectedModuleLoc appState of
|
|
Left err -> do
|
|
let selectedFileMsg = fromMaybe "<unknown>" appState.selectedFile
|
|
let errMsg =
|
|
"Cannot find module of line: "
|
|
<> selectedFileMsg
|
|
<> ":"
|
|
<> show appState.selectedLine
|
|
<> ": "
|
|
<> T.unpack err
|
|
liftIO $ fail errMsg
|
|
Right ml -> do
|
|
let daemonOp = Daemon.toggleBreakpointLine (Daemon.ModLoc ml) appState.interpState
|
|
interpState <-
|
|
liftIO $ do
|
|
eNewState <- Daemon.run daemonOp
|
|
case eNewState of
|
|
Right out -> pure out
|
|
Left er -> error $ show er
|
|
-- We may need to be smarter about this,
|
|
-- because there's a chance that the module loc 'ml'
|
|
-- doesn't actually refer to this viewed file?
|
|
case Loc.singleify (Loc.sourceRange ml) of
|
|
Just (lineno, _colrange) ->
|
|
invalidateCachedLine lineno
|
|
_ ->
|
|
-- If we don't know, just invalidate everything.
|
|
invalidateLineCache
|
|
B.put appState{interpState}
|
|
|
|
-- TODO: Invalidate only the lines instead of the entire application.
|
|
invalidateLineCache :: (Ord n) => B.EventM n (state n) ()
|
|
invalidateLineCache = B.invalidateCache
|
|
|
|
runDaemon
|
|
:: (MonadIO m)
|
|
=> (Daemon.InterpState () -> Daemon.DaemonIO (Daemon.InterpState ()))
|
|
-> AppState n
|
|
-> m (AppState n)
|
|
runDaemon f appState =
|
|
liftIO $ do
|
|
interp <-
|
|
(Daemon.run . f) appState.interpState >>= \case
|
|
Right out -> pure out
|
|
Left er -> error $ show er
|
|
newState <- updateSourceMap appState{interpState = interp}
|
|
pure (resetSelectedLine newState)
|
|
|
|
runDaemon2
|
|
:: (MonadIO m)
|
|
=> (Daemon.InterpState () -> Daemon.DaemonIO (Daemon.InterpState (), a))
|
|
-> AppState n
|
|
-> m (AppState n, a)
|
|
runDaemon2 f appState =
|
|
liftIO $ do
|
|
(interp, x) <-
|
|
(Daemon.run . f) appState.interpState >>= \case
|
|
Right out -> pure out
|
|
Left er -> error $ show er
|
|
newState <- updateSourceMap appState{interpState = interp}
|
|
pure (resetSelectedLine newState, x)
|
|
|
|
handleCursorPosition
|
|
:: AppState AppName
|
|
-- ^ State of the app.
|
|
-> [B.CursorLocation AppName]
|
|
-- ^ Potential Locs
|
|
-> Maybe (B.CursorLocation AppName)
|
|
-- ^ The chosen cursor location if any.
|
|
handleCursorPosition s ls =
|
|
if s.activeWindow == ActiveLiveInterpreter
|
|
then -- If we're in the interpreter window, show the cursor.
|
|
B.showCursorNamed widgetName ls
|
|
else -- No cursor
|
|
Nothing
|
|
where
|
|
widgetName = LiveInterpreter
|
|
|
|
-- | Get Location that's currently selected.
|
|
selectedModuleLoc :: AppState n -> Either T.Text Loc.ModuleLoc
|
|
selectedModuleLoc s = eModuleLoc =<< fl
|
|
where
|
|
sourceRange = Loc.srFromLineNo (selectedLine s)
|
|
fl = case s.selectedFile of
|
|
Nothing -> Left "No selected file to get module of"
|
|
Just x -> Right (Loc.FileLoc x sourceRange)
|
|
eModuleLoc x =
|
|
let moduleFileMap = Daemon.moduleFileMap (interpState s)
|
|
res = Loc.toModuleLoc moduleFileMap x
|
|
errMsg =
|
|
"No matching module found for '"
|
|
<> showT x
|
|
<> "' because moduleFileMap was '"
|
|
<> showT moduleFileMap
|
|
<> "'"
|
|
in note errMsg res
|