ghcitui 0.3.0.0 → 0.4.0.0
raw patch · 16 files changed
+973/−515 lines, 16 filesdep ~brickdep ~extradep ~string-interpolate
Dependency ranges changed: brick, extra, string-interpolate
Files
- CHANGELOG.md +51/−4
- MANUAL.rst +45/−0
- app/Main.hs +4/−1
- gen/MANUAL.txt +71/−30
- ghcitui.cabal +8/−4
- lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs +1/−0
- lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs +1/−1
- lib/ghcitui-brick/Ghcitui/Brick/AppState.hs +37/−12
- lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs +21/−1
- lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs +25/−8
- lib/ghcitui-brick/Ghcitui/Brick/EventUtils.hs +58/−0
- lib/ghcitui-brick/Ghcitui/Brick/Events.hs +44/−416
- lib/ghcitui-brick/Ghcitui/Brick/InterpWindowEvents.hs +269/−0
- lib/ghcitui-brick/Ghcitui/Brick/SourceWindowEvents.hs +201/−0
- lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs +102/−31
- lib/ghcitui-core/Ghcitui/Util.hs +35/−7
CHANGELOG.md view
@@ -1,8 +1,49 @@ # Revision history for ghcitui +## 0.4.0.0 -- 2024-11-15++### New features++- Interruptable expressions! This was a huge rework of the code. You can now press `Ctrl+c`+ and expression evaluation will be interrupted! Very handy for avoiding hanging.+ See [GitHub Issue #49](https://github.com/CrystalSplitter/ghcitui/issues/49) for details.++### API changes++Large overhaul in general, as GHCiTUI has moved to an async daemon scheduling model.++- **Ghcitui.Brick**+ - Introduction of the new `CustomAppEvent` to handle new event handling.+ - The `brickApp` now specifies a `CustomAppEvent`.+ - Moved event utils to `EventUtils.hs`+ - Separated out `Events.hs` into `InterpWindowEvents.hs` and `SourceWindowEvents.hs`.+ - Introduced the callback functions `handleSourceWindowPostCb` and `interpWindowPostCb`.+- **Ghcitui.Core**+ - Removed the `run` command as it was misleading in an asynchronous context. Replaced with+ `threadUnsafeRun`.+ - Added the `schedule` and `scheduleWithCb` functions, which mostly replace the intent+ of `run`, but work with async.+ - Added `interruptDaemon` to call the interrupt signal.+ - `emptyInterpreterState` now must be run under `IO`, as it must set up the lock.+ - Added `readyToExec` to check if the `ghci` handle lock is taken.++In general, lots of doc fixes.++### Bug fixes++- Fixed a bug where the module display wouldn't reveal the source in the `Source Window`.+ when there was only one module. See [GitHub Issue #48](https://github.com/CrystalSplitter/ghcitui/issues/48)+ for details.++### Known issues++See https://github.com/CrystalSplitter/ghcitui/issues for the latest issues.++- Inability to suspend operation through `Ctrl+z`.+ ## 0.3.0.0 -- 2024-03-17 -### API Changes+### API changes - **Ghcitui.Brick** - Large rework of SourceWindow's end calculation.@@ -18,13 +59,16 @@ See https://github.com/CrystalSplitter/ghcitui/issues for the latest issues. +- Unable to interrupt expressions (fixed in 0.4.0.0)+- Inability to suspend operation through `Ctrl+z`.+ ## 0.2.0.0 -- 2024-02-11 -### New Features+### New features - Rudimentary tab completion! (credit: https://github.com/bradrn) -### API Changes+### API changes - **Ghcitui.Brick** - Added functions to support tab completion.@@ -55,6 +99,8 @@ - Can't parse functions with apostrophes in names. (Issue #38) (fixed in 0.3.0.0) - Switching between files when updating contexts does not snap to the stopped line (Issue #41) (fixed in 0.3.0.0)+- Unable to interrupt expressions (fixed in 0.4.0.0)+- Inability to suspend operation through `Ctrl+z`. ## 0.1.0.0 -- 2024-01-21 @@ -83,6 +129,7 @@ - Occasionally we get a SEGV on start up. Uncertain why. Very infrequent--likely a race condition in Vty or GHCiD? - String variables which contain quotes are not parsed correctly.-- Unable to interrupt expressions (hopefully fixed in a future version?)+- Unable to interrupt expressions (fixed in 0.4.0.0) - Currently no remapping of keybindings or colours. - CRLF line endings don't work (fixed in 0.2.0.0)+- Inability to suspend operation through `Ctrl+z`.
MANUAL.rst view
@@ -50,6 +50,18 @@ $ ghcitui -C some/other/directory +You can specify a different starting command with ``--cmd <exec>`` or+``-c <exec>``.++.. code-block:: bash++ $ ghcitui -c 'ghci'+ $ ghcitui --cmd 'stack <args>'++This is handy if you don't want to use ``cabal repl``. Any executable can be+used with ``--cmd`` is that the underlying command communicates textually+through ``ghci``.+ ******** Stopping ********@@ -130,6 +142,7 @@ GHCi. - ``t``: Advance execution until next breakpoint under tracing. Same as ``:trace`` in GHCi.+- ``Ctrl+c``: Send an interrupt to the daemon. Useful for breaking infinite loops. *********************** Live Interpreter (REPL)@@ -148,6 +161,7 @@ panel size. - ``<Enter>``: Enter a command to the REPL. - ``<Tab>``: Autocomplete (yes there's basic autocomplete support)+- ``Ctrl+c``: Send an interrupt to the daemon. Useful for breaking infinite loops. ******* Modules@@ -160,6 +174,37 @@ - ``<Down>``, ``j``: Move the module selection down. - ``+``, ``-``: Increase/decrease the info panel size. - ``<Enter>``, ``o``: Open the selected module.++-------+Tracing+-------++Tracing works the same as in GHCi, but there's a panel to display the current+backtrace in the "Trace History" subpanel. To populate the Trace History panel,+run ``:trace`` in the Live Interpreter panel with a breakpoint set. For example:++.. code-block::++ $ cat Main.hs+ main = putStrLn "Hello" >> putStrLn "World!"++And then inside ghcitui...++.. code-block::++ # In the Live Interpreter Panel...++ ghci> :l Main.hs+ [1 of 2] Compiling Main ( Main.hs, interpreted )+ Ok, one module loaded+ ghci> :b main+ Breakpoint 0 activated at Main.hs:1:8-44+ ghci> :trace main+ Stopped in Main.main, Main.hs:1:8-44+ _result :: IO () = _+ ghci> :step++This should then populate the Trace History panel. ------------------------------- Reporting Bugs/Feature Requests
app/Main.hs view
@@ -96,5 +96,8 @@ GB.launchBrick conf (target opts) (workdir opts) where programName = "ghcitui"- programDescription = Opt.progDesc (programName <> ": A TUI interface for GHCi")+ programDescription = Opt.progDesc (+ programName <> ": A TUI interface for GHCi."+ <> "Press '?' while running for full help."+ ) parserInfo = Opt.info (Opt.helper <*> parseOpts) (Opt.fullDesc <> programDescription)
gen/MANUAL.txt view
@@ -19,8 +19,8 @@ STARTING AND STOPPING Starting- GHCiTUI runs a REPL in the current directory by default. By default,- it launches cabal repl.+ GHCiTUI runs a REPL in the current directory by default. By default, it+ launches cabal repl. $ cd your/cabal/project/root/directory $ ghcitui@@ -29,15 +29,25 @@ $ ghcitui -C some/other/directory + You can specify a different starting command with --cmd <exec> or -c+ <exec>.++ $ ghcitui -c 'ghci'+ $ ghcitui --cmd 'stack <args>'++ This is handy if you don't want to use cabal repl. Any executable can+ be used with --cmd is that the underlying command communicates textu‐+ ally through ghci.+ Stopping- To quit, press <ESC> or q while in the code viewport panel to quit.- While not in the code viewport panel, you may press <ESC> to get to- the viewport panel.+ To quit, press <ESC> or q while in the code viewport panel to quit.+ While not in the code viewport panel, you may press <ESC> to get to the+ viewport panel. LAYOUT- GHCiTUI is an in-terminal viewer for GHCi. The TUI is broken up into- three primary panels, with some additional auxiliary panels for spe‐- cial use cases:+ GHCiTUI is an in-terminal viewer for GHCi. The TUI is broken up into+ three primary panels, with some additional auxiliary panels for special+ use cases: ┌──────────────────┬──────┐ │ │ Info │@@ -51,35 +61,35 @@ │ │ │ └──────────────────┴──────┘ - Source Viewer: This panel shows source code. You can step, continue,+ Source Viewer: This panel shows source code. You can step, continue, and toggle breakpoints among other operations in this panel. - Live Interpreter: This panel shows the GHCi/REPL passthrough. You can- enter expressions and GHCi commands here like you would normally, with+ Live Interpreter: This panel shows the GHCi/REPL passthrough. You can+ enter expressions and GHCi commands here like you would normally, with some additional keybindings. - Info: This panel displays miscellaneous info about whatever is cur‐- rently running. For example, it can display the current bindings,+ Info: This panel displays miscellaneous info about whatever is cur‐+ rently running. For example, it can display the current bindings, loaded modules, and the current program trace. NAVIGATION- At any point in time, you can revert back to the Source Viewer panel- with the <Esc> key, and you can always quit by hitting <Esc> in the+ At any point in time, you can revert back to the Source Viewer panel+ with the <Esc> key, and you can always quit by hitting <Esc> in the Source Viewer panel. - On top of each panel is a label where the navigation key combination- is located. For example, the key combination above the Modules panel- displays [M]. Pressing this key combination will move the focus to- that panel.+ On top of each panel is a label where the navigation key combination is+ located. For example, the key combination above the Modules panel dis‐+ plays [M]. Pressing this key combination will move the focus to that+ panel. KEYBINDINGS- At this time, keybindings are hardcoded. This will hopefully change in+ At this time, keybindings are hardcoded. This will hopefully change in the future with a keybinding configuration file. Source Viewer • ?: Display help inside GHCiTUI. - • Ctrl+x: Toggle between the Source Viewer and the Live Interpreter+ • Ctrl+x: Toggle between the Source Viewer and the Live Interpreter panels. • M: Switch to the module panel.@@ -96,19 +106,22 @@ • +, -: Increase/decrease the left panel sizes. - • b: Toggle breakpoint at current line. Not every line in a source- file can have a breakpoint placed on it.+ • b: Toggle breakpoint at current line. Not every line in a source file+ can have a breakpoint placed on it. • s: Advance execution by one step. Same as the :step in GHCi. - • c: Advance execution until next breakpoint. Same as :continue in+ • c: Advance execution until next breakpoint. Same as :continue in GHCi. - • t: Advance execution until next breakpoint under tracing. Same as+ • t: Advance execution until next breakpoint under tracing. Same as :trace in GHCi. + • Ctrl+c: Send an interrupt to the daemon. Useful for breaking infinite+ loops.+ Live Interpreter (REPL)- • Ctrl+x: Toggle between the Source Viewer and the Live Interpreter+ • Ctrl+x: Toggle between the Source Viewer and the Live Interpreter panels. • <Esc>: Switch to Source Viewer.@@ -131,6 +144,9 @@ • <Tab>: Autocomplete (yes there's basic autocomplete support) + • Ctrl+c: Send an interrupt to the daemon. Useful for breaking infinite+ loops.+ Modules • ?: Display help inside GHCiTUI. @@ -146,11 +162,36 @@ • <Enter>, o: Open the selected module. +TRACING+ Tracing works the same as in GHCi, but there's a panel to display the+ current backtrace in the "Trace History" subpanel. To populate the+ Trace History panel, run :trace in the Live Interpreter panel with a+ breakpoint set. For example:++ $ cat Main.hs+ main = putStrLn "Hello" >> putStrLn "World!"++ And then inside ghcitui...++ # In the Live Interpreter Panel...++ ghci> :l Main.hs+ [1 of 2] Compiling Main ( Main.hs, interpreted )+ Ok, one module loaded+ ghci> :b main+ Breakpoint 0 activated at Main.hs:1:8-44+ ghci> :trace main+ Stopped in Main.main, Main.hs:1:8-44+ _result :: IO () = _+ ghci> :step++ This should then populate the Trace History panel.+ REPORTING BUGS/FEATURE REQUESTS- You can file bugs and feature requests both at:- https://github.com/CrystalSplitter/ghcitui/issues+ You can file bugs and feature requests both at:+ <https://github.com/CrystalSplitter/ghcitui/issues> - Please check to see if the bug/request already exists before filing a+ Please check to see if the bug/request already exists before filing a new one. - GHCITUI MANUAL()+ GHCITUI MANUAL()
ghcitui.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcitui-version: 0.3.0.0+version: 0.4.0.0 synopsis: A Terminal User Interface (TUI) for GHCi description:@@ -31,6 +31,7 @@ ||==9.4.7 ||==9.4.8 ||==9.8.1+ ||==9.8.2 extra-source-files: LICENSE , assets/splash.txt@@ -73,11 +74,11 @@ , containers >= 0.6.8 && < 0.8 , errors >= 2.2 && < 2.4 -- Needed to limit ghcid compat.- , extra >= 1.7.14 && < 1.8+ , extra >= 1.7.14 && < 1.9 , ghcid >= 0.8.8 && < 0.9 , regex-base ^>= 0.94.0.2 , regex-tdfa >= 1.3.2 && < 1.4- , string-interpolate ^>= 0.3.2.1+ , string-interpolate >= 0.3.2.1 && < 0.4 , text >= 2.0 && < 2.2 , transformers ^>= 0.6.1.0 -- Needed to limit string-interpolate compat.@@ -107,7 +108,7 @@ library ghcitui-brick hs-source-dirs: lib/ghcitui-brick build-depends: base >= 4.16 && < 5- , brick >= 2.2 && < 2.4+ , brick >= 2.2 && < 2.5 , containers , errors , file-embed ^>= 0.0.15@@ -127,8 +128,11 @@ , Ghcitui.Brick.BrickUI , Ghcitui.Brick.DrawSourceViewer , Ghcitui.Brick.Events+ , Ghcitui.Brick.EventUtils , Ghcitui.Brick.HelpText+ , Ghcitui.Brick.InterpWindowEvents , Ghcitui.Brick.SourceWindow+ , Ghcitui.Brick.SourceWindowEvents , Ghcitui.Brick.SplashTextEmbed ghc-options: -Wall -Wcompat
lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs view
@@ -46,6 +46,7 @@ } deriving (Show) +-- | Set up the default config for the App startup. defaultConfig :: AppConfig defaultConfig = AppConfig
lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs view
@@ -31,7 +31,7 @@ -- ^ The text currently typed into the editor, but not yet executed or in the history. , _cmdHistory :: ![[s]] , historyPos :: !Int- -- ^ Current position+ -- ^ Current position. } deriving (Show)
lib/ghcitui-brick/Ghcitui/Brick/AppState.hs view
@@ -27,9 +27,11 @@ , toggleBreakpointLine , updateSourceMap , writeDebugLog+ , daemonReadyToExec ) where import qualified Brick as B+import qualified Brick.BChan as B import qualified Brick.Widgets.Edit as BE import Control.Error (atMay, fromMaybe) import Control.Exception (IOException, try)@@ -45,8 +47,9 @@ import Ghcitui.Brick.AppConfig (AppConfig (..)) import qualified Ghcitui.Brick.AppConfig as AppConfig import qualified Ghcitui.Brick.AppInterpState as AIS-import Ghcitui.Brick.AppTopLevel (AppName (..))+import Ghcitui.Brick.AppTopLevel (AppName (..), CustomAppEvent) + import qualified Ghcitui.Brick.SourceWindow as SourceWindow import Ghcitui.Ghcid.Daemon (toggleBreakpointLine) import qualified Ghcitui.Ghcid.Daemon as Daemon@@ -80,6 +83,9 @@ data AppState n = AppState { interpState :: Daemon.InterpState () -- ^ The interpreter handle.+ , eventChannel :: !(B.BChan (CustomAppEvent (AppState n)))+ , waitingOnRepl :: !Bool+ -- ^ Wether we launched a long REPL command that we're waiting on. , getCurrentWorkingDir :: !FilePath -- ^ The current working directory. , _appInterpState :: AIS.AppInterpState T.Text n@@ -107,7 +113,6 @@ , splashContents :: !(Maybe T.Text) -- ^ Splash to show on start up. }- deriving (Show) newtype AppStateM m a = AppStateM {runAppStateM :: m a} @@ -148,18 +153,31 @@ selectedFile :: AppState n -> Maybe FilePath selectedFile = _selectedFile +daemonReadyToExec :: AppState n -> IO Bool+daemonReadyToExec appState = Daemon.readyToExec appState.interpState++-- | Change the selected file for the source window. setSelectedFile :: (MonadIO m) => Maybe FilePath -> AppState n -> m (AppState n) setSelectedFile mayFP appState = if mayFP == _selectedFile appState- then -- If we're selecting the same file again, do nothing.- pure appState+ then do+ -- If we're selecting the same file again, do nothing.+ let debugMsg =+ "not setting selected file to '"+ <> maybe "<Nothing>" T.pack mayFP+ <> "' because it is already set to it"+ pure $ writeDebugLog debugMsg appState else do -- Update the source map with the new file, and replace the window contents. updatedAppState <- liftIO $ updateSourceMap appState{_selectedFile = mayFP} let contents = mayFP >>= (sourceMap updatedAppState Map.!?) let elements = maybe Vec.empty (Vec.fromList . T.lines) contents let newSrcW = SourceWindow.srcWindowReplace elements (appState ^. sourceWindow)- pure updatedAppState{_sourceWindow = newSrcW}+ let debugMsg =+ "set selected file to '"+ <> maybe "<Nothing>" T.pack mayFP+ <> "'"+ pure . writeDebugLog debugMsg $ updatedAppState{_sourceWindow = newSrcW} -- ------------------------------------------------------------------------------------------------- -- State Line Details@@ -239,10 +257,11 @@ let logMsg = "updated source map with " <> T.pack filepath pure (writeDebugLog logMsg s{sourceMap = newSourceMap}) --- | Remove CR line endings.+-- | Remove CR line endings. Important for files checked in on Windows! stripCREndings :: T.Text -> T.Text stripCREndings = T.replace "\r" "" +-- | Return the internal mapping of module names to filepaths. listAvailableSources :: AppState n -> [(T.Text, FilePath)] listAvailableSources = Loc.moduleFileMapAssocs . Daemon.moduleFileMap . interpState @@ -303,11 +322,13 @@ :: AppConfig -- ^ Start up config. -> T.Text- -- ^ Daemon command prefix.+ -- ^ Daemon command suffix. -> FilePath -- ^ Workding directory.+ -> B.BChan (CustomAppEvent (AppState AppName))+ -- ^ Event channel to handle async with. -> IO (AppState AppName)-makeInitialState appConfig target cwd = do+makeInitialState appConfig target cwd chan = do let cwd' = if null cwd then "." else cwd let fullCmd = getCmd appConfig <> " " <> target let logOutput = case getDebugLogPath appConfig of@@ -320,8 +341,9 @@ { Daemon.logLevel = logLevel , Daemon.logOutput = logOutput }- interpState <-- Daemon.run (Daemon.startup (T.unpack fullCmd) cwd' startupConfig) >>= \case+ interpState <- do+ result <- Daemon.startup (T.unpack fullCmd) cwd' startupConfig+ case result of Right iState -> pure iState Left er -> error (show er) splashContents <- AppConfig.loadStartupSplash appConfig@@ -334,9 +356,12 @@ -- If we don't have a selected file, but we have a module loaded, -- select the last one. _ -> Nothing- updateSourceMap+ setSelectedFile+ selectedFile' AppState { interpState+ , eventChannel = chan+ , waitingOnRepl = False , getCurrentWorkingDir = cwd' , _appInterpState = AIS.emptyAppInterpState LiveInterpreter , activeWindow = ActiveCodeViewport@@ -344,7 +369,7 @@ , debugConsoleLogs = mempty , displayDebugConsoleLogs = getDebugConsoleOnStart appConfig , interpLogs = mempty- , _selectedFile = selectedFile'+ , _selectedFile = Nothing -- This will be overriden immediately. , _infoPanelSelectedModule = 0 , sourceMap = mempty , _currentWidgetSizes =
lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs view
@@ -1,5 +1,9 @@-module Ghcitui.Brick.AppTopLevel (AppName (..)) where+module Ghcitui.Brick.AppTopLevel (AppName (..), CustomAppEvent (..)) where +import qualified Data.Text as T++import qualified Ghcitui.Loc as Loc+ -- | Unique identifiers for components of the App. data AppName = GHCiTUI@@ -14,4 +18,20 @@ | TraceViewport | -- | Source Window Name. SourceList+ deriving (Eq, Show, Ord)++-- Aliases so it's easier to identify the names of++type AppEventCmd = T.Text+type AppEventLogs = [T.Text]+type AppEventPrefix = T.Text+type AppEventCompletions = [T.Text]++-- | Callback event types.+data CustomAppEvent state+ = ErrorOnCb state T.Text+ | StepCb state+ | BreakpointCb state Loc.ModuleLoc+ | ReplExecCb state AppEventCmd AppEventLogs+ | ReplTabCompleteCb state AppEventCmd (AppEventPrefix, AppEventCompletions) deriving (Eq, Show, Ord)
lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs view
@@ -7,6 +7,7 @@ ) where import qualified Brick as B+import qualified Brick.BChan as B import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Center as B import Brick.Widgets.Core ((<+>), (<=>))@@ -29,7 +30,7 @@ , makeInitialState ) import qualified Ghcitui.Brick.AppState as AppState-import Ghcitui.Brick.AppTopLevel (AppName (..))+import Ghcitui.Brick.AppTopLevel (AppName (..), CustomAppEvent) import qualified Ghcitui.Brick.DrawSourceViewer as DrawSourceViewer import qualified Ghcitui.Brick.Events as Events import qualified Ghcitui.Brick.HelpText as HelpText@@ -51,6 +52,12 @@ dialogMaxWidth :: (Integral a) => a dialogMaxWidth = 94 +maxSourceFilePathWidth :: (Integral a) => a+maxSourceFilePathWidth = 45++eventChannelSize :: (Integral a) => a+eventChannelSize = 10+ {- | Draw the dialog layer. If there's no dialog, returns an 'emptyWidget'.@@ -92,7 +99,11 @@ sourceLabel = markLabel (s.activeWindow == ActiveCodeViewport)- ( "Source: " <> maybe "?" T.pack (AppState.selectedFile s)+ ( "Source: "+ <> maybe+ "?"+ (Util.dropMiddleToFitText maxSourceFilePathWidth . T.pack)+ (AppState.selectedFile s) ) "[Esc]" interpreterLabel =@@ -158,12 +169,16 @@ . reverse $ s.interpLogs promptLine :: B.Widget AppName- promptLine =- B.txt (AppConfig.getInterpreterPrompt . AppState.appConfig $ s)- <+> BE.renderEditor displayF enableCursor (s ^. liveEditor)+ promptLine = promptWidget <+> BE.renderEditor displayF enableCursor (s ^. liveEditor) where+ promptWidget :: B.Widget AppName+ promptWidget =+ if AppState.waitingOnRepl s+ then B.emptyWidget+ else B.txt . AppConfig.getInterpreterPrompt . AppState.appConfig $ s displayF :: [T.Text] -> B.Widget AppName displayF t = B.vBox $ B.txt <$> t+ lockToBottomOnViewLock w = if s ^. appInterpState . AIS.viewLock then B.visible w@@ -290,7 +305,7 @@ -- ------------------------------------------------------------------------------------------------- -- | Brick main program.-brickApp :: B.App AppS e AppName+brickApp :: B.App AppS (CustomAppEvent AppS) AppName brickApp = B.App { B.appDraw = appDraw@@ -319,7 +334,9 @@ launchBrick conf target cwd = do T.putStrLn $ "Starting up GHCiTUI with: `" <> AppConfig.getCmd conf <> "`..." T.putStrLn "This can take a while..."- initialState <- makeInitialState conf target cwd- _ <- B.defaultMain brickApp initialState+ eventChan <- B.newBChan eventChannelSize+ initialState <- makeInitialState conf target cwd eventChan+ (_, vty) <- B.customMainWithDefaultVty (Just eventChan) brickApp initialState+ V.shutdown vty -- Got to shutdown the VTY separately, otherwise we get graphical glitches. T.putStrLn "GHCiTUI has shut down; have a nice day :)" pure ()
+ lib/ghcitui-brick/Ghcitui/Brick/EventUtils.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments #-}++module Ghcitui.Brick.EventUtils+ ( shortenText+ , commonPrefixes+ , reflowText+ , invalidateLineCache+ ) where++import qualified Brick.Main as B+import qualified Brick.Types as B++import Data.List (foldl')+import qualified Data.Text as T++-- | Limit text to a given length, and cut with an elipses.+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+ _ -> ""++-- TODO: Invalidate only the lines instead of the entire application.+invalidateLineCache :: (Ord n) => B.EventM n (state n) ()+invalidateLineCache = B.invalidateCache++{- | Reflow entries of text into columns.+ Mostly useful right now for printing autocomplete suggestions 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)
lib/ghcitui-brick/Ghcitui/Brick/Events.hs view
@@ -1,34 +1,45 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} module Ghcitui.Brick.Events (handleEvent, handleCursorPosition) where import qualified Brick.Main as B 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 import Lens.Micro ((^.)) import qualified Lens.Micro as Lens -import qualified Ghcitui.Brick.AppInterpState as AIS import Ghcitui.Brick.AppState as AppState import Ghcitui.Brick.AppTopLevel ( AppName (..)+ , CustomAppEvent (..) )+import Ghcitui.Brick.EventUtils (invalidateLineCache)+import qualified Ghcitui.Brick.InterpWindowEvents as InterpWindowEvents import qualified Ghcitui.Brick.SourceWindow as SourceWindow+import qualified Ghcitui.Brick.SourceWindowEvents as SourceWindowEvents import qualified Ghcitui.Ghcid.Daemon as Daemon-import qualified Ghcitui.Loc as Loc-import Ghcitui.Util (showT) -- | Handle any Brick event and update the state.-handleEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleEvent+ :: B.BrickEvent AppName (CustomAppEvent (AppState AppName))+ -- ^ Event to handle.+ -> B.EventM AppName (AppState AppName) () handleEvent (B.VtyEvent (V.EvResize _ _)) = B.invalidateCache+handleEvent (B.VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl])) = do+ -- Handle interrupts right away, regardless of our window.+ appState <- B.get+ liftIO . Daemon.interruptDaemon . AppState.interpState $ appState+ -- Invalidate everything.+ B.invalidateCache+handleEvent (B.AppEvent (ErrorOnCb appState msg)) =+ -- Handle errors cleanly and crash out.+ quit appState >> error (T.unpack msg)+handleEvent (B.AppEvent ev) = do+ SourceWindowEvents.handleSourceWindowPostCb ev+ InterpWindowEvents.handleInterpWindowPostCb ev handleEvent ev = do appState <- B.get updatedSourceWindow <- SourceWindow.updateVerticalSpace (appState ^. AppState.sourceWindow)@@ -36,8 +47,8 @@ B.put appStateUpdated let handler :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) () handler = case appStateUpdated.activeWindow of- AppState.ActiveCodeViewport -> handleSrcWindowEvent- AppState.ActiveLiveInterpreter -> handleInterpreterEvent+ AppState.ActiveCodeViewport -> SourceWindowEvents.handleSrcWindowEvent+ AppState.ActiveLiveInterpreter -> InterpWindowEvents.handleInterpreterEvent AppState.ActiveInfoWindow -> handleInfoEvent AppState.ActiveDialogQuit -> handleDialogQuit AppState.ActiveDialogHelp -> handleDialogHelp@@ -45,7 +56,7 @@ -- ------------------------------------------------------------------------------------------------- -- Info Event Handling-----------------------------------------------------------------------------------------------------+-- ------------------------------------------------------------------------------------------------- handleInfoEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) () handleInfoEvent ev = do@@ -82,410 +93,6 @@ B.invalidateCacheEntry ModulesViewport -- ---------------------------------------------------------------------------------------------------- Interpreter Event Handling--- ----------------------------------------------------------------------------------------------------- | Handle events when the interpreter (live GHCi) is selected.-handleInterpreterEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()-handleInterpreterEvent ev = do- appState <- B.get- 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)- let newAppState2 =- writeDebugLog ("Handled Enter: Ran '" <> cmd <> "'")- . Lens.set (appInterpState . AIS.viewLock) True- . 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- -- 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- B.VtyEvent (V.EvKey V.KEsc _) -> do- if not $ appState ^. appInterpState . AIS.viewLock- then -- Exit scroll mode first.- 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))- then storeCommandBuffer s- else s- let wDebug s =- writeDebugLog- ( "Handled Up; historyPos is "- <> (showT . AIS.historyPos . getAis $ s)- )- s- 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- 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'-- -- 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- B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Up- B.put (Lens.set (appInterpState . AIS.viewLock) False appState)- B.VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl]) -> do- -- Invert the viewLock.- B.put (Lens.over (appInterpState . AIS.viewLock) not appState)-- -- While scrolling (viewLock disabled), allow resizing the live interpreter history.- B.VtyEvent (V.EvKey (V.KChar '+') [])- | not (appState ^. appInterpState . AIS.viewLock) -> do- B.put (AppState.changeReplWidgetSize 1 appState)- B.VtyEvent (V.EvKey (V.KChar '-') [])- | not (appState ^. appInterpState . AIS.viewLock) -> do- B.put (AppState.changeReplWidgetSize (-1) appState)-- -- Actually handle keystrokes.- ev' -> do- -- When typing, bring us back down to the terminal.- 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--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.- Mostly useful right now for printing autocomplete suggestions 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)---- | Limit text to a given length, and cut with an elipses.-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- -- ^ 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)---- ---------------------------------------------------------------------------------------------------- Code Viewport Event Handling--- ----------------------------------------------------------------------------------------------------- TODO: Handle mouse events?-handleSrcWindowEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()-handleSrcWindowEvent (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 't' = do- appState <- B.get- newState <- Daemon.trace `runDaemon` appState- invalidateLineCache- B.put newState- | key == V.KChar 'b' = do- appState <- B.get- insertBreakpoint 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- scrollPage SourceWindow.Down- | key == V.KPageUp = do- scrollPage SourceWindow.Up-- -- '+' and '-' move the middle border.- | key == V.KChar '+' && null ms = do- appState <- B.get- B.put (AppState.changeInfoWidgetSize (-1) appState)- B.invalidateCacheEntry ModulesViewport- invalidateLineCache- | key == V.KChar '-' && null ms = do- appState <- B.get- B.put (AppState.changeInfoWidgetSize 1 appState)- B.invalidateCacheEntry ModulesViewport- invalidateLineCache- | key == V.KChar 'x' && ms == [V.MCtrl] =- B.put . toggleActiveLineInterpreter =<< B.get- | key == V.KChar 'M' = do- appState <- B.get- B.put appState{activeWindow = AppState.ActiveInfoWindow}- B.invalidateCacheEntry ModulesViewport- | key == V.KChar '?' = B.modify (\state -> state{activeWindow = AppState.ActiveDialogHelp})-handleSrcWindowEvent _ = pure ()--moveSelectedLineby :: Int -> B.EventM AppName (AppState AppName) ()-moveSelectedLineby movAmnt = do- appState <- B.get- let oldLineno = AppState.selectedLine appState- movedAppState <- do- sw <- SourceWindow.srcWindowMoveSelectionBy movAmnt (appState ^. AppState.sourceWindow)- pure $ Lens.set AppState.sourceWindow sw appState- let newLineno = AppState.selectedLine movedAppState- -- These two lines need to be re-rendered.- invalidateCachedLine oldLineno- invalidateCachedLine newLineno- B.put $ writeDebugLog ("Selected line is: " <> showT newLineno) movedAppState--scrollPage :: SourceWindow.ScrollDir -> B.EventM AppName (AppState AppName) ()-scrollPage dir = do- appState <- B.get- B.put- . (\srcW -> Lens.set AppState.sourceWindow srcW appState)- =<< SourceWindow.srcWindowScrollPage dir (appState ^. AppState.sourceWindow)- invalidateLineCache---- | Open up the quit dialog. See 'quit' for the actual quitting.-confirmQuit :: B.EventM AppName (AppState AppName) ()-confirmQuit = B.put . (\s -> s{activeWindow = AppState.ActiveDialogQuit}) =<< B.get--invalidateCachedLine :: Int -> B.EventM AppName s ()-invalidateCachedLine lineno = B.invalidateCacheEntry (SourceWindowLine lineno)--insertBreakpoint :: AppState AppName -> B.EventM AppName (AppState AppName) ()-insertBreakpoint appState =- case selectedModuleLoc appState of- Left err -> do- let selectedFileMsg = fromMaybe "<unknown>" (selectedFile appState)- let errMsg =- "Cannot find module of line: "- <> selectedFileMsg- <> ":"- <> show (selectedLine appState)- <> ": "- <> 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---- | Run a DaemonIO function on a given interpreter state, within an EventM monad.-runDaemon- :: (Ord n)- => (Daemon.InterpState () -> Daemon.DaemonIO (Daemon.InterpState ()))- -> AppState n- -> B.EventM n m (AppState n)-runDaemon f appState = do- interp <- liftIO $ do- (Daemon.run . f) appState.interpState >>= \case- Right out -> pure out- Left er -> error $ show er- selectPausedLine appState{interpState = interp}---- | Alternative to 'runDaemon' which returns a value along with the state.-runDaemon2- :: (Ord n)- => (Daemon.InterpState () -> Daemon.DaemonIO (Daemon.InterpState (), a))- -> AppState n- -> B.EventM n m (AppState n, a)-runDaemon2 f appState = do- (interp, x) <-- liftIO $- (Daemon.run . f) appState.interpState >>= \case- Right out -> pure out- Left er -> error $ show er- newState <- selectPausedLine appState{interpState = interp}- pure (newState, x)---- | Determine whether to show the cursor.-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 == AppState.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 selectedFile s 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---- ------------------------------------------------------------------------------------------------- -- Dialog boxes -- ------------------------------------------------------------------------------------------------- @@ -517,3 +124,24 @@ -- | Stop the TUI. quit :: AppState n -> B.EventM n s () quit appState = liftIO (Daemon.quit appState.interpState) >> B.halt++-- -------------------------------------------------------------------------------------------------+-- Handle Cursor Position+-- -------------------------------------------------------------------------------------------------++-- | Determine whether to show the cursor.+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 == AppState.ActiveLiveInterpreter+ then -- If we're in the interpreter window, show the cursor.+ B.showCursorNamed widgetName ls+ else -- No cursor+ Nothing+ where+ widgetName = LiveInterpreter
+ lib/ghcitui-brick/Ghcitui/Brick/InterpWindowEvents.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}++module Ghcitui.Brick.InterpWindowEvents+ ( handleInterpreterEvent+ , handleInterpWindowPostCb+ ) where++import qualified Brick.BChan as B+import qualified Brick.Main as B+import qualified Brick.Types as B+import qualified Brick.Widgets.Edit as BE+import Control.Error (atDef, lastDef)+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 Ghcitui.Brick.AppInterpState as AIS+import Ghcitui.Brick.AppState as AppState+import Ghcitui.Brick.AppTopLevel+ ( AppName (..)+ , CustomAppEvent (..)+ )+import Ghcitui.Brick.EventUtils+ ( commonPrefixes+ , reflowText+ )+import qualified Ghcitui.Ghcid.Daemon as Daemon+import Ghcitui.Util (showT)++-- -------------------------------------------------------------------------------------------------+-- Interpreter Event Handling+-- -------------------------------------------------------------------------------------------------++-- | Handle events when the interpreter (live GHCi/REPL) is selected.+handleInterpreterEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleInterpreterEvent ev = do+ appState <- B.get+ case ev of+ B.VtyEvent (V.EvKey V.KEnter []) -> do+ let cmd = T.strip (T.unlines (editorContents appState))+ let finishedState = appState{waitingOnRepl = False}+ let callback = replExecCb cmd finishedState+ -- While the command is running, put write some temporary confirmation that the command+ -- was run to the logs.+ B.put+ . appendToLogs mempty cmd+ . replaceCommandBuffer ""+ $ appState{waitingOnRepl = True}+ B.invalidateCache+ -- Actually schedule the command.+ let interpState = AppState.interpState appState+ liftIO $+ Daemon.scheduleWithCb interpState (Daemon.execCleaned cmd interpState) callback+ B.VtyEvent (V.EvKey (V.KChar '\t') []) -> do+ -- We want to preserve spaces, but not trailing newlines.+ let cmd = T.dropWhileEnd ('\n' ==) . T.unlines . editorContents $ appState+ let callback = tabCompleteCb cmd appState+ let interpState = AppState.interpState appState+ B.put appState+ -- Schedule the tab completion.+ liftIO $+ Daemon.scheduleWithCb interpState (Daemon.tabComplete cmd interpState) callback+ B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->+ -- Toggle out of the interpreter.+ leaveInterpreter+ B.VtyEvent (V.EvKey V.KEsc _) -> do+ if not $ appState ^. appInterpState . AIS.viewLock+ then -- Exit scroll mode first.+ 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))+ then storeCommandBuffer s+ else s+ let wDebug s =+ writeDebugLog+ ( "handled Up; historyPos is "+ <> (showT . AIS.historyPos . getAis $ s)+ )+ s+ 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+ 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'++ -- 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+ B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Up+ B.put (Lens.set (appInterpState . AIS.viewLock) False appState)+ B.VtyEvent (V.EvKey (V.KChar 'n') [V.MCtrl]) -> do+ -- Invert the viewLock.+ B.put (Lens.over (appInterpState . AIS.viewLock) not appState)++ -- While scrolling (viewLock disabled), allow resizing the live interpreter history.+ B.VtyEvent (V.EvKey (V.KChar '+') [])+ | not (appState ^. appInterpState . AIS.viewLock) -> do+ B.put (AppState.changeReplWidgetSize 1 appState)+ B.VtyEvent (V.EvKey (V.KChar '-') [])+ | not (appState ^. appInterpState . AIS.viewLock) -> do+ B.put (AppState.changeReplWidgetSize (-1) appState)++ -- Actually handle keystrokes.+ ev' ->+ if waitingOnRepl appState+ then+ -- Don't print a prompt if we're waiting.+ pure ()+ else do+ -- When typing, bring us back down to the terminal.+ 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++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++-- | 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)++-- -------------------------------------------------------------------------------------------------+-- Callbacks and Callback utils+-- -------------------------------------------------------------------------------------------------++-- | Live Interpreter/REPL Callback. Called asynchronously after the 'DaemonIO' resolves.+replExecCb+ :: T.Text+ -- ^ Command sent and ran on the Daemon.+ -> AppState n+ -- ^ 'AppState' to use for asynchronous channel communication.+ -> Either Daemon.DaemonError (Daemon.InterpState (), [T.Text])+ -- ^ The incoming response from the Daemon for the 'step' (or similar) operation.+ -> IO ()+ -- ^ IO used to write to the event bounded channel.+replExecCb cmd appState (Right (interpState, logs)) =+ B.writeBChan (AppState.eventChannel appState) (ReplExecCb appState{interpState} cmd logs)+replExecCb _ appState (Left msg) =+ B.writeBChan (AppState.eventChannel appState) (ErrorOnCb appState (showT msg))++tabCompleteCb+ :: T.Text+ -- ^ Partial command to get completion of.+ -> AppState n+ -> Either Daemon.DaemonError (Daemon.InterpState (), (T.Text, [T.Text]))+ -> IO ()+tabCompleteCb cmd appState (Right (interpState, (prefix, completions))) =+ B.writeBChan+ (AppState.eventChannel appState)+ (ReplTabCompleteCb appState{interpState} cmd (prefix, completions))+tabCompleteCb _ appState (Left msg) =+ B.writeBChan (AppState.eventChannel appState) (ErrorOnCb appState (showT msg))++-- | Synchronous code to update the state after a InterpreterEvent callback.+handleInterpWindowPostCb+ :: CustomAppEvent (AppState AppName) -> B.EventM AppName (AppState AppName) ()+handleInterpWindowPostCb (ReplExecCb appState cmd newLogs) = do+ let newEditor =+ BE.applyEdit+ (T.killToEOF . T.gotoBOF)+ (appState ^. liveEditor)+ let newAppState2 =+ writeDebugLog ("handled Enter: Ran '" <> cmd <> "'")+ . Lens.set (appInterpState . AIS.viewLock) True+ . Lens.over appInterpState (AIS.pushHistory [cmd])+ $ appendToLogs newLogs cmd appState+ 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+handleInterpWindowPostCb (ReplTabCompleteCb appState cmd (prefix, completions)) = do+ 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+ $ appState+-- For all other AppEvent types, ignore them. They're handled elsewhere.+handleInterpWindowPostCb _ = pure ()
+ lib/ghcitui-brick/Ghcitui/Brick/SourceWindowEvents.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Ghcitui.Brick.SourceWindowEvents (handleSrcWindowEvent, handleSourceWindowPostCb) where++import qualified Brick.Main as B+import qualified Brick.Types as B+import Control.Error (fromMaybe, note)+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Lens.Micro ((^.))+import qualified Lens.Micro as Lens++import qualified Brick.BChan as B+import Ghcitui.Brick.AppState as AppState+import Ghcitui.Brick.AppTopLevel+ ( AppName (..)+ , CustomAppEvent (..)+ )+import Ghcitui.Brick.EventUtils+import qualified Ghcitui.Brick.SourceWindow as SourceWindow+import qualified Ghcitui.Ghcid.Daemon as Daemon+import qualified Ghcitui.Loc as Loc+import Ghcitui.Util (showT)++-- -------------------------------------------------------------------------------------------------+-- Code Viewport Event Handling+-- -------------------------------------------------------------------------------------------------++-- TODO: Handle mouse events?+handleSrcWindowEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleSrcWindowEvent (B.VtyEvent (V.EvKey key ms))+ | key `elem` [V.KChar 'q', V.KEsc] = do+ confirmQuit++ -- GHCi Blocking Events.+ | key == V.KChar 's' = do+ appState@AppState.AppState{AppState.interpState} <- B.get+ let callback = stepCb appState+ liftIO $ Daemon.scheduleWithCb interpState (Daemon.step interpState) callback+ | key == V.KChar 'c' = do+ appState@AppState.AppState{AppState.interpState} <- B.get+ let callback = stepCb appState+ liftIO $ Daemon.scheduleWithCb interpState (Daemon.step interpState) callback+ | key == V.KChar 't' = do+ appState@AppState.AppState{AppState.interpState} <- B.get+ let callback = stepCb appState+ liftIO $ Daemon.scheduleWithCb interpState (Daemon.trace interpState) callback+ | key == V.KChar 'b' = do+ appState <- B.get+ insertBreakpoint 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+ scrollPage SourceWindow.Down+ | key == V.KPageUp = do+ scrollPage SourceWindow.Up++ -- '+' and '-' move the middle border.+ | key == V.KChar '+' && null ms = do+ appState <- B.get+ B.put (AppState.changeInfoWidgetSize (-1) appState)+ B.invalidateCacheEntry ModulesViewport+ invalidateLineCache+ | key == V.KChar '-' && null ms = do+ appState <- B.get+ B.put (AppState.changeInfoWidgetSize 1 appState)+ B.invalidateCacheEntry ModulesViewport+ invalidateLineCache+ | key == V.KChar 'x' && ms == [V.MCtrl] =+ B.put . toggleActiveLineInterpreter =<< B.get+ | key == V.KChar 'M' = do+ appState <- B.get+ B.put appState{activeWindow = AppState.ActiveInfoWindow}+ B.invalidateCacheEntry ModulesViewport+ | key == V.KChar '?' = B.modify (\state -> state{activeWindow = AppState.ActiveDialogHelp})+handleSrcWindowEvent _ = pure ()++{- | Redraw Step Callback. Called asynchronously after the 'DaemonIO' resolves+ for 'step' and similar.+-}+stepCb+ :: AppState n+ -- ^ 'AppState' to use for asynchronous channel communication.+ -> Either Daemon.DaemonError (Daemon.InterpState ())+ -- ^ The incoming response from the Daemon for the 'step' (or similar) operation.+ -> IO ()+ -- ^ IO used to write to the event bounded channel.+stepCb appState (Right interpState) =+ B.writeBChan (AppState.eventChannel appState) (StepCb appState{interpState})+stepCb appState (Left msg) =+ B.writeBChan (AppState.eventChannel appState) (ErrorOnCb appState (showT msg))++breakpointCb+ :: Loc.ModuleLoc+ -> AppState n+ -> Either Daemon.DaemonError (Daemon.InterpState ())+ -> IO ()+breakpointCb moduleLoc appState (Right interpState) =+ B.writeBChan+ (AppState.eventChannel appState)+ (BreakpointCb appState{interpState} moduleLoc)+breakpointCb _ appState (Left msg) =+ B.writeBChan (AppState.eventChannel appState) (ErrorOnCb appState (showT msg))++-- | Synchronous code to update the state after a SourceWindowEvent callback.+handleSourceWindowPostCb+ :: CustomAppEvent (AppState AppName) -> B.EventM AppName (AppState AppName) ()+handleSourceWindowPostCb (StepCb appState) = do+ B.put =<< AppState.selectPausedLine appState+ invalidateLineCache+handleSourceWindowPostCb (BreakpointCb appState moduleLoc) = do+ let interpState = AppState.interpState appState+ -- 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 moduleLoc) of+ Just (lineno, _colrange) ->+ invalidateCachedLine lineno+ _ ->+ -- If we don't know, just invalidate everything.+ invalidateLineCache+ B.put appState{interpState}+-- For all other AppEvent types, ignore them. They're handled elsewhere.+handleSourceWindowPostCb _ = pure ()++moveSelectedLineby :: Int -> B.EventM AppName (AppState AppName) ()+moveSelectedLineby movAmnt = do+ appState <- B.get+ let oldLineno = AppState.selectedLine appState+ movedAppState <- do+ sw <- SourceWindow.srcWindowMoveSelectionBy movAmnt (appState ^. AppState.sourceWindow)+ pure $ Lens.set AppState.sourceWindow sw appState+ let newLineno = AppState.selectedLine movedAppState+ -- These two lines need to be re-rendered.+ invalidateCachedLine oldLineno+ invalidateCachedLine newLineno+ B.put $ writeDebugLog ("selected line is: " <> showT newLineno) movedAppState++scrollPage :: SourceWindow.ScrollDir -> B.EventM AppName (AppState AppName) ()+scrollPage dir = do+ appState <- B.get+ B.put+ . (\srcW -> Lens.set AppState.sourceWindow srcW appState)+ =<< SourceWindow.srcWindowScrollPage dir (appState ^. AppState.sourceWindow)+ invalidateLineCache++-- | Open up the quit dialog. See 'quit' for the actual quitting.+confirmQuit :: B.EventM AppName (AppState AppName) ()+confirmQuit = B.put . (\s -> s{activeWindow = AppState.ActiveDialogQuit}) =<< B.get++invalidateCachedLine :: Int -> B.EventM AppName s ()+invalidateCachedLine lineno = B.invalidateCacheEntry (SourceWindowLine lineno)++insertBreakpoint :: AppState AppName -> B.EventM AppName (AppState AppName) ()+insertBreakpoint appState =+ case selectedModuleLoc appState of+ Left err -> do+ let selectedFileMsg = fromMaybe "<unknown>" (selectedFile appState)+ let errMsg =+ "Cannot find module of line: "+ <> selectedFileMsg+ <> ":"+ <> show (selectedLine appState)+ <> ": "+ <> T.unpack err+ liftIO $ fail errMsg+ Right ml -> do+ let interpState = AppState.interpState appState+ let daemonOp = Daemon.toggleBreakpointLine (Daemon.ModLoc ml) interpState+ let callback = breakpointCb ml appState+ liftIO $+ Daemon.scheduleWithCb+ interpState+ daemonOp+ callback++-- | 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 selectedFile s 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
lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs view
@@ -23,6 +23,19 @@ , StartupConfig (..) , quit + -- * Daemon running types++ -- | These types are used for restricting concurrent operations and forcing error handling.+ , DaemonIO+ , DaemonError++ -- * Running operations++ -- | For running 'DaemonIO' operations.+ , schedule+ , scheduleWithCb+ , threadUnsafeRun+ -- * Base operations with the daemon , exec , execCleaned@@ -50,13 +63,13 @@ -- * Misc , isExecuting+ , readyToExec , BreakpointArg (..)- , run- , DaemonIO- , DaemonError+ , interruptDaemon , LogOutput (..) ) where +import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, takeMVar, isEmptyMVar) import Control.Error import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..))@@ -76,9 +89,13 @@ import Ghcitui.Util (showT) import qualified Ghcitui.Util as Util +type GhciHandle = Ghcid.Ghci+ data InterpState a = InterpState- { _ghci :: !Ghcid.Ghci+ { _ghci :: !GhciHandle -- ^ GHCiD handle.+ , _ghciLock :: !(MVar ())+ -- ^ Lock for single-threaded GHCi operations. , func :: !(Maybe T.Text) -- ^ Current pause position function name. , pauseLoc :: !(Maybe Loc.FileLoc)@@ -118,22 +135,25 @@ {- | Create an empty/starting interpreter state. Usually you don't want to call this directly. Instead use 'startup'. -}-emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> StartupConfig -> InterpState a-emptyInterpreterState ghci startupConfig =- InterpState- { _ghci = ghci- , func = Nothing- , pauseLoc = Nothing- , moduleFileMap = mempty- , stack = mempty- , breakpoints = mempty- , bindings = Right mempty- , status = Right mempty- , logLevel = StartupConfig.logLevel startupConfig- , logOutput = StartupConfig.logOutput startupConfig- , execHist = mempty- , traceHist = mempty- }+emptyInterpreterState :: (Monoid a) => GhciHandle -> StartupConfig -> IO (InterpState a)+emptyInterpreterState ghci startupConfig = do+ ghciLock <- newMVar ()+ pure $+ InterpState+ { _ghci = ghci+ , _ghciLock = ghciLock+ , func = Nothing+ , pauseLoc = Nothing+ , moduleFileMap = mempty+ , stack = mempty+ , breakpoints = mempty+ , bindings = Right mempty+ , status = Right mempty+ , logLevel = StartupConfig.logLevel startupConfig+ , logOutput = StartupConfig.logOutput startupConfig+ , execHist = mempty+ , traceHist = mempty+ } -- | Reset anything context-based in a 'InterpState'. contextReset :: (Monoid a) => InterpState a -> InterpState a@@ -151,11 +171,21 @@ appendExecHist :: T.Text -> InterpState a -> InterpState a appendExecHist cmd s@InterpState{execHist} = s{execHist = cmd : execHist} --- | Is the daemon currently in the middle of an expression evaluation?+{- | Is the daemon currently in the middle of an expression evaluation, but paused?+ Note, this does not indicate whether there's a scheduled 'DaemonIO' operation,+ but rather just indicates whether we have stopped at a breakpoint in the middle+ of evaluation.++ Use 'readyToExec' if you want to query the state of the actual underlying handle.+-} isExecuting :: InterpState a -> Bool isExecuting InterpState{func = Nothing} = False isExecuting InterpState{func = Just _} = True +-- | Is the GHCi lock busy?+readyToExec :: InterpState a -> IO Bool+readyToExec s = isEmptyMVar (_ghciLock s)+ -- | Start up the GHCi Daemon. startup :: String@@ -164,16 +194,19 @@ -- ^ Working directory to run the start up command in. -> StartupConfig -- ^ Where do we put the logging?- -> DaemonIO (InterpState ())+ -> IO (Either DaemonError (InterpState ())) -- ^ The newly created interpreter handle. startup cmd wd logOutput = do -- We don't want any highlighting or colours. let realCmd = "env TERM='dumb' " <> cmd- let startOp = Ghcid.startGhci realCmd (Just wd) startupStreamCallback- (ghci, _) <- liftIO startOp- let state = emptyInterpreterState ghci logOutput+ state <- liftIO $ do+ (ghci, _) <- Ghcid.startGhci realCmd (Just wd) startupStreamCallback+ emptyInterpreterState ghci logOutput logDebug "|startup| GHCi Daemon initted" state- updateState state+ _ <- takeMVar (_ghciLock state)+ updatedState <- threadUnsafeRun $ updateState state+ _ <- putMVar (_ghciLock state) ()+ pure updatedState startupStreamCallback :: Ghcid.Stream -> String -> IO () startupStreamCallback stream msg = do@@ -323,7 +356,7 @@ load filepath = execMuted (T.pack $ ":load " <> filepath) {- | Return tab completions for a given prefix.- Analog to @:complete repl "<prefix>"@+ Analogue to @:complete repl "\<prefix\>"@ See https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#ghci-cmd-:complete -} tabComplete@@ -559,10 +592,48 @@ deriving (Eq, Show) {- | An IO operation that can fail into a DaemonError.- Execute them to IO through 'run'.+ Execute them synchronously in IO through 'threadUnsafeRun'.+ Execute them asynchronously in IO through 'schedule'.+ Execute them with a callback with 'scheduleWithCb' -} type DaemonIO r = ExceptT DaemonError IO r --- | Convert Daemon operation to an IO operation.-run :: DaemonIO r -> IO (Either DaemonError r)-run = runExceptT+{- | Convert Daemon operation to an IO operation. NOT THREAD SAFE.++ Prefer 'schedule' or 'scheduleWithCb' in a multithreaded context.+-}+threadUnsafeRun :: DaemonIO r -> IO (Either DaemonError r)+threadUnsafeRun = runExceptT++{- | Schedule execution of this 'DaemonIO' operation, with the result being stored in the MVar.++ This function is a thread safe way to run 'DaemonIO' operations.+-}+schedule :: InterpState a -> DaemonIO r -> IO (MVar (Either DaemonError r))+schedule state daemonIO = do+ opResultVar <- newEmptyMVar+ _ <- forkIO $ do+ _ <- takeMVar (_ghciLock state)+ result <- threadUnsafeRun daemonIO+ _ <- putMVar (_ghciLock state) ()+ putMVar opResultVar result+ pure opResultVar++{- | Schedule execution of this Daemon IO operation, and run a callback with the result.+ 'scheduleWithCb' is very common throughout the ghcitui source code, as it primarily+ allows inter-thread communication through the use of callbacks.++ This function is a thread safe way to run 'DaemonIO' operations.+-}+scheduleWithCb :: InterpState a -> DaemonIO r -> (Either DaemonError r -> IO ()) -> IO ()+scheduleWithCb state daemonIO callback = do+ _ <- forkIO $ do+ _ <- takeMVar (_ghciLock state)+ result <- threadUnsafeRun daemonIO+ _ <- putMVar (_ghciLock state) ()+ callback result+ pure ()++-- | Stop the currently executing process in the daemon.+interruptDaemon :: InterpState a -> IO ()+interruptDaemon InterpState{_ghci} = Ghcid.interrupt _ghci
lib/ghcitui-core/Ghcitui/Util.hs view
@@ -1,7 +1,16 @@-module Ghcitui.Util (showT, splitBy, linesToText, clamp, getNumDigits, formatDigits) where+module Ghcitui.Util+ ( showT+ , splitBy+ , linesToText+ , clamp+ , getNumDigits+ , formatDigits+ , dropMiddleToFitText+ , revealNewlines+ ) where -import Data.Text (Text, breakOn, drop, length, pack)-import Prelude hiding (drop, length)+import Data.Text (Text, breakOn, drop, length, pack, replace, take, takeEnd)+import Prelude hiding (drop, length, take) -- | Split text based on a delimiter. splitBy@@ -24,7 +33,7 @@ showT :: (Show a) => a -> Text showT = pack . show --- Return the number of digits in a given integral+-- | Return the number of digits in a given integral getNumDigits :: (Integral a) => a -> Int getNumDigits 0 = 1 getNumDigits num = truncate (logBase 10 (fromIntegral num) :: Double) + 1@@ -44,12 +53,31 @@ clamp :: (Ord a) => (a, a)- -- ^ The minimum and maximum (inclusive)+ -- ^ The minimum and maximum (inclusive). -> a- -- ^ Value to clamp+ -- ^ Value to clamp. -> a- -- ^ Result+ -- ^ Result. clamp (mi, mx) v | v < mi = mi | v > mx = mx | otherwise = v++-- | Remove the inner characters of a Text to fit within a maximum width.+dropMiddleToFitText+ :: Int+ -- ^ Maximum length to trim to.+ -> Text+ -- ^ Text to shorten.+ -> Text+ -- ^ Result.+dropMiddleToFitText w text+ | length text <= w = text+ | otherwise = prefix <> "…" <> suffix+ where+ halfWidth = fromIntegral (w - 1) / 2.0 :: Float+ prefix = take (floor halfWidth) text+ suffix = takeEnd (ceiling halfWidth) text++revealNewlines :: Text -> Text+revealNewlines = replace "\n" "↓"