ghcitui (empty) → 0.1.0.0
raw patch · 30 files changed
+3545/−0 lines, 30 filesdep +arraydep +basedep +brickbinary-added
Dependencies added: array, base, brick, containers, errors, extra, file-embed, ghcid, ghcitui, hspec, microlens, microlens-th, optparse-applicative, regex-base, regex-tdfa, string-interpolate, text, text-zipper, transformers, utf8-string, vector, vty, word-wrap
Files
- CHANGELOG.md +31/−0
- LICENSE +26/−0
- MANUAL.rst +171/−0
- README.md +58/−0
- app/Main.hs +100/−0
- assets/splash.txt +10/−0
- docs/assets/20240116_splash.png binary
- gen/MANUAL.txt +154/−0
- ghcitui.cabal +152/−0
- lib/ghcitui-brick/Ghcitui/Brick.hs +10/−0
- lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs +62/−0
- lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs +90/−0
- lib/ghcitui-brick/Ghcitui/Brick/AppState.hs +338/−0
- lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs +16/−0
- lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs +326/−0
- lib/ghcitui-brick/Ghcitui/Brick/DrawSourceViewer.hs +197/−0
- lib/ghcitui-brick/Ghcitui/Brick/Events.hs +438/−0
- lib/ghcitui-brick/Ghcitui/Brick/HelpText.hs +10/−0
- lib/ghcitui-brick/Ghcitui/Brick/SourceWindow.hs +227/−0
- lib/ghcitui-brick/Ghcitui/Brick/SplashTextEmbed.hs +10/−0
- lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs +533/−0
- lib/ghcitui-core/Ghcitui/Ghcid/LogConfig.hs +7/−0
- lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs +286/−0
- lib/ghcitui-core/Ghcitui/Ghcid/StartupConfig.hs +11/−0
- lib/ghcitui-core/Ghcitui/Loc.hs +151/−0
- lib/ghcitui-core/Ghcitui/NameBinding.hs +25/−0
- lib/ghcitui-core/Ghcitui/Util.hs +55/−0
- test/LocSpec.hs +22/−0
- test/Spec.hs +11/−0
- test/UtilSpec.hs +18/−0
+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Revision history for ghcitui++## 0.1.0.0 -- 2024-01-21++First release! This is a "public beta" release, which we try to get feedback for higher priority+features.++### Features++- The public Ghcitui library.+- Ghcid connection set up.+- Source code viewer.+- GHCi REPL+- Current Bindings.+- Available Modules.+- Tracing.+- Debug console.++### Bug fixes++- None--this is the first release.++### Known issues++(See https://github.com/CrystalSplitter/ghcitui/issues for the latest issues.)++- 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?)+- Currently no remapping of keybindings or colours.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2023 Jordan 'Crystal' R AW++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+may be used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MANUAL.rst view
@@ -0,0 +1,171 @@+==============+GHCiTUI MANUAL+==============++------------+CLI Synopsis+------------++.. code-block::++ Usage: ghcitui [--version] [--debug-console] [-v] [--daemon-log LOGFILE]+ [-c|--cmd CMD] [-C|--workdir DIR] [TARGET]++ ghcitui: A TUI interface for GHCi++ Available options:+ -h,--help Show this help text+ --version Print the version number and exit+ --debug-console Display the debug console+ -v Set verbosity for output logs. Pass multiple times+ (e.g -vvv) to increase the logging. Use --daemon-log+ to specify where the logs go.+ --daemon-log LOGFILE File path for debugging daemon logs. Used with -v.+ Setting this to 'stdout' or 'stderr' sends logs to+ each, respectively. Defaults to /tmp/ghcitui.log.+ -c,--cmd CMD Command to start the internal interpreter+ -C,--workdir DIR Set working dir++---------------------+Starting and Stopping+---------------------++********+Starting+********++GHCiTUI runs a REPL in the current directory by default. By default, it+launches ``cabal repl``.++.. code-block:: bash++ $ cd your/cabal/project/root/directory+ $ ghcitui++You can specify another starting directory with the ``-C <DIR>`` flag.+++.. code-block:: bash++ $ ghcitui -C some/other/directory+++********+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.++------+Layout+------++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:++.. code-block::++ ┌──────────────────┬──────┐+ │ │ Info │+ │ │ │+ │ Source Viewer │ │+ │ │ │+ │ │ │+ ├──────────────────┤ │+ │ │ │+ │ Live Interpreter │ │+ │ │ │+ └──────────────────┴──────┘++**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 some+additional keybindings.++**Info:** This panel displays miscellaneous info about whatever is+currently 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 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.++-----------+Keybindings+-----------++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+ panels.+- ``M``: Switch to the module panel.+- ``<Esc>``, ``q``: Quit.+- ``<Up>``, ``k``: Move the cursor up. (``j`` and ``k`` from Vim keybinds)+- ``<Down>``, ``j``: Move the cursor down. (``j`` and ``k`` from Vim keybinds).+- ``<PgUp>``: Move the source viewer one page up.+- ``<PgDown>``: Move the source viewer one page down.+- ``+``, ``-``: 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.+- ``s``: Advance execution by one step. Same as the ``:step`` in GHCi.+- ``c``: Advance execution until next breakpoint. Same as ``:continue`` in+ GHCi.+- ``t``: Advance execution until next breakpoint under tracing. Same as+ ``:trace`` in GHCi.++***********************+Live Interpreter (REPL)+***********************++- ``Ctrl+x``: Toggle between the Source Viewer and the Live Interpreter+ panels.+- ``<Esc>``: Switch to Source Viewer.+- ``<Esc>`` while in scrolling mode: Exit scrolling mode.+- ``<Up>``: Scroll back in time through the REPL command history.+- ``<Down>``: Scroll forward in time through the REPL command history.+- ``<PgUp>``: Scroll the Live Interpreter window one page up.+- ``<PgDown>``: Scroll the Live Interpreter window one page down.+- ``Ctrl+n``: Toggle scrolling mode.+- ``+``, ``-`` while in scrolling mode: Increase/decrease the live+ panel size.+- ``<Enter>``: Enter a command to the REPL.++*******+Modules+*******++- ``?``: Display help inside GHCiTUI.+- ``Ctrl+x``: Switch to the Live Interpreter.+- ``<Esc>``, ``C``: Switch to Source Viewer.+- ``<Up>``, ``k``: Move the module selection up.+- ``<Down>``, ``j``: Move the module selection down.+- ``+``, ``-``: Increase/decrease the info panel size.+- ``<Enter>``, ``o``: Open the selected module.++-------------------------------+Reporting Bugs/Feature Requests+-------------------------------++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 new one.
+ README.md view
@@ -0,0 +1,58 @@+# GHCiTUI: Interactive terminal interface for the Glasgow Haskell Compiler++```+ / ______ __ __ ______ __+ // /\ ___\ /\ \_\ \ /\ ___\ /\_\+ // ___\ \ \__ \_\ \ __ \_\ \ \_____\ \ \___+' , _ // \ \ \_____\ \ \_\ \_\ \ \_____\ \ \_\ \+ / \ // 7 \ \/_____/ \/_/\/_/ \/_____/ \/_/ \+ " \ \ ______ __ __ __ \+ a a \ /\__ _\ /\ \/\ \ /\ \ \+ |_ \ \________\/_/\ \/_\ \ \_\ \_\ \ \________\+ '._ ' \ \_\ \ \_____\ \ \_\+ (' _ ' \/_/ \/_____/ \/_/+```++++This is an experimental front-end terminal interface for+`ghci`. It provides a source viewer, keybindings, an interactive+interpreter, and a local context viewer.++++## Installation++You can install this project from Hackage using `cabal` or from source. See [INSTALLATION] for details.++## Basic Usage++For full usage, please see the [manual].++### Starting the TUI++GHCiTUI runs a repl in the current directory by default.++```bash+$ cd your/cabal/project/root/directory+$ ghcitui+```++You can specify another directory with the `-C <DIR>` flag.++```bash+$ ghcitui -C some/other/directory+```++### Quitting the TUI++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.++## Contributing++Contributors are welcome! Please see [CONTRIBUTING] to see how.++[INSTALLATION]: https://github.com/CrystalSplitter/ghcitui/blob/main/INSTALL.rst+[manual]: https://github.com/CrystalSplitter/ghcitui/blob/main/MANUAL.rst+[CONTRIBUTING]: https://github.com/CrystalSplitter/ghcitui/blob/main/CONTRIBUTING.md
+ app/Main.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import qualified Data.Version+import qualified Paths_ghcitui as CabalPkg++import Control.Applicative (many)+import qualified Data.Text as T+import qualified Options.Applicative as Opt++import qualified Ghcitui.Brick as GB++-- | Holds passed in command line options.+data CmdOptions = CmdOptions+ { version :: !Bool+ , debugConsole :: !Bool+ , verbosity :: !Int+ , debugLogPath :: !FilePath+ , cmd :: !T.Text+ , workdir :: !FilePath+ -- ^ Launch the TUI at this work directory.+ , target :: !T.Text+ -- ^ Build target, passed as the final argument to cmd.+ }+ deriving (Show, Eq)++parseOpts :: Opt.Parser CmdOptions+parseOpts = do+ version <- Opt.switch (Opt.long "version" <> Opt.help "Print the version number and exit")+ debugConsole <-+ Opt.switch+ ( Opt.long "debug-console"+ <> Opt.help "Display the debug console"+ )+ verbosity <-+ length <$> many (Opt.flag' () (Opt.short 'v' <> Opt.help verbosityHelp))+ debugLogPath <-+ Opt.strOption+ ( Opt.long "daemon-log"+ <> Opt.help daemonLogHelp+ <> Opt.metavar "LOGFILE"+ <> Opt.value "stderr"+ )+ cmd <-+ Opt.strOption+ ( Opt.long "cmd"+ <> Opt.short 'c'+ <> Opt.metavar "CMD"+ <> Opt.help "Command to start the internal interpreter"+ <> Opt.value ""+ )+ workdir <-+ Opt.strOption+ ( Opt.long "workdir"+ <> Opt.short 'C'+ <> Opt.metavar "DIR"+ <> Opt.help "Set working dir"+ <> Opt.value ""+ )+ target <- Opt.argument Opt.str (Opt.metavar "TARGET" <> Opt.value "")+ pure CmdOptions{..}+ where+ verbosityHelp =+ "Set verbosity for output logs."+ <> " Pass multiple times (e.g -vvv) to increase the logging."+ <> " Use --daemon-log to specify where the logs go."+ daemonLogHelp =+ "File path for debugging daemon logs."+ <> " Used with -v."+ <> " Setting this to 'stdout' or 'stderr' sends logs to each, respectively."+ <> " Defaults to 'stderr'"++-- | The cabal package version.+programVersion :: String+programVersion = Data.Version.showVersion CabalPkg.version++main :: IO ()+main = do+ opts <- Opt.execParser parserInfo+ if version opts+ then do+ putStrLn $ programName <> " " <> programVersion+ else do+ let conf =+ GB.defaultConfig+ { GB.getDebugConsoleOnStart = debugConsole opts+ , GB.getVerbosity = verbosity opts+ , GB.getDebugLogPath = debugLogPath opts+ , GB.getCmd =+ if T.null $ cmd opts+ then GB.getCmd GB.defaultConfig+ else cmd opts+ }+ GB.launchBrick conf (target opts) (workdir opts)+ where+ programName = "ghcitui"+ programDescription = Opt.progDesc (programName <> ": A TUI interface for GHCi")+ parserInfo = Opt.info (Opt.helper <*> parseOpts) (Opt.fullDesc <> programDescription)
+ assets/splash.txt view
@@ -0,0 +1,10 @@+ ______ __ __ ______ __+ /\ ___\ /\ \_\ \ /\ ___\ /\_\+ ___\ \ \__ \_\ \ __ \_\ \ \_____\ \ \___+ \ \ \_____\ \ \_\ \_\ \ \_____\ \ \_\ \+ \ \/_____/ \/_/\/_/ \/_____/ \/_/ \+ \ ______ __ __ __ \+ \ /\__ _\ /\ \/\ \ /\ \ \+ \________\/_/\ \/_\ \ \_\ \_\ \ \________\+ \ \_\ \ \_____\ \ \_\+ \/_/ \/_____/ \/_/
+ docs/assets/20240116_splash.png view
binary file changed (absent → 51902 bytes)
+ gen/MANUAL.txt view
@@ -0,0 +1,154 @@+CLI SYNOPSIS+ Usage: ghcitui [--version] [--debug-console] [-v] [--daemon-log LOGFILE]+ [-c|--cmd CMD] [-C|--workdir DIR] [TARGET]++ ghcitui: A TUI interface for GHCi++ Available options:+ -h,--help Show this help text+ --version Print the version number and exit+ --debug-console Display the debug console+ -v Set verbosity for output logs. Pass multiple times+ (e.g -vvv) to increase the logging. Use --daemon-log+ to specify where the logs go.+ --daemon-log LOGFILE File path for debugging daemon logs. Used with -v.+ Setting this to 'stdout' or 'stderr' sends logs to+ each, respectively. Defaults to /tmp/ghcitui.log.+ -c,--cmd CMD Command to start the internal interpreter+ -C,--workdir DIR Set working dir++STARTING AND STOPPING+ Starting+ GHCiTUI runs a REPL in the current directory by default. By default,+ it launches cabal repl.++ $ cd your/cabal/project/root/directory+ $ ghcitui++ You can specify another starting directory with the -C <DIR> flag.++ $ ghcitui -C some/other/directory++ 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.++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:++ ┌──────────────────┬──────┐+ │ │ Info │+ │ │ │+ │ Source Viewer │ │+ │ │ │+ │ │ │+ ├──────────────────┤ │+ │ │ │+ │ Live Interpreter │ │+ │ │ │+ └──────────────────┴──────┘++ 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+ some additional keybindings.++ 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+ 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.++KEYBINDINGS+ 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+ panels.++ • M: Switch to the module panel.++ • <Esc>, q: Quit.++ • <Up>, k: Move the cursor up. (j and k from Vim keybinds)++ • <Down>, j: Move the cursor down. (j and k from Vim keybinds).++ • <PgUp>: Move the source viewer one page up.++ • <PgDown>: Move the source viewer one page down.++ • +, -: 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.++ • s: Advance execution by one step. Same as the :step in GHCi.++ • c: Advance execution until next breakpoint. Same as :continue in+ GHCi.++ • t: Advance execution until next breakpoint under tracing. Same as+ :trace in GHCi.++ Live Interpreter (REPL)+ • Ctrl+x: Toggle between the Source Viewer and the Live Interpreter+ panels.++ • <Esc>: Switch to Source Viewer.++ • <Esc> while in scrolling mode: Exit scrolling mode.++ • <Up>: Scroll back in time through the REPL command history.++ • <Down>: Scroll forward in time through the REPL command history.++ • <PgUp>: Scroll the Live Interpreter window one page up.++ • <PgDown>: Scroll the Live Interpreter window one page down.++ • Ctrl+n: Toggle scrolling mode.++ • +, - while in scrolling mode: Increase/decrease the live panel size.++ • <Enter>: Enter a command to the REPL.++ Modules+ • ?: Display help inside GHCiTUI.++ • Ctrl+x: Switch to the Live Interpreter.++ • <Esc>, C: Switch to Source Viewer.++ • <Up>, k: Move the module selection up.++ • <Down>, j: Move the module selection down.++ • +, -: Increase/decrease the info panel size.++ • <Enter>, o: Open the selected module.++REPORTING BUGS/FEATURE REQUESTS+ 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+ new one.++ GHCITUI MANUAL()
+ ghcitui.cabal view
@@ -0,0 +1,152 @@+cabal-version: 2.4+name: ghcitui+version: 0.1.0.0+synopsis: A Terminal User Interface (TUI) for GHCi++description:+ A terminal user interface for GHCi debug mode.+ .+ Features:+ .+ * A source view window, with debug keybindings.+ .+ * Live variable bindings.+ .+ * Live loaded modules.+ .+ * Visible trace history.+ .+ * An GHCi session in the current context.++author: Jordan 'Crystal' R AW+bug-reports: https://github.com/CrystalSplitter/ghcitui/issues+category: Debug+copyright: Jordan 'Crystal' R AW+homepage: https://github.com/CrystalSplitter/ghcitui+license-file: LICENSE+license: BSD-3-Clause+maintainer: crystal@crystalwobsite.gay+stability: experimental+tested-with: GHC == 9.2.8, GHC == 9.4.8, GHC == 9.8.1++extra-source-files: LICENSE+ , assets/splash.txt+ , gen/MANUAL.txt+extra-doc-files: CHANGELOG.md+ , MANUAL.rst+ , README.md+ , docs/assets/20240116_splash.png++source-repository head+ type: git+ location: https://github.com/CrystalSplitter/ghcitui++executable ghcitui+ main-is: Main.hs+ build-depends: base >= 4.16 && < 5+ , ghcitui-brick+ , optparse-applicative >= 0.17 && < 0.19+ , ghcitui+ , text+ hs-source-dirs: app+ other-modules: Paths_ghcitui+ autogen-modules: Paths_ghcitui+ ghc-options: -rtsopts+ -threaded+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wpartial-fields+ -Wredundant-constraints+ default-language: Haskell2010+ default-extensions: MonoLocalBinds+ OverloadedStrings+ RecordWildCards++library+ hs-source-dirs: lib/ghcitui-core+ build-depends: base >= 4.16 && < 5+ , array ^>= 0.5+ , containers >= 0.6.8 && < 0.8+ , errors >= 2.2 && < 2.4+ -- Needed to limit ghcid compat.+ , extra >= 1.7.14 && < 1.8+ , 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+ , text >= 2.0 && < 2.2+ , transformers ^>= 0.6.1.0+ -- Needed to limit string-interpolate compat.+ , utf8-string >= 1.0.2 && < 1.1+ exposed-modules: Ghcitui.Ghcid.Daemon+ , Ghcitui.Ghcid.LogConfig+ , Ghcitui.Ghcid.ParseContext+ , Ghcitui.Loc+ , Ghcitui.NameBinding+ , Ghcitui.Util+ other-modules: Ghcitui.Ghcid.StartupConfig+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wpartial-fields+ -Wredundant-constraints+ default-language: Haskell2010+ default-extensions: DuplicateRecordFields+ MonoLocalBinds+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ TupleSections++library ghcitui-brick+ hs-source-dirs: lib/ghcitui-brick+ build-depends: base >= 4.16 && < 5+ , brick >= 2.2 && < 2.4+ , containers+ , errors+ , file-embed ^>= 0.0.15+ , ghcitui+ , microlens >= 0.4.0.1 && < 0.5+ , microlens-th ^>= 0.4+ , text+ , text-zipper ^>= 0.13+ , vector >= 0.10 && < 0.14+ , vty >= 5.38 && < 6.2+ , word-wrap ^>= 0.5+ exposed-modules: Ghcitui.Brick+ other-modules: Ghcitui.Brick.AppConfig+ , Ghcitui.Brick.AppInterpState+ , Ghcitui.Brick.AppState+ , Ghcitui.Brick.AppTopLevel+ , Ghcitui.Brick.BrickUI+ , Ghcitui.Brick.DrawSourceViewer+ , Ghcitui.Brick.Events+ , Ghcitui.Brick.HelpText+ , Ghcitui.Brick.SourceWindow+ , Ghcitui.Brick.SplashTextEmbed+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wpartial-fields+ -Wredundant-constraints+ default-language: Haskell2010+ default-extensions: DuplicateRecordFields+ LambdaCase+ MonoLocalBinds+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ TupleSections+++test-suite spec+ hs-source-dirs: test+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ build-depends: base >= 4.16 && < 5+ , ghcitui+ , hspec ^>= 2.11.5+ other-modules: LocSpec+ , UtilSpec+ default-language: Haskell2010
+ lib/ghcitui-brick/Ghcitui/Brick.hs view
@@ -0,0 +1,10 @@+module Ghcitui.Brick+ ( -- * Configuration settings for the BrickUI+ module Ghcitui.Brick.AppConfig++ -- * Display BrickUI+ , module Ghcitui.Brick.BrickUI+ ) where++import Ghcitui.Brick.AppConfig+import Ghcitui.Brick.BrickUI
+ lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Ghcitui.Brick.AppConfig+ ( AppConfig (..)+ , defaultConfig+ , loadStartupSplash+ , userConfigDir+ )+where++import Data.Maybe (fromMaybe)+import Data.String (IsString)+import qualified Data.Text as T+import System.Environment (lookupEnv)++import qualified Ghcitui.Brick.SplashTextEmbed as SplashTextEmbed++userConfigDir :: IO FilePath+userConfigDir = fromMaybe (error errorMsg) <$> result+ where+ chooseNonEmpty accA xA = do+ a <- accA+ if a == mempty+ then xA+ else pure a+ errorMsg = "Cannot set config location. Neither XDG_CONFIG_HOME nor HOME values were set."+ result =+ foldr+ chooseNonEmpty+ mempty+ [lookupEnv "XDG_CONFIG_HOME", fmap (fmap (<> "/.config")) (lookupEnv "HOME")]++data AppConfig = AppConfig+ { getInterpreterPrompt :: !T.Text+ -- ^ Prompt to show for the live interpreter.+ , getDebugConsoleOnStart :: !Bool+ -- ^ Display the debug console on start up.+ , getDebugLogPath :: !FilePath+ , getVerbosity :: !Int+ -- ^ Verbosity level.+ , getStartupSplashPath :: !(Maybe FilePath)+ , getCmd :: !T.Text+ -- ^ Command to run to initialise the interpreter.+ , getStartupCommands :: ![T.Text]+ -- ^ Commands to run in ghci during start up.+ }++defaultConfig :: AppConfig+defaultConfig =+ AppConfig+ { getInterpreterPrompt = "ghci> "+ , getDebugConsoleOnStart = False+ , getDebugLogPath = ""+ , getVerbosity = 0+ , getStartupSplashPath = Nothing+ , getCmd = "cabal v2-repl --repl-options='-fno-it'"+ , getStartupCommands = mempty+ }++-- | Return the startup screen splash as an IsString.+loadStartupSplash :: (IsString s) => AppConfig -> IO (Maybe s)+loadStartupSplash _ = pure (pure SplashTextEmbed.splashText)
+ lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}++module Ghcitui.Brick.AppInterpState+ ( AppInterpState (_liveEditor, _viewLock, _commandBuffer, historyPos)+ , commandBuffer+ , emptyAppInterpState+ , futHistoryPos+ , cmdHistory+ , isScanningHist+ , liveEditor+ , pastHistoryPos+ , pushHistory+ , viewLock+ ) where++import qualified Brick.Widgets.Edit as BE+import qualified Data.Text as T+import Lens.Micro as Lens++data AppInterpState s n = AppInterpState+ { _liveEditor :: BE.Editor s n+ , _viewLock :: !Bool+ -- ^ Whether we're locked to the bottom of the interpreter (True) window or not (False).+ , _commandBuffer :: [s]+ -- ^ The text currently typed into the editor, but not yet executed or in the history.+ , _cmdHistory :: [[s]]+ , historyPos :: !Int+ }++-- | Lens accessor for the editor. See '_liveEditor'.+liveEditor :: Lens.Lens' (AppInterpState s n) (BE.Editor s n)+liveEditor = Lens.lens _liveEditor (\ais le -> ais{_liveEditor = le})++-- | Lens for the view lock setting. See '_viewLock'.+viewLock :: Lens.Lens' (AppInterpState s n) Bool+viewLock = Lens.lens _viewLock (\ais x -> ais{_viewLock = x})++-- | Lens for the current contents of the command line buffer. See '_commandBuffer'.+commandBuffer :: Lens.Lens' (AppInterpState s n) [s]+commandBuffer = Lens.lens _commandBuffer (\ais x -> ais{_commandBuffer = x})++-- | Return the interpreter command history.+cmdHistory :: AppInterpState s n -> [[s]]+cmdHistory = _cmdHistory++-- | Create a base interpreter state.+emptyAppInterpState+ :: n+ -- ^ Name for the 'Brick.Editor'.+ -> AppInterpState T.Text n+emptyAppInterpState name =+ AppInterpState+ { _liveEditor = initInterpWidget name (Just 1)+ , _viewLock = True+ , _commandBuffer = mempty+ , _cmdHistory = mempty+ , historyPos = 0+ }++resetHistoryPos :: AppInterpState s n -> AppInterpState s n+resetHistoryPos s = s{historyPos = 0}++-- | Move interpreter history back.+pastHistoryPos :: AppInterpState s n -> AppInterpState s n+pastHistoryPos s@AppInterpState{..} =+ -- Note we do want it to stop at length _history, not length _history - 1+ -- because 0 is not the beginning of the history, it's the commandBuffer.+ s{historyPos = min (length _cmdHistory) $ succ historyPos}++-- | Are we currently viewing past contents?+isScanningHist :: AppInterpState s n -> Bool+isScanningHist AppInterpState{..} = historyPos /= 0++-- | Move interpreter history forward.+futHistoryPos :: AppInterpState s n -> AppInterpState s n+futHistoryPos s@AppInterpState{..} = s{historyPos = max 0 $ pred historyPos}++-- | Push a new value on to the history stack and reset the position.+pushHistory :: [s] -> AppInterpState s n -> AppInterpState s n+pushHistory cmdLines s = resetHistoryPos $ s{_cmdHistory = cmdLines : cmdHistory s}++-- | Create the initial live interpreter widget object.+initInterpWidget+ :: n+ -- ^ Editor name (must be a unique identifier).+ -> Maybe Int+ -- ^ Line height of the editor. Nothing for unlimited.+ -> BE.Editor T.Text n+initInterpWidget name height = BE.editorText name height mempty
+ lib/ghcitui-brick/Ghcitui/Brick/AppState.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Ghcitui.Brick.AppState+ ( ActiveWindow (..)+ , AppConfig (..)+ , AppState (..)+ , WidgetSizes+ , changeInfoWidgetSize+ , getInfoWidth+ , getReplHeight+ , changeReplWidgetSize+ , getSelectedModuleInInfoPanel+ , changeSelectedModuleInInfoPanel+ , appInterpState+ , getSourceLineCount+ , selectedFile+ , setSelectedFile+ , selectedLine+ , filePathOfInfoSelectedModule+ , listAvailableSources+ , liveEditor+ , makeInitialState+ , selectPausedLine+ , sourceWindow+ , toggleActiveLineInterpreter+ , toggleBreakpointLine+ , updateSourceMap+ , writeDebugLog+ ) where++import qualified Brick as B+import qualified Brick.Widgets.Edit as BE+import Control.Error (atMay, fromMaybe)+import Control.Exception (IOException, try)+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as Vec+import Lens.Micro ((^.))+import qualified Lens.Micro as Lens++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 qualified Ghcitui.Brick.SourceWindow as SourceWindow+import Ghcitui.Ghcid.Daemon (toggleBreakpointLine)+import qualified Ghcitui.Ghcid.Daemon as Daemon+import qualified Ghcitui.Ghcid.LogConfig as LogConfig+import qualified Ghcitui.Loc as Loc+import qualified Ghcitui.Util as Util++data ActiveWindow+ = ActiveCodeViewport+ | ActiveLiveInterpreter+ | ActiveInfoWindow+ | ActiveDialogQuit+ | ActiveDialogHelp+ deriving (Show, Eq, Ord)++-- | Size information of the current GHCiTUI main boxes.+data WidgetSizes = WidgetSizes+ { _wsInfoWidth :: !Int+ , _wsReplHeight :: !Int+ }++{- | Application state wrapper.++Contains information about the UI and configuration. It also holds a+handle to the actual interpreter under the hood, but on the high level+it should not hold anything internal to GHCi or GHCiD.++Prefer to create this with 'makeInitialState'.+-}+data AppState n = AppState+ { interpState :: Daemon.InterpState ()+ -- ^ The interpreter handle.+ , getCurrentWorkingDir :: !FilePath+ -- ^ The current working directory.+ , _appInterpState :: AIS.AppInterpState T.Text n+ -- ^ The live interpreter state (separate from the interpreter+ -- and the app state itself.+ , interpLogs :: ![Text]+ , appConfig :: !AppConfig+ -- ^ Program launch configuration.+ , activeWindow :: !ActiveWindow+ -- ^ Currently active window.+ , _selectedFile :: !(Maybe FilePath)+ -- ^ Filepath to the current code viewport contents, if set.+ , _sourceWindow :: !(SourceWindow.SourceWindow n T.Text)+ , _infoPanelSelectedModule :: !Int+ -- ^ Currently selected module in the info sidebar, zero indexed.+ , sourceMap :: Map.Map FilePath T.Text+ -- ^ Mapping between source filepaths and their contents.+ , _currentWidgetSizes :: WidgetSizes+ -- ^ Current window/box/panel sizes (since it can change). Do not edit+ -- directly.+ , displayDebugConsoleLogs :: !Bool+ -- ^ Whether to display debug Console logs.+ , debugConsoleLogs :: [Text]+ -- ^ Place for debug output to go.+ , splashContents :: !(Maybe T.Text)+ -- ^ Splash to show on start up.+ }++newtype AppStateM m a = AppStateM {runAppStateM :: m a}++instance (Functor m) => Functor (AppStateM m) where+ fmap f appStateA = AppStateM (f <$> runAppStateM appStateA)++instance (Applicative m) => Applicative (AppStateM m) where+ pure appState = AppStateM (pure appState)+ AppStateM appl <*> AppStateM tgt = AppStateM (appl <*> tgt)++instance (Monad m) => Monad (AppStateM m) where+ return = pure+ AppStateM valM >>= f2 = AppStateM (valM >>= runAppStateM . f2)++instance (MonadIO m) => MonadIO (AppStateM m) where+ liftIO = AppStateM . liftIO++-- | Lens for the App's interpreter box.+appInterpState :: Lens.Lens' (AppState n) (AIS.AppInterpState T.Text n)+appInterpState = Lens.lens _appInterpState (\x ais -> x{_appInterpState = ais})++-- | Lens wrapper for zooming with handleEditorEvent.+liveEditor :: Lens.Lens' (AppState n) (BE.Editor T.Text n)+liveEditor = appInterpState . AIS.liveEditor++currentWidgetSizes :: Lens.Lens' (AppState n) WidgetSizes+currentWidgetSizes = Lens.lens _currentWidgetSizes (\x cws -> x{_currentWidgetSizes = cws})++wsInfoWidth :: Lens.Lens' WidgetSizes Int+wsInfoWidth = Lens.lens _wsInfoWidth (\x ipw -> x{_wsInfoWidth = ipw})++wsReplHeight :: Lens.Lens' WidgetSizes Int+wsReplHeight = Lens.lens _wsReplHeight (\x rh -> x{_wsReplHeight = rh})++sourceWindow :: Lens.Lens' (AppState n) (SourceWindow.SourceWindow n T.Text)+sourceWindow = Lens.lens _sourceWindow (\x srcW -> x{_sourceWindow = srcW})++selectedFile :: AppState n -> Maybe FilePath+selectedFile = _selectedFile++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+ 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}++-- -------------------------------------------------------------------------------------------------+-- State Line Details+-- -------------------------------------------------------------------------------------------------++-- | Currently selected line number. One-indexed. If no line is selected, returns 1.+selectedLine :: AppState n -> Int+selectedLine s = fromMaybe 1 (s ^. sourceWindow . SourceWindow.srcSelectedLineL)++-- | Reset the code viewport selected line to the pause location.+selectPausedLine :: (Ord n) => AppState n -> B.EventM n m (AppState n)+selectPausedLine s@AppState{interpState} = do+ s' <- setSelectedFile ourSelectedFile s+ newSrcW <- SourceWindow.setSelectionTo ourSelectedLine (s' ^. sourceWindow)+ pure $ Lens.set sourceWindow newSrcW s'+ where+ ourSelectedLine :: Int+ ourSelectedLine =+ fromMaybe+ (selectedLine s)+ (Loc.startLine . Loc.fSourceRange =<< interpState.pauseLoc)+ ourSelectedFile = maybe (selectedFile s) (Just . Loc.filepath) interpState.pauseLoc++-- | Write a debug log entry.+writeDebugLog :: T.Text -> AppState n -> AppState n+writeDebugLog lg s = s{debugConsoleLogs = take 100 (lg : debugConsoleLogs s)}++toggleActiveLineInterpreter :: AppState n -> AppState n+toggleActiveLineInterpreter s@AppState{activeWindow} =+ s{activeWindow = toggleLogic activeWindow}+ where+ toggleLogic ActiveLiveInterpreter = ActiveCodeViewport+ toggleLogic _ = ActiveLiveInterpreter++-- | Update the source map given any app state changes.+updateSourceMap :: AppState n -> IO (AppState n)+updateSourceMap s = do+ s' <- case selectedFile s of+ Just sf -> updateSourceMapWithFilepath s sf+ Nothing -> pure s+ case s'.interpState.pauseLoc of+ Nothing -> pure s'+ (Just (Loc.FileLoc{filepath})) -> updateSourceMapWithFilepath s' filepath++-- | Update the source map with a given filepath.+updateSourceMapWithFilepath :: AppState n -> FilePath -> IO (AppState n)+updateSourceMapWithFilepath s filepath+ | Map.member filepath s.sourceMap = pure s+ | otherwise = do+ let adjustedFilepath = getCurrentWorkingDir s <> "/" <> filepath+ eContents <- try $ T.readFile adjustedFilepath :: IO (Either IOException T.Text)+ case eContents of+ Left err -> do+ pure $+ writeDebugLog+ ( "failed to update source map with "+ <> T.pack filepath+ <> ": "+ <> T.pack (show err)+ )+ s+ Right contents -> do+ let newSourceMap = Map.insert filepath contents s.sourceMap+ let logMsg = "updated source map with " <> T.pack filepath+ pure (writeDebugLog logMsg s{sourceMap = newSourceMap})++listAvailableSources :: AppState n -> [(T.Text, FilePath)]+listAvailableSources = Loc.moduleFileMapAssocs . Daemon.moduleFileMap . interpState++-- | Return the potential contents of the current paused file location.+getSourceContents :: AppState n -> Maybe T.Text+getSourceContents s = selectedFile s >>= (sourceMap s Map.!?)++{- | Return the number of lines in the current source viewer.+ Returns Nothing if there's no currently viewed source.+-}+getSourceLineCount :: AppState n -> Maybe Int+getSourceLineCount s = length . T.lines <$> getSourceContents s++changeInfoWidgetSize :: Int -> AppState n -> AppState n+changeInfoWidgetSize amnt s =+ Lens.set+ (currentWidgetSizes . wsInfoWidth)+ -- Do not let the min go too low (<=2), because this causes a memory leak in Brick?+ (Util.clamp (10, 120) (getInfoWidth s + amnt))+ s++changeReplWidgetSize :: Int -> AppState n -> AppState n+changeReplWidgetSize amnt s =+ Lens.set+ (currentWidgetSizes . wsReplHeight)+ -- Do not let the min go too low, because the box disappears then.+ (Util.clamp (1, 80) (getReplHeight s + amnt))+ s++changeSelectedModuleInInfoPanel :: Int -> AppState n -> AppState n+changeSelectedModuleInInfoPanel amnt s =+ s{_infoPanelSelectedModule = newSelection}+ where+ newSelection = (_infoPanelSelectedModule s + amnt) `mod` numModules+ numModules = length (Loc.moduleFileMapAssocs (Daemon.moduleFileMap (interpState s)))++getSelectedModuleInInfoPanel :: AppState n -> Int+getSelectedModuleInInfoPanel = _infoPanelSelectedModule++-- | Return the info box's desired width in character columns.+getInfoWidth :: AppState n -> Int+getInfoWidth = _wsInfoWidth . _currentWidgetSizes++-- | Return the REPL (interactive interpreter)'s box in lines.+getReplHeight :: AppState n -> Int+getReplHeight = _wsReplHeight . _currentWidgetSizes++filePathOfInfoSelectedModule :: AppState n -> Maybe FilePath+filePathOfInfoSelectedModule AppState{interpState, _infoPanelSelectedModule} =+ fmap snd+ . flip atMay _infoPanelSelectedModule+ . Loc.moduleFileMapAssocs+ . Daemon.moduleFileMap+ $ interpState++-- | Initialise the state from the config.+makeInitialState+ :: AppConfig+ -- ^ Start up config.+ -> T.Text+ -- ^ Daemon command prefix.+ -> FilePath+ -- ^ Workding directory.+ -> IO (AppState AppName)+makeInitialState appConfig target cwd = do+ let cwd' = if null cwd then "." else cwd+ let fullCmd = getCmd appConfig <> " " <> target+ let logOutput = case getDebugLogPath appConfig of+ "stderr" -> Daemon.LogOutputStdErr+ "stdout" -> Daemon.LogOutputStdOut+ filepath -> Daemon.LogOutputFile filepath+ let logLevel = LogConfig.LogLevel (AppConfig.getVerbosity appConfig)+ let startupConfig =+ Daemon.StartupConfig+ { Daemon.logLevel = logLevel+ , Daemon.logOutput = logOutput+ }+ interpState <-+ Daemon.run (Daemon.startup (T.unpack fullCmd) cwd' startupConfig) >>= \case+ Right iState -> pure iState+ Left er -> error (show er)+ splashContents <- AppConfig.loadStartupSplash appConfig+ let selectedFile' =+ case Loc.moduleFileMapAssocs (Daemon.moduleFileMap interpState) of+ -- If we just have one file, select that.+ [(_, filepath)] -> Just filepath+ -- If we have no module/file mappings, nothing must be selected.+ [] -> Nothing+ -- If we don't have a selected file, but we have a module loaded,+ -- select the last one.+ _ -> Nothing+ updateSourceMap+ AppState+ { interpState+ , getCurrentWorkingDir = cwd'+ , _appInterpState = AIS.emptyAppInterpState LiveInterpreter+ , activeWindow = ActiveCodeViewport+ , appConfig+ , debugConsoleLogs = mempty+ , displayDebugConsoleLogs = getDebugConsoleOnStart appConfig+ , interpLogs = mempty+ , _selectedFile = selectedFile'+ , _infoPanelSelectedModule = 0+ , sourceMap = mempty+ , _currentWidgetSizes =+ WidgetSizes+ { _wsInfoWidth = 35+ , _wsReplHeight = 11 -- 10 plus 1 for the entry line.+ }+ , splashContents+ , _sourceWindow = SourceWindow.mkSourcWindow SourceList ""+ }
+ lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs view
@@ -0,0 +1,16 @@+module Ghcitui.Brick.AppTopLevel (AppName (..)) where++-- | Unique identifiers for components of the App.+data AppName+ = GHCiTUI+ | CodeViewport+ | SourceWindowLine Int+ | DebugPanel+ | LiveInterpreter+ | LiveInterpreterViewport+ | HelpViewport+ | BindingViewport+ | ModulesViewport+ | TraceViewport+ | SourceList+ deriving (Eq, Show, Ord)
+ lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+++module Ghcitui.Brick.BrickUI+ ( launchBrick+ , AppState (..)+ ) where++import qualified Brick as B+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Center as B+import Brick.Widgets.Core ((<+>), (<=>))+import qualified Brick.Widgets.Dialog as B+import qualified Brick.Widgets.Edit as BE+import Control.Error (headMay)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Graphics.Vty as V+import Lens.Micro ((&), (^.))+import qualified Text.Wrap as Wrap++import qualified Ghcitui.Brick.AppConfig as AppConfig+import qualified Ghcitui.Brick.AppInterpState as AIS+import Ghcitui.Brick.AppState+ ( ActiveWindow (..)+ , AppState (..)+ , appInterpState+ , liveEditor+ , makeInitialState+ )+import qualified Ghcitui.Brick.AppState as AppState+import Ghcitui.Brick.AppTopLevel (AppName (..))+import qualified Ghcitui.Brick.DrawSourceViewer as DrawSourceViewer+import qualified Ghcitui.Brick.Events as Events+import qualified Ghcitui.Brick.HelpText as HelpText+import qualified Ghcitui.Brick.SourceWindow as SourceWindow+import qualified Ghcitui.Ghcid.Daemon as Daemon+import qualified Ghcitui.Loc as Loc+import qualified Ghcitui.NameBinding as NameBinding+import qualified Ghcitui.Util as Util++-- | Alias for 'AppState AppName' convenience.+type AppS = AppState AppName++appDraw :: AppS -> [B.Widget AppName]+appDraw s =+ [ drawDialogLayer s+ , drawBaseLayer s+ ]++dialogMaxWidth :: (Integral a) => a+dialogMaxWidth = 94++{- | Draw the dialog layer.++ If there's no dialog, returns an 'emptyWidget'.+-}+drawDialogLayer :: AppS -> B.Widget AppName+-- Quit Dialog+drawDialogLayer AppState{activeWindow = ActiveDialogQuit} =+ B.withAttr (B.attrName "dialog") $ B.renderDialog dialogObj body+ where+ dialogObj = B.dialog (Just titleW) Nothing dialogMaxWidth+ titleW = B.txt "Please don't go. The drones need you. They look up to you."+ body =+ B.hCenter+ (B.padAll 1 (B.txt "Do you want to halt the current program and quit?"))+ <=> B.hCenter (B.padAll 1 (B.txt "[Enter] -> QUIT" <=> B.txt "[Esc/q] -> Go back"))+-- Help Dialog+drawDialogLayer AppState{activeWindow = ActiveDialogHelp} =+ B.withAttr (B.attrName "dialog") $ B.renderDialog dialogObj body+ where+ dialogObj = B.dialog (Just titleW) Nothing dialogMaxWidth+ titleW = B.txt "Actually reading the manual, huh?"+ body =+ ( B.hCenter+ . B.withVScrollBars B.OnRight+ . B.viewport HelpViewport B.Vertical+ $ B.padAll 1 (B.txt HelpText.helpText)+ )+ <=> ( B.hCenter+ . B.padAll 1+ $ B.txt "[Esc/Enter/q] -> Go back"+ )+-- No Dialog+drawDialogLayer _ = B.emptyWidget++drawBaseLayer :: AppS -> B.Widget AppName+drawBaseLayer s =+ (sourceWindowBox <=> interpreterBox <=> debugBox) <+> infoBox s+ where+ sourceLabel =+ markLabel+ (s.activeWindow == ActiveCodeViewport)+ ( "Source: " <> maybe "?" T.pack (AppState.selectedFile s)+ )+ "[Esc]"+ interpreterLabel =+ markLabel+ (s.activeWindow == ActiveLiveInterpreter)+ ( if s ^. appInterpState . AIS.viewLock+ then "GHCi"+ else "GHCi (Scrolling)"+ )+ "[Ctrl+x]"++ -- For seeing the source code.+ sourceWindowBox :: B.Widget AppName+ sourceWindowBox =+ B.borderWithLabel sourceLabel+ . appendLastCommand+ . B.padRight B.Max+ . B.padBottom B.Max+ $ DrawSourceViewer.drawSourceViewer s+ where+ appendLastCommand w =+ B.padBottom B.Max (w <=> B.hBorder <=> (lastCmdWidget <+> lineNumRatioWidget))+ where+ selectedLine = AppState.selectedLine s+ totalLines = s ^. AppState.sourceWindow & SourceWindow.srcWindowLength+ percentageNum =+ if totalLines > 0+ then (selectedLine * 100) `div` totalLines+ else 0+ lineNumRatioWidget =+ B.txt+ ( Util.showT selectedLine+ <> "/"+ <> Util.showT totalLines+ <> "L ("+ <> Util.showT percentageNum+ <> "%)"+ )+ lastCmdWidget =+ B.padRight+ B.Max+ ( case headMay (Daemon.execHist (AppState.interpState s)) of+ Just h -> B.txt h+ _ -> B.txt " "+ )++ -- For the REPL.+ interpreterBox :: B.Widget AppName+ interpreterBox =+ B.borderWithLabel interpreterLabel+ . B.vLimit (AppState.getReplHeight s)+ . B.withVScrollBars B.OnRight+ . B.viewport LiveInterpreterViewport B.Vertical+ $ previousOutput <=> lockToBottomOnViewLock promptLine+ where+ enableCursor = True+ previousOutput =+ if null s.interpLogs+ then B.emptyWidget+ else+ B.txt+ . T.unlines+ . reverse+ $ s.interpLogs+ promptLine :: B.Widget AppName+ promptLine =+ B.txt (AppConfig.getInterpreterPrompt . AppState.appConfig $ s)+ <+> BE.renderEditor displayF enableCursor (s ^. liveEditor)+ where+ displayF :: [T.Text] -> B.Widget AppName+ displayF t = B.vBox $ B.txt <$> t+ lockToBottomOnViewLock w =+ if s ^. appInterpState . AIS.viewLock+ then B.visible w+ else w++ debugBox =+ if s.displayDebugConsoleLogs+ then+ let logDisplay =+ if null s.debugConsoleLogs then [" "] else s.debugConsoleLogs+ applyVisTo (x : xs) = B.visible x : xs+ applyVisTo [] = []+ in B.borderWithLabel (B.txt "Debug")+ . B.vLimit 10+ . B.withVScrollBars B.OnRight+ . B.viewport DebugPanel B.Vertical+ . B.padRight B.Max+ . B.vBox+ . reverse+ . applyVisTo+ $ (B.txt <$> logDisplay)+ else B.emptyWidget++-- | Draw the info panel.+infoBox :: AppS -> B.Widget AppName+infoBox appState =+ B.borderWithLabel infoLabel+ . B.hLimit (AppState.getInfoWidth appState)+ . B.padRight B.Max+ . B.padBottom B.Max+ $ bindingBox+ <=> B.hBorderWithLabel modulesLabel+ <=> moduleBox appState+ <=> B.hBorderWithLabel (B.txt "Trace History")+ <=> drawTraceBox appState+ where+ isActive = activeWindow appState == ActiveInfoWindow+ infoLabel = B.txt "Info"+ modulesLabel =+ markLabel+ isActive+ "Modules"+ (if activeWindow appState /= ActiveLiveInterpreter then "[M]" else mempty)+ intState = interpState appState++ bindingBox :: B.Widget AppName+ bindingBox = B.viewport BindingViewport B.Vertical contents+ where+ contents = case NameBinding.renderNamesTxt <$> Daemon.bindings intState of+ Left _ -> B.txt "<Error displaying bindings>"+ Right [] -> B.txt " " -- Can't be an empty widget due to padding?+ Right bs -> B.vBox (B.txtWrapWith wrapSettings <$> bs)+ wrapSettings =+ Wrap.defaultWrapSettings+ { Wrap.preserveIndentation = True+ , Wrap.breakLongWords = True+ , Wrap.fillStrategy = Wrap.FillIndent 2+ }++moduleBox :: AppS -> B.Widget AppName+moduleBox appState =+ B.cached ModulesViewport $+ if null mfmAssocs+ then B.hCenter $ B.txt "<No module mappings>"+ else+ B.withVScrollBars B.OnRight+ . B.viewport ModulesViewport B.Vertical+ $ B.vBox moduleEntries+ where+ mfmAssocs = Loc.moduleFileMapAssocs (Daemon.moduleFileMap (AppState.interpState appState))+ moduleEntries = zipWith mkModEntryWidget [0 ..] mfmAssocs++ mkModEntryWidget :: Int -> (T.Text, FilePath) -> B.Widget n+ mkModEntryWidget idx (modName, fp) =+ if isSelected && isActive+ then+ B.visible+ ( B.withAttr+ (B.attrName "selected-marker")+ (B.txt cursor <+> B.txtWrapWith wrapSettings entryText)+ )+ else B.txt padding <+> B.txt entryText+ where+ isSelected = AppState.getSelectedModuleInInfoPanel appState == idx+ isActive = AppState.activeWindow appState == ActiveInfoWindow+ entryText = modName <> " = " <> T.pack fp+ padding = " "+ cursor = "> "+ wrapSettings =+ Wrap.defaultWrapSettings+ { Wrap.preserveIndentation = True+ , Wrap.breakLongWords = True+ , Wrap.fillStrategy = Wrap.FillIndent 2+ }++-- | Draw the trace box in the info panel.+drawTraceBox :: AppState AppName -> B.Widget AppName+drawTraceBox s = contents+ where+ contents =+ if null traceHist+ then B.txt "<No trace>"+ else B.vBox $ B.txt <$> traceHist+ traceHist :: [T.Text]+ traceHist = Daemon.traceHist (AppState.interpState s)++-- | Mark the label if the first arg is True.+markLabel+ :: Bool+ -- ^ Conditional to mark with.+ -> T.Text+ -- ^ Text to use for the label.+ -> T.Text+ -- ^ Addendum unfocused text.+ -> B.Widget a+markLabel False labelTxt focus = B.txt . appendFocusButton $ labelTxt+ where+ appendFocusButton t = if focus == mempty then t else t <> " " <> focus+markLabel True labelTxt _ =+ B.withAttr (B.attrName "highlight") (B.txt ("#> " <> labelTxt <> " <#"))++-- -------------------------------------------------------------------------------------------------+-- Brick Main+-- -------------------------------------------------------------------------------------------------++-- | Brick main program.+brickApp :: B.App AppS e AppName+brickApp =+ B.App+ { B.appDraw = appDraw+ , B.appChooseCursor = Events.handleCursorPosition+ , B.appHandleEvent = Events.handleEvent+ , B.appStartEvent = pure ()+ , B.appAttrMap =+ const $+ B.attrMap+ V.defAttr+ [ (B.attrName "stop-line", B.fg V.red)+ , (B.attrName "line-numbers", B.fg V.cyan)+ , (B.attrName "selected-line-numbers", B.fg V.yellow)+ , (B.attrName "selected-line", B.bg V.brightBlack)+ , (B.attrName "selected-marker", B.fg V.yellow)+ , (B.attrName "breakpoint-marker", B.fg V.red)+ , (B.attrName "underline", B.style V.underline)+ , (B.attrName "styled", B.fg V.magenta `V.withStyle` V.bold)+ , (B.attrName "highlight", B.style V.standout)+ , (B.attrName "dialog", B.style V.standout)+ ]+ }++-- | Start the Brick UI+launchBrick :: AppConfig.AppConfig -> T.Text -> FilePath -> IO ()+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+ T.putStrLn "GHCiTUI has shut down; have a nice day :)"+ pure ()
+ lib/ghcitui-brick/Ghcitui/Brick/DrawSourceViewer.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE NamedFieldPuns #-}++module Ghcitui.Brick.DrawSourceViewer (drawSourceViewer) where++import qualified Brick as B+import qualified Brick.Widgets.Center as B+import Brick.Widgets.Core ((<+>), (<=>))+import Control.Error (fromMaybe)+import Data.Function ((&))+import Data.Functor ((<&>))+import qualified Data.Text as T+import qualified Data.Vector as Vec+import qualified Graphics.Vty as V+import Lens.Micro ((^.))++import Ghcitui.Brick.AppState (AppState)+import qualified Ghcitui.Brick.AppState as AppState+import Ghcitui.Brick.AppTopLevel (AppName (..))+import qualified Ghcitui.Brick.SourceWindow as SourceWindow+import qualified Ghcitui.Ghcid.Daemon as Daemon+import qualified Ghcitui.Loc as Loc+import qualified Ghcitui.Util as Util++-- | Make the primary viewport widget.+drawSourceViewer :: AppState AppName -> B.Widget AppName+drawSourceViewer s+ | (srcWindow ^. SourceWindow.srcElementsL) /= mempty = drawSourceViewer' s srcWindow+ | not currentlyRunning = notRunningWidget+ | otherwise = noSourceWidget+ where+ currentlyRunning = Daemon.isExecuting (AppState.interpState s)+ srcWindow = s ^. AppState.sourceWindow+ notRunningWidget =+ padWidget splashWidget+ <=> padWidget (B.txt "Nothing executing. Maybe run something?")+ noSourceWidget =+ padWidget splashWidget <=> padWidget (B.txt "Can't display. Source not found.")+ padWidget w =+ B.padTop (B.Pad 3)+ . B.hCenter+ $ B.withAttr (B.attrName "styled") w+ splashWidget = B.txt $ fromMaybe "No splash file loaded." (AppState.splashContents s)++-- -------------------------------------------------------------------------------------------------+-- Source Viewer Drawing Details+-- -------------------------------------------------------------------------------------------------++-- | Information used to compute the gutter status of each line.+data GutterInfo = GutterInfo+ { isStoppedHere :: !Bool+ -- ^ Is the interpreter stopped/paused here?+ , isBreakpoint :: !Bool+ -- ^ Is there a breakpoint here?+ , isSelected :: !Bool+ -- ^ Is this line currently selected by the user?+ , gutterLineNumber :: !Int+ -- ^ What line number is this?+ , gutterDigitWidth :: !Int+ -- ^ How many columns is the gutter line number?+ }++-- | Prepend gutter information on each line in the primary viewport.+prependGutter :: GutterInfo -> B.Widget n -> B.Widget n+prependGutter gi line = makeGutter gi <+> line++{- | Create the gutter section for a given line (formed from GutterInfo).+ This should be cached wherever since there can be thousands of these+ in a source.+-}+makeGutter :: GutterInfo -> B.Widget n+makeGutter GutterInfo{..} =+ lineNoWidget <+> spaceW <+> stopColumn <+> breakColumn <+> spaceW+ where+ spaceW = B.txt " "+ lineNoWidget =+ let attr = B.attrName (if isSelected then "selected-line-numbers" else "line-numbers")+ in B.withAttr attr (B.txt (Util.formatDigits gutterDigitWidth gutterLineNumber))+ breakColumn+ | isSelected && isBreakpoint = B.withAttr (B.attrName "selected-marker") (B.txt "@")+ | isSelected = B.withAttr (B.attrName "selected-marker") (B.txt ">")+ | isBreakpoint = B.withAttr (B.attrName "breakpoint-marker") (B.txt "*")+ | otherwise = spaceW+ stopColumn+ | isStoppedHere = B.withAttr (B.attrName "stop-line") (B.txt "!")+ | otherwise = spaceW++-- | Panel when we have source contents.+drawSourceViewer'+ :: AppState AppName+ -> SourceWindow.SourceWindow AppName T.Text+ -> B.Widget AppName+drawSourceViewer' s sourceWindow = composedTogether+ where+ isSelectedLine :: Int -> Bool+ isSelectedLine lineno = Just lineno == sourceWindow ^. SourceWindow.srcSelectedLineL++ composedTogether :: B.Widget AppName+ composedTogether = SourceWindow.renderSourceWindow createWidget sourceWindow+ where+ createWidget lineno _old lineTxt =+ styliseLine $ composedTogetherHelper lineno lineTxt+ where+ styliseLine w =+ if isSelectedLine lineno+ then -- Add highlighting, then mark it as visible in the viewport.+ B.modifyDefAttr (`V.withStyle` V.bold) w+ else w++ -- Select which line widget we want to draw based on both the interpreter+ -- state and the app state.+ --+ -- It's important that the line information is cached, because+ -- each line is actually pretty expensive to render.+ composedTogetherHelper :: Int -> T.Text -> B.Widget AppName+ composedTogetherHelper lineno lineTxt = lineWidgetCached+ where+ sr = maybe Loc.unknownSourceRange Loc.sourceRange (Daemon.pauseLoc (AppState.interpState s))+ mLineno = Loc.singleify sr+ lineWidget = case mLineno of+ -- This only makes the stopped line widget appear for the start loc.+ Just (singleLine, _) | lineno == singleLine -> stoppedLineW lineTxt+ -- If it's a range, just try to show the range.+ _+ | Loc.isLineInside sr lineno -> stoppedRangeW+ -- Default case (includes selected and non-selected).+ _ -> (\w -> prefixLine (lineno, w)) . B.txt $ lineTxt+ lineWidgetCached = B.cached (SourceWindowLine lineno) lineWidget++ stoppedRangeW :: B.Widget AppName+ stoppedRangeW =+ prefixLine+ ( lineno+ , B.forceAttrAllowStyle (B.attrName "stop-line") (B.txt lineTxt)+ )++ prefixLine :: (Int, B.Widget n) -> B.Widget n+ prefixLine (lineno', w) =+ prependGutter+ (gutterInfoForLine lineno')+ w+ where+ gutterInfoForLine :: Int -> GutterInfo+ gutterInfoForLine lineno =+ GutterInfo+ { isStoppedHere =+ Daemon.pauseLoc (AppState.interpState s)+ <&> Loc.sourceRange+ <&> (`Loc.isLineInside` lineno)+ & fromMaybe False+ , isBreakpoint = lineno `elem` breakpoints+ , gutterLineNumber = lineno+ , gutterDigitWidth = Util.getNumDigits $ sourceWindowLength sourceWindow+ , isSelected = isSelectedLine lineno+ }+ where+ breakpoints :: [Int]+ breakpoints =+ maybe+ mempty+ (\f -> Daemon.getBpInFile f (AppState.interpState s))+ (AppState.selectedFile s)++ originalLookupLineNo :: Int+ originalLookupLineNo =+ Daemon.pauseLoc (AppState.interpState s)+ >>= Loc.startLine . Loc.sourceRange+ & fromMaybe 0++ stoppedLineW :: T.Text -> B.Widget AppName+ stoppedLineW lineTxt =+ let Loc.SourceRange{startCol, endCol} =+ maybe+ Loc.unknownSourceRange+ Loc.sourceRange+ (Daemon.pauseLoc (AppState.interpState s))+ lineWidget = makeStoppedLineWidget lineTxt (startCol, endCol)+ in prefixLine (originalLookupLineNo, lineWidget)++sourceWindowLength :: SourceWindow.SourceWindow n e -> Int+sourceWindowLength = Vec.length . SourceWindow.srcElements++-- | Make the Stopped Line widget (the line where we paused execution)+makeStoppedLineWidget :: T.Text -> Loc.ColumnRange -> B.Widget AppName+makeStoppedLineWidget lineData (Nothing, _) =+ B.forceAttrAllowStyle (B.attrName "stop-line") (B.txt lineData)+makeStoppedLineWidget lineData (Just startCol, Nothing) =+ makeStoppedLineWidget lineData (Just startCol, Just (startCol + 1))+makeStoppedLineWidget lineData (Just startCol, Just endCol) =+ B.forceAttrAllowStyle+ (B.attrName "stop-line")+ ( B.txt lineDataBefore+ <+> B.withAttr (B.attrName "highlight") (B.txt lineDataRange)+ <+> B.txt lineDataAfter+ )+ where+ (lineDataBefore, partial) = T.splitAt (startCol - 1) lineData+ (lineDataRange, lineDataAfter) = T.splitAt (endCol - startCol + 1) partial
+ lib/ghcitui-brick/Ghcitui/Brick/Events.hs view
@@ -0,0 +1,438 @@+{-# 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 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 (..)+ )+import qualified Ghcitui.Brick.SourceWindow as SourceWindow+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.VtyEvent (V.EvResize _ _)) = B.invalidateCache+handleEvent ev = do+ appState <- B.get+ updatedSourceWindow <- SourceWindow.updateSrcWindowEnd (appState ^. AppState.sourceWindow)+ let appStateUpdated = Lens.set AppState.sourceWindow updatedSourceWindow appState+ let handler = case appStateUpdated.activeWindow of+ AppState.ActiveCodeViewport -> handleSrcWindowEvent+ AppState.ActiveLiveInterpreter -> handleInterpreterEvent+ AppState.ActiveInfoWindow -> handleInfoEvent+ AppState.ActiveDialogQuit -> handleDialogQuit+ AppState.ActiveDialogHelp -> handleDialogHelp+ handler ev++-- -------------------------------------------------------------------------------------------------+-- Info Event Handling+----------------------------------------------------------------------------------------------------++handleInfoEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleInfoEvent ev = do+ appState <- B.get+ case ev of+ B.VtyEvent (V.EvKey key _ms)+ | key `elem` [V.KChar 'j', V.KDown] -> do+ B.put $ AppState.changeSelectedModuleInInfoPanel 1 appState+ | key `elem` [V.KChar 'k', V.KUp] -> do+ B.put $ AppState.changeSelectedModuleInInfoPanel (-1) appState+ | key == V.KEnter || key == V.KChar 'o' -> do+ let mayFp = AppState.filePathOfInfoSelectedModule appState+ case mayFp of+ Just _ -> do+ updatedState <- liftIO $ AppState.setSelectedFile mayFp appState+ B.put updatedState+ invalidateLineCache+ Nothing -> pure ()+ | key == V.KEsc || key == V.KChar 'C' -> do+ B.put appState{activeWindow = AppState.ActiveCodeViewport}+ B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) -> do+ B.put appState{activeWindow = AppState.ActiveLiveInterpreter}+ B.VtyEvent (V.EvKey (V.KChar '?') _) -> do+ B.put appState{activeWindow = AppState.ActiveDialogHelp}++ -- Resizing+ B.VtyEvent (V.EvKey (V.KChar '-') []) -> do+ B.put (AppState.changeInfoWidgetSize (-1) appState)+ invalidateLineCache+ B.VtyEvent (V.EvKey (V.KChar '+') []) -> do+ B.put (AppState.changeInfoWidgetSize 1 appState)+ invalidateLineCache+ _ -> pure ()+ 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)+ -- TODO: Should be configurable?+ let interpreterLogLimit = 1000+ let formattedWithPrompt = appState.appConfig.getInterpreterPrompt <> cmd+ let combinedLogs = reverse output <> (formattedWithPrompt : interpLogs appState)+ let newAppState2 =+ writeDebugLog ("Handled Enter: Ran '" <> cmd <> "'")+ . Lens.set (appInterpState . AIS.viewLock) True+ . Lens.over appInterpState (AIS.pushHistory (editorContents appState))+ $ newAppState1+ { interpLogs =+ take interpreterLogLimit combinedLogs+ }+ let appStateFinalIO = updateSourceMap (Lens.set liveEditor newEditor newAppState2)+ B.put =<< liftIO appStateFinalIO+ -- Invalidate the entire render state of the application+ -- because we don't know what's actually changed here now.+ B.invalidateCache+ B.VtyEvent (V.EvKey (V.KChar '\t') []) -> do+ -- Tab completion?+ let cmd = T.strip (T.unlines (editorContents appState))+ (newAppState1, _output) <-+ runDaemon2+ (Daemon.execCleaned (":complete " <> cmd))+ appState+ B.put newAppState1+ B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->+ -- Toggle out of the interpreter.+ leaveInterpreter+ B.VtyEvent (V.EvKey V.KEsc _) -> 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+ 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'+ 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++-- | 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+-- -------------------------------------------------------------------------------------------------++handleDialogQuit :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleDialogQuit ev = do+ appState <- B.get+ case ev of+ (B.VtyEvent (V.EvKey key _))+ | key == V.KChar 'q' || key == V.KEsc -> do+ B.put $ appState{activeWindow = AppState.ActiveCodeViewport}+ | key == V.KEnter -> quit appState+ _ -> pure ()+ pure ()++handleDialogHelp :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()+handleDialogHelp (B.VtyEvent (V.EvKey key _))+ | key == V.KChar 'q' || key == V.KEsc || key == V.KEnter = do+ appState <- B.get+ B.put $ appState{activeWindow = AppState.ActiveCodeViewport}+ | key == V.KPageDown = B.vScrollPage scroller B.Down+ | key == V.KPageUp = B.vScrollPage scroller B.Up+ | key == V.KDown = B.vScrollBy scroller 1+ | key == V.KUp = B.vScrollBy scroller (-1)+ | otherwise = pure ()+ where+ scroller = B.viewportScroll HelpViewport+handleDialogHelp _ = pure ()++-- | Stop the TUI.+quit :: AppState n -> B.EventM n s ()+quit appState = liftIO (Daemon.quit appState.interpState) >> B.halt
+ lib/ghcitui-brick/Ghcitui/Brick/HelpText.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}++module Ghcitui.Brick.HelpText (helpText) where++import Data.String (IsString)++import qualified Data.FileEmbed as FileEmbed++helpText :: (IsString a) => a+helpText = $(FileEmbed.makeRelativeToProject "gen/MANUAL.txt" >>= FileEmbed.embedStringFile)
+ lib/ghcitui-brick/Ghcitui/Brick/SourceWindow.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Ghcitui.Brick.SourceWindow+ ( SourceWindow (srcElements)++ -- * Creation+ , mkSourcWindow++ -- * Rendering+ , renderSourceWindow++ -- * Event Handling+ , ScrollDir (..)+ , scrollTo+ , srcWindowScrollPage+ , updateSrcWindowEnd+ , srcWindowMoveSelectionBy+ , srcWindowReplace+ , setSelectionTo++ -- * Lenses+ , srcElementsL+ , srcNameL+ , srcSelectedLineL+ , srcWindowStartL++ -- * Misc+ , srcWindowLength+ ) where++import qualified Brick as B+import Control.Error (fromMaybe)+import qualified Data.Text as T+import qualified Data.Vector as Vec+import Lens.Micro ((^.))+import qualified Lens.Micro as Lens+import Lens.Micro.TH (makeLensesFor)++import qualified Ghcitui.Util as Util++-- | Hold data regarding a code source viewing window.+data SourceWindow name elem = SourceWindow+ { srcElements :: !(Vec.Vector elem)+ -- ^ The actual entries for each source window.+ , srcWindowStart :: !Int+ -- ^ The starting position of the window, as a line number (1-indexed).+ -- No lines before this line number is rendered.+ , srcWindowEnd :: !(Maybe Int)+ , srcName :: !name+ -- ^ The name of the window.+ , srcSelectedLine :: !(Maybe Int)+ -- ^ The currently selected line in the window.+ }+ deriving (Show)++makeLensesFor+ [ ("srcElements", "srcElementsL")+ , ("srcWindowStart", "srcWindowStartL")+ , ("srcWindowEnd", "srcWindowEndL")+ , ("srcName", "srcNameL")+ , ("srcSelectedLine", "srcSelectedLineL")+ ]+ ''SourceWindow++-- | Render a 'SourceWindow' into a Brick 'B.Widget'.+renderSourceWindow+ :: (Ord n)+ => (Int -> Bool -> e -> B.Widget n)+ -- ^ Render function.+ -> SourceWindow n e+ -- ^ 'SourceWindow' to render.+ -> B.Widget n+ -- ^ The newly created widget.+renderSourceWindow func srcW = B.reportExtent (srcName srcW) (B.Widget B.Greedy B.Greedy renderM)+ where+ renderM = do+ c <- B.getContext+ let availableHeight = c ^. B.availHeightL + 1+ let renderHeight = Util.clamp (1, remainingElements) availableHeight+ let slicedElems = Vec.slice startZeroIdx renderHeight elems+ let drawnElems =+ [ func idx (Just idx == srcSelectedLine srcW) e+ | (idx, e) <- zip [srcWindowStart srcW ..] . Vec.toList $ slicedElems+ ]+ let trailingSpaces = availableHeight - length drawnElems+ -- This is a fairly weird list comprehension, since it either has only one element+ -- or none. But it works, and is for some reason recommended by hlint. Ugh.+ let trailingSpaceWidgets = [B.txt (T.replicate trailingSpaces "\n") | trailingSpaces > 0]+ B.render+ . B.vBox+ $ drawnElems <> trailingSpaceWidgets+ startZeroIdx = Util.clamp (0, srcWindowLength srcW - 1) $ srcWindowStart srcW - 1+ remainingElements = srcWindowLength srcW - startZeroIdx+ elems = srcElements srcW++{- | Return the length of the full contents of the source code stored in the window.++ Note, does NOT return the current length/height/size of the rendered widget.+-}+srcWindowLength :: SourceWindow n e -> Int+srcWindowLength = Vec.length . srcElements++-- | Set the source window end line inside of the given 'EventM' Monad.+updateSrcWindowEnd :: (Ord n) => SourceWindow n e -> B.EventM n m (SourceWindow n e)+updateSrcWindowEnd srcW@SourceWindow{srcWindowStart, srcName} = do+ mExtent <- B.lookupExtent srcName+ let end = case mExtent of+ Just extent ->+ -- -1 offset since the end is inclusive.+ Just $ (snd . B.extentSize $ extent) + srcWindowStart - 1+ _ -> Nothing+ pure (Lens.set srcWindowEndL end srcW)++-- | Scroll to a given position, and move the source line along the way if needed.+scrollTo :: Int -> SourceWindow n e -> SourceWindow n e+scrollTo pos srcW@SourceWindow{srcWindowEnd = Just windowEnd} =+ srcW{srcWindowStart = clampedPos, srcSelectedLine = newSelection}+ where+ clampedPos = Util.clamp (1, srcWindowLength srcW - renderHeight) pos+ newSelection+ | -- Choose the starting line if we're trying to go past the beginning.+ isScrollingPastStart =+ Just 1+ | -- Choose the last line if we're trying to go past the end.+ isScrollingPastEnd =+ Just $ srcWindowLength srcW+ | otherwise = newClampedSelectedLine+ renderHeight = windowEnd - srcWindowStart srcW+ isScrollingPastStart = pos < 1+ isScrollingPastEnd = pos >= srcWindowLength srcW -- Using >= because of a hack.+ newClampedSelectedLine =+ Util.clamp+ (clampedPos, clampedPos + renderHeight)+ <$> srcSelectedLine srcW+scrollTo _ srcW = srcW++-- | Direction to scroll by.+data ScrollDir = Up | Down deriving (Eq, Show)++-- | Scroll by a full page in a direction.+srcWindowScrollPage :: (Ord n) => ScrollDir -> SourceWindow n e -> B.EventM n m (SourceWindow n e)+srcWindowScrollPage dir srcW = srcWindowScrollPage' dir <$> updateSrcWindowEnd srcW++-- | Internal helper.+srcWindowScrollPage' :: ScrollDir -> SourceWindow n e -> SourceWindow n e+srcWindowScrollPage' dir srcW =+ case dir of+ Up ->+ let renderHeight = windowEnd - srcWindowStart srcW+ in scrollTo (srcWindowStart srcW - renderHeight) srcW+ Down -> scrollTo windowEnd srcW+ where+ windowEnd = fromMaybe 1 $ srcWindowEnd srcW++-- | Set the selection to a given position, and scroll the window accordingly.+setSelectionTo+ :: (Ord n)+ => Int+ -- ^ Line number to set the selection to (1-indexed)+ -> SourceWindow n e+ -- ^ Source window to update.+ -> B.EventM n m (SourceWindow n e)+setSelectionTo pos srcW@SourceWindow{srcSelectedLine = Just sl, srcWindowEnd = Just end} =+ if pos < srcWindowStart srcW || pos > end+ then srcWindowMoveSelectionBy delta srcW+ else do+ pure $ srcW{srcSelectedLine = Just pos}+ where+ delta = pos - sl+setSelectionTo _ srcW = pure srcW++-- | Move the selected line by a given amount.+srcWindowMoveSelectionBy+ :: (Ord n)+ => Int+ -- ^ Delta to move the selected line.+ -> SourceWindow n e+ -- ^ Source window to update.+ -> B.EventM n m (SourceWindow n e)+srcWindowMoveSelectionBy amnt sw = do+ srcW' <- updateSrcWindowEnd sw+ case srcWindowEnd srcW' of+ Just end -> do+ let start = srcWindowStart srcW'+ let mSLine = srcSelectedLine srcW'+ let renderHeight = end - start+ pure $ case mSLine of+ Just sLine+ | newSLine < start ->+ scrollTo newSLine srcW'{srcSelectedLine = Just newSLine}+ | newSLine > end ->+ scrollTo (newSLine - renderHeight) srcW'{srcSelectedLine = Just newSLine}+ | otherwise -> srcW'{srcSelectedLine = Just newSLine}+ where+ newSLine = Util.clamp (1, Vec.length (srcElements srcW')) $ sLine + amnt+ _ -> srcW'+ Nothing -> pure srcW'++{- | Replace the contents of a given source window, and reset the pseudo-viewport's position+ to the top.+-}+srcWindowReplace :: (Foldable f) => f e -> SourceWindow n e -> SourceWindow n e+srcWindowReplace foldable srcW =+ srcW{srcSelectedLine = Just 1, srcWindowStart = 1, srcElements = elems}+ where+ elems = Vec.fromList . foldr (:) [] $ foldable++-- | Create a new source window from some text.+mkSourcWindow+ :: n+ -- ^ Name for the source window.+ -> T.Text+ -- ^ Text contents of the source window (to be split up).+ -> SourceWindow n T.Text+mkSourcWindow name text =+ SourceWindow+ { srcElements = lineVec+ , srcWindowStart = 1+ , srcSelectedLine = Just 1+ , srcName = name+ , srcWindowEnd = Nothing+ }+ where+ lineVec = Vec.fromList (T.lines text)
+ lib/ghcitui-brick/Ghcitui/Brick/SplashTextEmbed.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}++module Ghcitui.Brick.SplashTextEmbed (splashText) where++import Data.String (IsString)++import qualified Data.FileEmbed as FileEmbed++splashText :: (IsString a) => a+splashText = $(FileEmbed.makeRelativeToProject "assets/splash.txt" >>= FileEmbed.embedStringFile)
+ lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QuasiQuotes #-}++module Ghcitui.Ghcid.Daemon+ ( -- * The interpreter state+ InterpState+ ( func+ , pauseLoc+ , moduleFileMap+ , breakpoints+ , bindings+ , logLevel+ , logOutput+ , execHist+ , traceHist+ )+ , emptyInterpreterState++ -- * Startup and shutdown+ , startup+ , StartupConfig (..)+ , quit++ -- * Base operations with the daemon+ , exec+ , execCleaned+ , execMuted++ -- * Wrapped operations with the daemon+ , step+ , stepInto+ , load+ , continue++ -- * Breakpoints+ , getBpInCurModule+ , getBpInFile+ , toggleBreakpointLine+ , setBreakpointLine+ , deleteBreakpointLine++ -- * Tracing+ , trace+ , history++ -- * Misc+ , isExecuting+ , BreakpointArg (..)+ , run+ , DaemonIO+ , DaemonError+ , LogOutput (..)+ ) where++import Control.Error+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.String.Interpolate (i)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Language.Haskell.Ghcid as Ghcid+import qualified System.IO as IO++import Ghcitui.Ghcid.LogConfig (LogLevel (..), LogOutput (..))+import qualified Ghcitui.Ghcid.ParseContext as ParseContext+import Ghcitui.Ghcid.StartupConfig (StartupConfig)+import qualified Ghcitui.Ghcid.StartupConfig as StartupConfig+import qualified Ghcitui.Loc as Loc+import qualified Ghcitui.NameBinding as NameBinding+import Ghcitui.Util (showT)+import qualified Ghcitui.Util as Util++data InterpState a = InterpState+ { _ghci :: Ghcid.Ghci+ -- ^ GHCiD handle.+ , func :: !(Maybe T.Text)+ -- ^ Current pause position function name.+ , pauseLoc :: !(Maybe Loc.FileLoc)+ -- ^ Current pause position.+ , moduleFileMap :: !Loc.ModuleFileMap+ -- ^ Mapping between modules and their filepaths.+ , stack :: [T.Text]+ -- ^ Program stack (only available during tracing).+ , breakpoints :: [(Int, Loc.ModuleLoc)]+ -- ^ Currently set breakpoint locations.+ , bindings :: Either DaemonError [NameBinding.NameBinding T.Text]+ -- ^ Current context value bindings.+ , status :: !(Either T.Text a)+ -- ^ IDK? I had an idea here at one point.+ , logLevel :: !LogLevel+ -- ^ How much should we log?+ , logOutput :: !LogOutput+ -- ^ Where should we log to?+ , execHist :: ![T.Text]+ -- ^ What's the execution history? Note: different from trace history.+ , traceHist :: ![T.Text]+ -- ^ Trace history.+ }++instance Show (InterpState a) where+ show s =+ let func' = show s.func+ msg = case s.pauseLoc of+ Just (Loc.FileLoc filepath' Loc.SourceRange{..}) ->+ let srcRngFmt :: String+ srcRngFmt =+ [i|{sourceRange=(#{startLine},#{startCol})-(#{endLine},#{endCol})}|]+ in [i|{func=#{func'}, filepath=#{filepath'}, #{srcRngFmt}}|]+ _ -> "<unknown pause location>" :: String+ in msg++{- | 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+ }++-- | Reset anything context-based in a 'InterpState'.+contextReset :: (Monoid a) => InterpState a -> InterpState a+contextReset state =+ state+ { func = Nothing+ , pauseLoc = Nothing+ , stack = mempty+ , bindings = Right mempty+ , status = Right mempty+ , traceHist = mempty+ }++-- | Append a string to the interpreter's history.+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?+isExecuting :: InterpState a -> Bool+isExecuting InterpState{func = Nothing} = False+isExecuting InterpState{func = Just _} = True++-- | Start up the GHCi Daemon.+startup+ :: String+ -- ^ Command to run (e.g. "ghci" or "cabal repl")+ -> FilePath+ -- ^ Working directory to run the start up command in.+ -> StartupConfig+ -- ^ Where do we put the logging?+ -> DaemonIO (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+ logDebug "|startup| GHCi Daemon initted" state+ updateState state++startupStreamCallback :: Ghcid.Stream -> String -> IO ()+startupStreamCallback stream msg = do+ IO.hPutStrLn handle [i|[ghcid startup:#{prefix}] #{msg}|]+ IO.hFlush handle+ where+ (handle, prefix) = case stream of+ Ghcid.Stdout -> (IO.stdout, "out" :: String)+ Ghcid.Stderr -> (IO.stderr, "err" :: String)++-- | Shut down the GHCi Daemon.+quit :: InterpState a -> IO (InterpState a)+quit state = do+ Ghcid.quit (state._ghci)+ pure state++-- | Update the interpreter state. Wrapper around other updaters.+updateState :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)+updateState state =+ updateContext state+ >>= updateBindingsWithErrorHandling+ >>= updateModuleFileMap+ >>= updateBreakList+ >>= updateTraceHistory+ where+ -- Make a wrapper so we don't fail on updating bindings.+ -- Parsing bindings turns out to be actually impossible to solve+ -- with the current ':show bindings' output, so try our best+ -- and keep going.+ updateBindingsWithErrorHandling s = updateBindings s `catchE` catchBindings s+ catchBindings s er = pure s{bindings = Left er}++-- | Update the current interpreter context.+updateContext :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)+updateContext state@InterpState{_ghci} = do+ logDebug "|updateContext| CMD: :show context\n" state+ msgs <- liftIO $ Ghcid.exec _ghci ":show context"+ let feedback = ParseContext.cleanResponse (T.pack <$> msgs)+ logDebug+ ( "|updateContext| OUT:\n"+ <> Util.linesToText msgs+ <> "\n"+ )+ state+ if T.null feedback+ then pure $ contextReset state -- We exited everything.+ else do+ let ctx = ParseContext.parseContext feedback+ case ctx of+ ParseContext.PCError er -> do+ let msg = [i|Failed to update context: #{er}|]+ logError ("|updateContext| " <> msg) state+ throwE $ UpdateContextError msg+ ParseContext.PCNoContext -> pure $ contextReset state+ ParseContext.PCContext+ ParseContext.ParseContextOut{func, filepath, pcSourceRange} ->+ pure+ state+ { func = Just func+ , pauseLoc = Just $ Loc.FileLoc filepath pcSourceRange+ }++-- | Update the current local bindings.+updateBindings :: InterpState a -> DaemonIO (InterpState a)+updateBindings state@InterpState{_ghci} = do+ logDebug "|updateBindings| CMD: :show bindings\n" state+ msgs <- liftIO (Ghcid.exec _ghci ":show bindings")+ let feedback = ParseContext.cleanResponse (T.pack <$> msgs)+ logDebug+ ( "|updateBindings| OUT:\n"+ <> Util.linesToText msgs+ <> "\n"+ )+ state+ case ParseContext.parseBindings feedback of+ Right bindings -> pure (state{bindings = pure bindings})+ Left er -> do+ logError ("|updateBingings| " <> msg) state+ throwE $ UpdateBindingError msg+ where+ msg = [i|Failed to update bindings: #{er}|]++-- | Update the source map given any app state changes.+updateModuleFileMap :: InterpState a -> DaemonIO (InterpState a)+updateModuleFileMap state@InterpState{_ghci, moduleFileMap} = do+ logDebug "updateModuleFileMap|: CMD: :show modules\n" state+ msgs <- liftIO $ Ghcid.exec _ghci ":show modules"+ let packedMsgs = Util.linesToText msgs+ logDebug [i||updateModuleFileMap|: OUT: #{packedMsgs}\n|] state+ modules <- case ParseContext.parseShowModules packedMsgs of+ Right modules -> pure modules+ Left er -> throwE (GenericError (showT er))+ logDebug [i||updateModuleFileMap| modules: #{modules}|] state+ let addedModuleMap = Loc.moduleFileMapFromList modules+ let newModuleFileMap = addedModuleMap <> moduleFileMap+ pure $ state{moduleFileMap = newModuleFileMap}++updateTraceHistory :: InterpState a -> DaemonIO (InterpState a)+updateTraceHistory state = do+ (newState, eTraceHist) <- history state+ pure $ case eTraceHist of+ Left _ -> newState{traceHist = []}+ Right traceHist -> newState{traceHist}++-- | Analogue to @:step@.+step :: (Monoid a) => InterpState a -> ExceptT DaemonError IO (InterpState a)+step = execMuted ":step"++-- | Analogue to @:step <func>@.+stepInto+ :: (Monoid a)+ => T.Text+ -> InterpState a+ -- ^ Function name to jump to.+ -> ExceptT DaemonError IO (InterpState a)+ -- ^ New interpreter state.+stepInto func = execMuted (":step " <> func)++{- | Analogue to @:history@.+ Returns either a 'Left' error message, or a 'Right' list of trace breakpoints.+-}+history :: InterpState a -> DaemonIO (InterpState a, Either T.Text [T.Text])+history state = do+ msgStrs <- liftIO $ Ghcid.exec (_ghci state) ":history"+ let msgs = T.lines (ParseContext.cleanResponse (T.pack <$> msgStrs))+ logDebug [i||history| OUT:\n#{T.unlines msgs}|] state+ case msgs of+ [] -> throwE (GenericError "':history' unexpectedly returned nothing.")+ [oneLine] ->+ if ParseContext.isHistoryFailureMsg oneLine+ then -- This is probably an error message. Set it as such.+ pure (state, Left oneLine)+ else -- This is a real trace entry... maybe.+ pure (state, Right [oneLine])+ _ -> pure (state, Right msgs)++-- | Analogue to @:continue@. Throws out any messages.+continue :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)+continue = execMuted ":continue"++-- | Analogue to @:trace@, with no arguments. Throws out any messages.+trace :: (Monoid a) => InterpState a -> DaemonIO (InterpState a)+trace = execMuted ":trace"++-- | Analogue to @:load <filepath>@. Throws out any messages.+load :: (Monoid a) => FilePath -> InterpState a -> DaemonIO (InterpState a)+load filepath = execMuted (T.pack $ ":load " <> filepath)++{- | Execute an arbitrary command, as if it was directly written in GHCi.+ It is unlikely you want to call this directly, and instead want to call+ one of the wrapped functions or 'execMuted' or 'execCleaned'.+-}+exec :: (Monoid a) => T.Text -> InterpState a -> ExceptT DaemonError IO (InterpState a, [T.Text])+exec cmd state@InterpState{_ghci} = do+ logDebug ("|exec| CMD: " <> cmd) state+ msgs <- liftIO $ Ghcid.exec _ghci (T.unpack cmd)+ logDebug [i||exec| OUT:\n#{Util.linesToText msgs}\n|] state+ newState <-+ updateState+ ( -- Only append the command to the history if it has something interesting.+ if T.null cmd+ then state+ else appendExecHist cmd state+ )+ pure (newState, fmap T.pack msgs)++-- | 'exec', but throw out any messages.+execMuted :: (Monoid a) => T.Text -> InterpState a -> ExceptT DaemonError IO (InterpState a)+execMuted cmd state = fst <$> exec cmd state++-- | 'exec', but fully clean the message from prompt.+execCleaned+ :: (Monoid a)+ => T.Text+ -> InterpState a+ -> ExceptT DaemonError IO (InterpState a, [T.Text])+execCleaned cmd state = do+ res <- cleaner <$> exec cmd state+ logDebug ("|cleaned|:\n" <> (T.unlines . snd $ res)) state+ pure res+ where+ cleaner (s, ls) = (s, T.lines (ParseContext.cleanResponse ls))++-- | Location info passed to breakpoint functions.+data BreakpointArg+ = -- | Location in the current file.+ LocalLine !Int+ | -- | Location in a module.+ ModLoc Loc.ModuleLoc+ deriving (Show, Eq, Ord)++-- | Toggle a breakpoint (disable/enable) at a given location.+toggleBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)+toggleBreakpointLine loc state+ | Right True <- isSet = deleteBreakpointLine loc state+ | Left x <- isSet = throwE x+ | otherwise = setBreakpointLine loc state+ where+ handleModLoc ml =+ fileLoc >>= \fl -> case (Loc.filepath fl, Loc.startLine (Loc.sourceRange fl)) of+ (filepath, Just lineno) ->+ Right $ lineno `elem` getBpInFile filepath state+ (_, _) -> invalidLoc ml+ where+ fileLoc = maybe (invalidLoc ml) Right (Loc.toFileLoc (moduleFileMap state) ml)++ isSet =+ case loc of+ LocalLine lineno -> Right $ lineno `elem` getBpInCurModule state+ ModLoc ml -> handleModLoc ml++ invalidLoc :: Loc.ModuleLoc -> Either DaemonError a+ invalidLoc ml = Left $ BreakpointError [i|Cannot locate breakpoint position '#{ml}' in module without source|]++-- | Set a breakpoint at a given line.+setBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)+setBreakpointLine loc state = do+ command <- getCommand+ execMuted command state+ where+ getCommand :: DaemonIO T.Text+ getCommand = do+ breakPos <- case loc of+ LocalLine pos -> pure (showT pos)+ ModLoc (Loc.ModuleLoc mod' Loc.SourceRange{startLine, startCol}) ->+ let line = maybe "" showT startLine+ colno = maybe "" showT startCol+ in if line == ""+ then+ throwE+ (BreakpointError "Cannot set breakpoint at unknown line number")+ else pure [i|#{mod'} #{line} #{colno}|]+ pure (":break " <> breakPos)++-- | Delete a breakpoint at a given line.+deleteBreakpointLine :: (Monoid a) => BreakpointArg -> InterpState a -> DaemonIO (InterpState a)+deleteBreakpointLine loc state =+ let convert (LocalLine ll) =+ -- TODO: We really should not consider LocalLines valid for this, because we don't+ -- really know whether it's local to the paused file, or local to the file+ -- we're viewing.+ -- But that's a problem for future me.+ let fakeSourceRange = Loc.srFromLineNo ll+ in do+ pauseLoc <- state.pauseLoc+ Loc.toModuleLoc+ state.moduleFileMap+ (pauseLoc{Loc.fSourceRange = fakeSourceRange})+ convert (ModLoc ml) = Just ml++ -- Get the breakpoint index if it exists.+ idxMaybe =+ convert loc >>= \ml ->+ let match x y =+ let srX = Loc.sourceRange x+ srY = Loc.sourceRange y+ in Loc.startLine srX == Loc.startLine srY+ && Loc.endLine srY == Loc.endLine srY+ in headMay+ [ idx+ | (idx, otherML) <- state.breakpoints+ , match ml otherML+ ]+ in case idxMaybe of+ Just num -> execMuted (":delete " <> showT num) state+ Nothing -> do+ logDebug+ ( [i|No breakpoint at '#{show loc}'; |]+ <> [i|breakpoints are found at #{show (breakpoints state)}|]+ )+ state+ pure state++updateBreakList :: InterpState a -> ExceptT DaemonError IO (InterpState a)+updateBreakList state@InterpState{_ghci} = do+ logDebug "|updateBreakList| CMD: :show breaks\n" state+ msgs <- liftIO (Ghcid.exec _ghci ":show breaks")+ logDebug+ ( "|updateBreakList| OUT:\n"+ <> Util.linesToText msgs+ )+ state+ let response = ParseContext.cleanResponse (T.pack <$> msgs)+ case ParseContext.parseShowBreaks response of+ Right breakpoints -> pure state{breakpoints}+ Left er -> throwE (UpdateBreakListError [i|parsing breakpoint list: #{er}|])++-- | Return a list of breakpoint line numbers in the currently paused file.+getBpInCurModule :: InterpState a -> [Int]+getBpInCurModule InterpState{pauseLoc = Nothing} = []+getBpInCurModule s@InterpState{pauseLoc = Just Loc.FileLoc{filepath = fp}} = getBpInFile fp s++-- | Return a list of breakpoint line numbers in the given filepath.+getBpInFile :: FilePath -> InterpState a -> [Int]+getBpInFile fp state =+ catMaybes+ [ Loc.startLine (Loc.sourceRange loc)+ | loc <- breakpointlocs+ , Loc.filepath loc == fp+ ]+ where+ -- Convert between module locations and file locations+ convert (_, x) = Loc.toFileLoc (moduleFileMap state) x+ breakpointlocs = mapMaybe convert (breakpoints state)++-- ------------------------------------------------------------------------------------------------++-- | Log a message at the Debug level.+logDebug :: (MonadIO m) => T.Text -> InterpState a -> m ()+logDebug msg state =+ liftIO $ do+ when (logLevel state >= LogLevel 2) $+ logHelper output "[DEBUG]: " msg+ where+ output = logOutput state++-- Log a message at the Error level.+logError :: (MonadIO m) => T.Text -> InterpState a -> m ()+logError msg state =+ liftIO $ do+ when (logLevel state >= LogLevel 0) $+ logHelper output "[ERROR]: " msg+ where+ output = logOutput state++logHelper+ :: (MonadIO m)+ => LogOutput+ -- ^ Where to log?+ -> T.Text+ -- ^ prefix+ -> T.Text+ -- ^ Message+ -> m ()+logHelper outputLoc prefix msg = do+ liftIO $ case outputLoc of+ LogOutputFile path -> T.appendFile path fmtMsg+ LogOutputStdOut -> T.putStrLn fmtMsg+ LogOutputStdErr -> T.hPutStrLn IO.stderr fmtMsg+ where+ fmtMsg = T.unlines [prefix <> line | line <- T.lines msg]++-- ------------------------------------------------------------------------------------------------+-- Misc++data DaemonError+ = GenericError T.Text+ | UpdateBindingError T.Text+ | UpdateBreakListError T.Text+ | BreakpointError T.Text+ | UpdateContextError T.Text+ deriving (Eq, Show)++{- | An IO operation that can fail into a DaemonError.+ Execute them to IO through 'run'.+-}+type DaemonIO r = ExceptT DaemonError IO r++-- | Convert Daemon operation to an IO operation.+run :: DaemonIO r -> IO (Either DaemonError r)+run = runExceptT
+ lib/ghcitui-core/Ghcitui/Ghcid/LogConfig.hs view
@@ -0,0 +1,7 @@+module Ghcitui.Ghcid.LogConfig where++-- | Determines how verbose logging should be.+newtype LogLevel = LogLevel Int deriving (Eq, Ord, Show)++-- | Determines where the daemon logs are written.+data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath deriving (Show)
+ lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QuasiQuotes #-}++module Ghcitui.Ghcid.ParseContext+ ( ParseContextOut (..)+ , ParseContextReturn (..)+ , NameBinding (..)+ , BindingValue (..)+ , parseContext+ , parseBreakResponse+ , parseBindings+ , parseShowBreaks+ , parseShowModules+ , isHistoryFailureMsg+ , cleanResponse+ , ParseError (..)+ ) where++import Prelude hiding (lines)++import Control.Applicative ((<|>))+import Control.Error+import Data.Array ((!))+import Data.String.Interpolate (i)+import qualified Data.Text as T+import Text.Regex.TDFA (MatchResult (..), (=~~))+import qualified Text.Regex.TDFA as Regex++import qualified Ghcitui.Loc as Loc+import Ghcitui.NameBinding+import Ghcitui.Util++ghcidPrompt :: T.Text+ghcidPrompt = "#~GHCID-START~#"++newtype ParseError = ParseError T.Text deriving (Show, Eq)++-- | Output record datatype for 'parseContext'.+data ParseContextOut = ParseContextOut+ { func :: !T.Text+ , filepath :: !FilePath+ , pcSourceRange :: !Loc.SourceRange+ }+ deriving (Show)++data ParseContextReturn = PCError ParseError | PCNoContext | PCContext ParseContextOut++-- | Parse the output from ":show context" for the interpreter state.+parseContext :: T.Text -> ParseContextReturn+parseContext contextText =+ case eInfoLine contextText of+ Right (func, rest) ->+ let sourceRange = parseSourceRange rest+ in case parseFile rest of+ Right f -> PCContext (ParseContextOut func f sourceRange)+ Left e -> PCError e+ Left (ParseError e) ->+ let contextTextLines = T.lines contextText+ in if all (`elem` ["", "()"]) contextTextLines+ then PCNoContext+ else PCError (ParseError [i| parsing context: #{e}|])++parseFile :: T.Text -> Either ParseError FilePath+parseFile s+ | Just mr <- s =~~ ("^[ \t]*([^:]*):" :: T.Text) = Right (T.unpack (mrSubs mr ! 1))+ | otherwise = Left (ParseError [i|Could not parse file from: '#{s}'|])++-- | Parse a source range structure into a SourceRange object.+parseSourceRange :: T.Text -> Loc.SourceRange+parseSourceRange s+ -- Matches (12,34)-(56,78)+ | Just mr <- matches "\\(([0-9]+),([0-9]+)\\)-\\(([0-9]+),([0-9]+)\\)" = fullRange mr+ -- Matches 12:34-56+ | Just mr <- matches "([0-9]+):([0-9]+)-([0-9]+)" = lineColRange mr+ -- Matches 12:34+ | Just mr <- matches "([0-9]+):([0-9]+)" = lineColSingle mr+ -- Matches 12+ | Just mr <- matches "([0-9]+)" = onlyLine mr+ | otherwise = Loc.unknownSourceRange+ where+ matches :: T.Text -> Maybe (MatchResult T.Text)+ matches reg = s =~~ reg++ unpackRead :: (Read a) => MatchResult T.Text -> Int -> Maybe a+ unpackRead mr idx = readMay (T.unpack (mrSubs mr ! idx))++ fullRange :: MatchResult T.Text -> Loc.SourceRange+ fullRange mr =+ let startLine = unpackRead mr 1+ startCol = unpackRead mr 2+ endLine = unpackRead mr 3+ endCol = unpackRead mr 4+ in Loc.SourceRange{startLine, startCol, endLine, endCol}++ lineColRange :: MatchResult T.Text -> Loc.SourceRange+ lineColRange mr =+ let startLine = unpackRead mr 1+ startCol = unpackRead mr 2+ endLine = startLine+ endCol = unpackRead mr 3+ in Loc.SourceRange{startLine, startCol, endLine, endCol}++ lineColSingle :: MatchResult T.Text -> Loc.SourceRange+ lineColSingle mr =+ let startLine = unpackRead mr 1+ startCol = unpackRead mr 2+ endLine = startLine+ endCol = fmap (+ 1) startCol+ in Loc.SourceRange{startLine, startCol, endLine, endCol}++ onlyLine :: MatchResult T.Text -> Loc.SourceRange+ onlyLine mr =+ let startLine = unpackRead mr 1+ startCol = Nothing+ endLine = startLine+ endCol = Nothing+ in Loc.SourceRange{startLine, startCol, endLine, endCol}++{- | Converts a multiline contextText from:++ Stopped in Foo.Bar, other stuff here+ more stuff that doesn't match+ even more stuff++ into ("Foo.Bar", "other stuff here") if the text matches.+-}+eInfoLine :: T.Text -> Either ParseError (T.Text, T.Text)+eInfoLine "" = Left $ ParseError "Could not find info line in empty string"+eInfoLine contextText =+ note+ (ParseError $ "Could not match info line: '" <> showT splits <> "'")+ stopLine+ where+ splits = splitBy ghcidPrompt contextText+ stopLineMR = foldr (\n acc -> acc <|> stopReg n) Nothing splits+ stopLine = (\mr -> (mrSubs mr ! 1, mrSubs mr ! 2)) <$> stopLineMR+ -- Match on the "Stopped in ..." line.+ stopReg :: T.Text -> Maybe (MatchResult T.Text)+ stopReg s = s =~~ ("^[ \t]*Stopped in ([[:alnum:]_.()]+),(.*)" :: T.Text)++parseBreakResponse :: T.Text -> Either T.Text [Loc.ModuleLoc]+parseBreakResponse t+ | Just xs <- mapM matching (T.lines t) =+ let+ parseEach :: MatchResult T.Text -> Loc.ModuleLoc+ parseEach mr =+ let moduleName = mr.mrSubs ! 2+ startLine = readMay $ T.unpack $ mr.mrSubs ! 3+ endLine = startLine+ startCol = readMay $ T.unpack $ mr.mrSubs ! 4+ endCol = readMay $ T.unpack $ mr.mrSubs ! 5+ in Loc.ModuleLoc moduleName Loc.SourceRange{startLine, startCol, endLine, endCol}+ in+ Right $ parseEach <$> xs+ | otherwise = Left ("Could not parse breakpoint from: " <> t)+ where+ breakpointReg =+ "Breakpoint (.*) activated at (.*):([0-9]*):([0-9]*)(-[0-9]*)?" :: T.Text+ matching :: T.Text -> Maybe (MatchResult T.Text)+ matching = (=~~ breakpointReg)++-- | Parse the output from ":show breaks"+parseShowBreaks+ :: T.Text+ -- ^ Message to parse.+ -> Either T.Text [(Int, Loc.ModuleLoc)]+ -- ^ Tuples are (breakpoint index, location).+parseShowBreaks t+ | Just xs <- (mapM matching . T.lines) response = traverse parseEach xs+ | response == "No active breakpoints." = Right mempty+ | otherwise = Left (T.pack ("Response was" ++ show response))+ where+ response = T.strip t+ breakpointReg =+ "\\[([0-9]+)\\] +(.*) +([^:]*):(.*) +([a-zA-Z_-]+)" :: T.Text++ matching :: T.Text -> Maybe (MatchResult T.Text)+ matching = (=~~ breakpointReg)++ parseEach :: MatchResult T.Text -> Either T.Text (Int, Loc.ModuleLoc)+ parseEach mr =+ let+ -- Don't need to use readMay because regex.+ eIdx = readErr "Failed to read index" $ T.unpack $ mr.mrSubs ! 1+ module_ = mr.mrSubs ! 2+ _filepath = Just $ mr.mrSubs ! 3 -- Not used currently but could be useful?+ sourceRange = parseSourceRange $ mr.mrSubs ! 4+ enabled = case mr.mrSubs ! 5 of+ "enabled" -> Right True+ "disabled" -> Right False+ x -> Left ("Breakpoint neither enabled nor disabled: " <> x)+ in+ case (sourceRange, eIdx) of+ (_, Right idx)+ | sourceRange == Loc.unknownSourceRange ->+ Left ("Could not parse source range for breakpoint " <> showT idx)+ | otherwise ->+ enabled >> Right (idx, Loc.ModuleLoc module_ sourceRange)+ (_, Left e) -> Left e++-- | Parse the output of ":show modules".+parseShowModules :: T.Text -> Either ParseError [(T.Text, FilePath)]+parseShowModules t+ | T.null stripped = Right []+ | Just xs <- matchingLines =+ let+ parseEach :: MatchResult T.Text -> (T.Text, FilePath)+ parseEach mr = (mr.mrSubs ! 1, T.unpack $ mr.mrSubs ! 2)+ in+ Right $ parseEach <$> xs+ | otherwise = Left (ParseError [i|Failed to parse ':show modules': #{stripped}|])+ where+ stripped = T.strip t+ matchingLines = mapMaybe matching . T.lines <$> lastMay (splitBy ghcidPrompt stripped)+ reg = "([[:alnum:]_.]+)[ \\t]+\\( *([^,]*),.*\\)" :: T.Text+ matching :: T.Text -> Maybe (MatchResult T.Text)+ matching = (=~~ reg)++-- Sometimes there's lines that are just Unit '()'. Unsure+-- what they are meant to represent in the binding list.+dropUnitLines :: [T.Text] -> [T.Text]+dropUnitLines = filter (\x -> T.strip x /= "()")++-- | Parse the output of ":show bindings".+parseBindings :: T.Text -> Either T.Text [NameBinding T.Text]+parseBindings t+ | T.null stripped = Right []+ | Just xs <- mapM (=~~ reg) (dropUnitLines (mergeBindingLines (T.lines stripped))) =+ let+ parseEach :: MatchResult T.Text -> NameBinding T.Text+ parseEach mr = NameBinding (mr.mrSubs ! 1) (mr.mrSubs ! 2) (Evald $ mr.mrSubs ! 3)+ in+ Right $ parseEach <$> xs+ | otherwise = Left ("Failed to parse ':show bindings':\n" <> stripped)+ where+ stripped = T.strip t++ mergeBindingLines :: [T.Text] -> [T.Text]+ mergeBindingLines [] = []+ mergeBindingLines [x] = [x]+ mergeBindingLines (x1 : x2 : xs) =+ case T.uncons x2 of+ Just (' ', rest) ->+ let newLine = (T.strip x1 <> " " <> T.strip rest)+ in mergeBindingLines (newLine : xs)+ _ -> x1 : mergeBindingLines (x2 : xs)++ {- They look like...+ ghci> :show bindings+ somethingLong ::+ [AVeryLong+ SubType+ -> SomeResultType] = value+ _result :: Int = _+ it :: () = ()+ -}+ reg = "([a-z_][[:alnum:]_.']*) +:: +(.*) += +(.*)" :: T.Text++-- | Whether a given text line represents a failed history lookup.+isHistoryFailureMsg :: T.Text -> Bool+isHistoryFailureMsg text = (reg `Regex.match` text) || (reg2 `Regex.match` text)+ where+ execOption = Regex.ExecOption False+ compOption = Regex.defaultCompOpt{Regex.caseSensitive = False}+ makeRegex :: T.Text -> Regex.Regex+ makeRegex = Regex.makeRegexOpts compOption execOption+ reg = makeRegex "not +stopped +at +a +breakpoint"+ reg2 = makeRegex "empty history(\\.)?"++{- | Clean up GHCID exec returned messages/feedback.++Frequently, "exec" may include various GHCID prompts in its+returned messages. Return only the last prompt output, which seems to+include what we want fairly consistently.++Additionally, pack the lines into a single T.Text block.+-}+cleanResponse :: [T.Text] -> T.Text+cleanResponse =+ T.unlines+ . dropUnitLines+ . T.lines+ . lastDef ""+ . splitBy ghcidPrompt+ . T.unlines
+ lib/ghcitui-core/Ghcitui/Ghcid/StartupConfig.hs view
@@ -0,0 +1,11 @@+module Ghcitui.Ghcid.StartupConfig (StartupConfig (..)) where++import Ghcitui.Ghcid.LogConfig (LogLevel, LogOutput)++-- | Configuration passed during Daemon 'startup'+data StartupConfig = StartupConfig+ { logLevel :: !LogLevel+ -- ^ How much do we want to log?+ , logOutput :: !LogOutput+ -- ^ Where do we log?+ }
+ lib/ghcitui-core/Ghcitui/Loc.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Ghcitui.Loc+ ( -- * Code locations within a file++ -- Types and functions for handling code within a single file or module.+ SourceRange (..)+ , HasSourceRange (..)+ , unknownSourceRange+ , isLineInside+ , srFromLineNo+ , singleify+ , ColumnRange++ -- * Code in files and modules+ -- $modulesAndFiles+ , FileLoc (..)+ , ModuleLoc (..)+ , toModuleLoc+ , toFileLoc++ -- * Converting between modules and source files+ , ModuleFileMap+ , moduleFileMapFromList+ , moduleFileMapAssocs+ , getPathOfModule+ , getModuleOfPath+ ) where++import Data.Map.Strict as Map+import Data.Maybe (isNothing)+import qualified Data.Text as T+import Control.Error (headMay)++-- ------------------------------------------------------------------------------------------------++-- | Range, mapping start to end.+type ColumnRange = (Maybe Int, Maybe Int)++-- | Represents a multi-line range from one character to another in a source file.+data SourceRange = SourceRange+ { startLine :: !(Maybe Int)+ -- ^ Start of the source range, inclusive.+ , startCol :: !(Maybe Int)+ -- ^ Start column of the source range, inclusive.+ , endLine :: !(Maybe Int)+ -- ^ End of the source range, inclusive.+ , endCol :: !(Maybe Int)+ -- ^ End column of the source range, EXCLUSIVE.+ }+ deriving (Show, Eq, Ord)++-- | A source range that represents an unknown location.+unknownSourceRange :: SourceRange+unknownSourceRange = SourceRange Nothing Nothing Nothing Nothing++-- | Create a source range from a single line number.+srFromLineNo :: Int -> SourceRange+srFromLineNo lineno = unknownSourceRange{startLine = Just lineno, endLine = Just lineno}++{- | Return whether a given line number lies within a given source range.++>>> let sr = (srFromLineNo 1) { endLine = 3 }+>>> isLineInside sr <$> [0, 1, 2, 3, 5]+[False, True, True, True, False]+-}+isLineInside :: SourceRange -> Int -> Bool+isLineInside SourceRange{startLine = Just sl, endLine = Just el} num = num >= sl && num <= el+isLineInside SourceRange{startLine = Just sl, endLine = Nothing} num = num >= sl+isLineInside _ _ = False++-- | Convert a 'SourceRange' to potentially a single line and 'ColumnRange'.+singleify :: SourceRange -> Maybe (Int, ColumnRange)+singleify sr+ | isNothing sl = Nothing+ | sl == endLine sr = do+ lineno <- sl+ pure (lineno, (startCol sr, endCol sr))+ | otherwise = Nothing+ where+ sl = startLine sr++-- ------------------------------------------------------------------------------------------------++{- $modulesAndFiles+GHCi talks about code ranges in both files and modules inconsistently. 'ModuleLoc' and+'FileLoc' are types representing each code range. In general, locations as 'FileLoc's+are easier to manage.+-}++-- | Location in a module (may not have a corresponding source file).+data ModuleLoc = ModuleLoc+ { modName :: !T.Text+ , mSourceRange :: !SourceRange+ }+ deriving (Show, Eq, Ord)++-- | Location in a file (may not have a corresponding module).+data FileLoc = FileLoc+ { filepath :: !FilePath+ , fSourceRange :: !SourceRange+ }+ deriving (Show, Eq, Ord)++class HasSourceRange a where+ -- | Retrieve the source range from this source location.+ sourceRange :: a -> SourceRange++instance HasSourceRange FileLoc where+ sourceRange = fSourceRange++instance HasSourceRange ModuleLoc where+ sourceRange = mSourceRange++newtype ModuleFileMap = ModuleFileMap (Map.Map T.Text FilePath) deriving (Show, Eq)++instance Semigroup ModuleFileMap where+ ModuleFileMap a <> ModuleFileMap b = ModuleFileMap $ a <> b++instance Monoid ModuleFileMap where+ mempty = ModuleFileMap mempty++-- | Create a 'ModuleFileMap' from an association list.+moduleFileMapFromList :: [(T.Text, FilePath)] -> ModuleFileMap+moduleFileMapFromList = ModuleFileMap . Map.fromList++-- | Return mappings between a module name and a filepath.+moduleFileMapAssocs :: ModuleFileMap -> [(T.Text, FilePath)]+moduleFileMapAssocs (ModuleFileMap map_) = Map.assocs map_++-- | Convert a module to a @FilePath@.+getPathOfModule :: ModuleFileMap -> T.Text -> Maybe FilePath+getPathOfModule (ModuleFileMap ms) mod' = Map.lookup mod' ms++-- | Convert a @FilePath@ to a module name.+getModuleOfPath :: ModuleFileMap -> FilePath -> Maybe T.Text+getModuleOfPath (ModuleFileMap ms) fp = headMay [mod' | (mod', fp') <- Map.assocs ms, fp' == fp]++-- | Convert a 'FileLoc' to a 'ModuleLoc'.+toModuleLoc :: ModuleFileMap -> FileLoc -> Maybe ModuleLoc+toModuleLoc mfm fl = convert fl.filepath+ where+ makeModuleLoc txt' = ModuleLoc txt' (sourceRange fl)+ convert fp = makeModuleLoc <$> getModuleOfPath mfm fp++-- | Convert a 'ModuleLoc' to a 'FileLoc'.+toFileLoc :: ModuleFileMap -> ModuleLoc -> Maybe FileLoc+toFileLoc mfm ml = convert ml.modName+ where+ makeFileLoc txt' = FileLoc txt' (sourceRange ml)+ convert mn = makeFileLoc <$> getPathOfModule mfm mn
+ lib/ghcitui-core/Ghcitui/NameBinding.hs view
@@ -0,0 +1,25 @@+module Ghcitui.NameBinding (NameBinding (..), BindingValue (..), renderNamesTxt) where++import qualified Data.Text as T++-- | Value associated with a binding.+data BindingValue a = Uneval | Evald a deriving (Eq, Show)++-- | Represents a binding in the local context.+data NameBinding t = NameBinding+ { bName :: t+ -- ^ Name of the binding.+ , bType :: t+ -- ^ Type of the binding.+ , bValue :: BindingValue t+ -- ^ Value of the binding.+ }+ deriving (Eq, Show)++-- | Display the name bindings together into a group of Texts.+renderNamesTxt :: (Functor f) => f (NameBinding T.Text) -> f T.Text+renderNamesTxt ns = onEach <$> ns+ where+ valueRender Uneval = "_"+ valueRender (Evald v) = v+ onEach nb = T.concat [bName nb, " :: ", bType nb, " = ", valueRender . bValue $ nb]
+ lib/ghcitui-core/Ghcitui/Util.hs view
@@ -0,0 +1,55 @@+module Ghcitui.Util (showT, splitBy, linesToText, clamp, getNumDigits, formatDigits) where++import Data.Text (Text, breakOn, drop, length, pack)+import Prelude hiding (drop, length)++-- | Split text based on a delimiter.+splitBy+ :: Text+ -- ^ Delimeter.+ -> Text+ -- ^ Text to split on.+ -> [Text]+splitBy "" source = [source]+splitBy delim source =+ case breakOn delim source of+ (l, "") -> [l]+ (l, r) -> l : splitBy delim (drop (length delim) r)++-- | Convert Strings to Text.+linesToText :: [String] -> Text+linesToText = pack . Prelude.unlines++-- | 'show' but to Text.+showT :: (Show a) => a -> Text+showT = pack . show++-- 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++-- | Format digits into a string with padding.+formatDigits+ :: Int+ -- ^ Number of spaces+ -> Int+ -- ^ Number to format digits of+ -> Text+ -- ^ Formatted Text+formatDigits spacing num = pack (replicate amount ' ') <> pack (show num)+ where+ amount = spacing - getNumDigits num++clamp+ :: (Ord a)+ => (a, a)+ -- ^ The minimum and maximum (inclusive)+ -> a+ -- ^ Value to clamp+ -> a+ -- ^ Result+clamp (mi, mx) v+ | v < mi = mi+ | v > mx = mx+ | otherwise = v
+ test/LocSpec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module LocSpec where++import Ghcitui.Loc+import Test.Hspec++spec :: Spec+spec = do+ describe "module/file mappings" $ do+ let mfmA = moduleFileMapFromList [("A.Module.Name", "some/filepath")]+ let mfmB = moduleFileMapFromList [("Another.Module.Name", "some/other/filepath")]+ it "can convert a module name to file path" $ do+ getPathOfModule mfmA "A.Module.Name" `shouldBe` Just "some/filepath"+ it "can convert a file path to a module name" $ do+ getModuleOfPath mfmA "some/filepath" `shouldBe` Just "A.Module.Name"+ it "can merge ModuleFileMaps" $ do+ let merged = mfmB <> mfmA+ getModuleOfPath merged "some/other/filepath"+ `shouldBe` Just "Another.Module.Name"+ getModuleOfPath merged "some/filepath"+ `shouldBe` Just "A.Module.Name"
+ test/Spec.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.Hspec++import qualified LocSpec+import qualified UtilSpec++main :: IO ()+main = hspec $ do+ LocSpec.spec+ UtilSpec.spec
+ test/UtilSpec.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++module UtilSpec where++import Test.Hspec++import Ghcitui.Util++spec :: Spec+spec = do+ describe "splitBy" $ do+ it "should not edit an empty text" $ do+ splitBy "a" "" `shouldBe` [""]+ it "should not split with an empty delimiter" $ do+ splitBy "" "a" `shouldBe` ["a"]+ it "should split by a delim" $ do+ splitBy "a" "a" `shouldBe` ["", ""]+ splitBy "b" "aba" `shouldBe` ["a", "a"]