diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/MANUAL.rst b/MANUAL.rst --- a/MANUAL.rst +++ b/MANUAL.rst @@ -50,6 +50,18 @@ $ ghcitui -C some/other/directory +You can specify a different starting command with ``--cmd `` or +``-c ``. + +.. code-block:: bash + + $ ghcitui -c 'ghci' + $ ghcitui --cmd 'stack ' + +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 a command to the REPL. - ````: 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 @@ - ````, ``j``: Move the module selection down. - ``+``, ``-``: Increase/decrease the info panel size. - ````, ``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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/gen/MANUAL.txt b/gen/MANUAL.txt --- a/gen/MANUAL.txt +++ b/gen/MANUAL.txt @@ -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 or -c + . + + $ ghcitui -c 'ghci' + $ ghcitui --cmd 'stack ' + + 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 or q while in the code viewport panel to quit. - While not in the code viewport panel, you may press to get to - the viewport panel. + To quit, press or q while in the code viewport panel to quit. + While not in the code viewport panel, you may press 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 key, and you can always quit by hitting in the + At any point in time, you can revert back to the Source Viewer panel + with the key, and you can always quit by hitting 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. • : Switch to Source Viewer. @@ -131,6 +144,9 @@ • : 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 @@ • , 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: + - 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() diff --git a/ghcitui.cabal b/ghcitui.cabal --- a/ghcitui.cabal +++ b/ghcitui.cabal @@ -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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs @@ -46,6 +46,7 @@ } deriving (Show) +-- | Set up the default config for the App startup. defaultConfig :: AppConfig defaultConfig = AppConfig diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs @@ -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 "" 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 "" 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 = diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs b/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs @@ -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 () diff --git a/lib/ghcitui-brick/Ghcitui/Brick/EventUtils.hs b/lib/ghcitui-brick/Ghcitui/Brick/EventUtils.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/EventUtils.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/Events.hs b/lib/ghcitui-brick/Ghcitui/Brick/Events.hs --- a/lib/ghcitui-brick/Ghcitui/Brick/Events.hs +++ b/lib/ghcitui-brick/Ghcitui/Brick/Events.hs @@ -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 "" (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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/InterpWindowEvents.hs b/lib/ghcitui-brick/Ghcitui/Brick/InterpWindowEvents.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/InterpWindowEvents.hs @@ -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 () diff --git a/lib/ghcitui-brick/Ghcitui/Brick/SourceWindowEvents.hs b/lib/ghcitui-brick/Ghcitui/Brick/SourceWindowEvents.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/SourceWindowEvents.hs @@ -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 "" (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 diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs b/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs --- a/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs +++ b/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs @@ -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 ""@ + Analogue to @:complete repl "\"@ 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 diff --git a/lib/ghcitui-core/Ghcitui/Util.hs b/lib/ghcitui-core/Ghcitui/Util.hs --- a/lib/ghcitui-core/Ghcitui/Util.hs +++ b/lib/ghcitui-core/Ghcitui/Util.hs @@ -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" "↓"