diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/MANUAL.rst b/MANUAL.rst new file mode 100644 --- /dev/null +++ b/MANUAL.rst @@ -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 `` flag. + + +.. code-block:: bash + + $ ghcitui -C some/other/directory + + +******** +Stopping +******** + +To quit, press ```` or ``q`` while in the code viewport panel to quit. +While not in the code viewport panel, you may press ```` to get to the +viewport panel. + +------ +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 +```` key, and you can always quit by hitting ```` in the Source Viewer +panel. + +On top of each panel is a label where the navigation key combination is located. +For example, the key combination above the Modules panel displays ``[M]``. +Pressing this key combination will move the focus to that panel. + +----------- +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. +- ````, ``q``: Quit. +- ````, ``k``: Move the cursor up. (``j`` and ``k`` from Vim keybinds) +- ````, ``j``: Move the cursor down. (``j`` and ``k`` from Vim keybinds). +- ````: Move the source viewer one page up. +- ````: 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. +- ````: Switch to Source Viewer. +- ```` while in scrolling mode: Exit scrolling mode. +- ````: Scroll back in time through the REPL command history. +- ````: Scroll forward in time through the REPL command history. +- ````: Scroll the Live Interpreter window one page up. +- ````: Scroll the Live Interpreter window one page down. +- ``Ctrl+n``: Toggle scrolling mode. +- ``+``, ``-`` while in scrolling mode: Increase/decrease the live + panel size. +- ````: Enter a command to the REPL. + +******* +Modules +******* + +- ``?``: Display help inside GHCiTUI. +- ``Ctrl+x``: Switch to the Live Interpreter. +- ````, ``C``: Switch to Source Viewer. +- ````, ``k``: Move the module selection up. +- ````, ``j``: Move the module selection down. +- ``+``, ``-``: Increase/decrease the info panel size. +- ````, ``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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# GHCiTUI: Interactive terminal interface for the Glasgow Haskell Compiler + +``` + / ______ __ __ ______ __ + // /\ ___\ /\ \_\ \ /\ ___\ /\_\ + // ___\ \ \__ \_\ \ __ \_\ \ \_____\ \ \___ +' , _ // \ \ \_____\ \ \_\ \_\ \ \_____\ \ \_\ \ + / \ // 7 \ \/_____/ \/_/\/_/ \/_____/ \/_/ \ + " \ \ ______ __ __ __ \ + a a \ /\__ _\ /\ \/\ \ /\ \ \ + |_ \ \________\/_/\ \/_\ \ \_\ \_\ \ \________\ + '._ ' \ \_\ \ \_____\ \ \_\ + (' _ ' \/_/ \/_____/ \/_/ +``` + +![GitHub Actions Workflow Status](https://img.shields.io/github/actions/workflow/status/CrystalSplitter/ghcitui/haskell.yaml) + +This is an experimental front-end terminal interface for +`ghci`. It provides a source viewer, keybindings, an interactive +interpreter, and a local context viewer. + +![Splash Image For GHCiTUI](https://media.githubusercontent.com/media/CrystalSplitter/ghcitui/main/docs/assets/20240116_splash.png) + +## 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 ` flag. + +```bash +$ ghcitui -C some/other/directory +``` + +### Quitting the TUI + +Press `` or `q` while in the code viewport panel to quit. While not in the +code viewport panel, you may press `` to get to the viewport panel. + +## 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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/assets/splash.txt b/assets/splash.txt new file mode 100644 --- /dev/null +++ b/assets/splash.txt @@ -0,0 +1,10 @@ + ______ __ __ ______ __ + /\ ___\ /\ \_\ \ /\ ___\ /\_\ + ___\ \ \__ \_\ \ __ \_\ \ \_____\ \ \___ + \ \ \_____\ \ \_\ \_\ \ \_____\ \ \_\ \ + \ \/_____/ \/_/\/_/ \/_____/ \/_/ \ + \ ______ __ __ __ \ + \ /\__ _\ /\ \/\ \ /\ \ \ + \________\/_/\ \/_\ \ \_\ \_\ \ \________\ + \ \_\ \ \_____\ \ \_\ + \/_/ \/_____/ \/_/ diff --git a/docs/assets/20240116_splash.png b/docs/assets/20240116_splash.png new file mode 100644 Binary files /dev/null and b/docs/assets/20240116_splash.png differ diff --git a/gen/MANUAL.txt b/gen/MANUAL.txt new file mode 100644 --- /dev/null +++ b/gen/MANUAL.txt @@ -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 flag. + + $ ghcitui -C some/other/directory + + Stopping + To quit, press or q while in the code viewport panel to quit. + While not in the code viewport panel, you may press to get to + the viewport panel. + +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 key, and you can always quit by hitting in the + Source Viewer panel. + + On top of each panel is a label where the navigation key combination + is located. For example, the key combination above the Modules panel + displays [M]. Pressing this key combination will move the focus to + that panel. + +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. + + • , q: Quit. + + • , k: Move the cursor up. (j and k from Vim keybinds) + + • , j: Move the cursor down. (j and k from Vim keybinds). + + • : Move the source viewer one page up. + + • : 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. + + • : Switch to Source Viewer. + + • while in scrolling mode: Exit scrolling mode. + + • : Scroll back in time through the REPL command history. + + • : Scroll forward in time through the REPL command history. + + • : Scroll the Live Interpreter window one page up. + + • : Scroll the Live Interpreter window one page down. + + • Ctrl+n: Toggle scrolling mode. + + • +, - while in scrolling mode: Increase/decrease the live panel size. + + • : Enter a command to the REPL. + + Modules + • ?: Display help inside GHCiTUI. + + • Ctrl+x: Switch to the Live Interpreter. + + • , C: Switch to Source Viewer. + + • , k: Move the module selection up. + + • , j: Move the module selection down. + + • +, -: Increase/decrease the info panel size. + + • , 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() diff --git a/ghcitui.cabal b/ghcitui.cabal new file mode 100644 --- /dev/null +++ b/ghcitui.cabal @@ -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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick.hs b/lib/ghcitui-brick/Ghcitui/Brick.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick.hs @@ -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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppConfig.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppInterpState.hs @@ -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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppState.hs @@ -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 "" + } diff --git a/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs b/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/AppTopLevel.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs b/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/BrickUI.hs @@ -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 "" + 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 "" + 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 "" + 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 () diff --git a/lib/ghcitui-brick/Ghcitui/Brick/DrawSourceViewer.hs b/lib/ghcitui-brick/Ghcitui/Brick/DrawSourceViewer.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/DrawSourceViewer.hs @@ -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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/Events.hs b/lib/ghcitui-brick/Ghcitui/Brick/Events.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/Events.hs @@ -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 "" (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 diff --git a/lib/ghcitui-brick/Ghcitui/Brick/HelpText.hs b/lib/ghcitui-brick/Ghcitui/Brick/HelpText.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/HelpText.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/SourceWindow.hs b/lib/ghcitui-brick/Ghcitui/Brick/SourceWindow.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/SourceWindow.hs @@ -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) diff --git a/lib/ghcitui-brick/Ghcitui/Brick/SplashTextEmbed.hs b/lib/ghcitui-brick/Ghcitui/Brick/SplashTextEmbed.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-brick/Ghcitui/Brick/SplashTextEmbed.hs @@ -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) diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs b/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Ghcid/Daemon.hs @@ -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}}|] + _ -> "" :: 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 @. +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 @. 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 diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/LogConfig.hs b/lib/ghcitui-core/Ghcitui/Ghcid/LogConfig.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Ghcid/LogConfig.hs @@ -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) diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs b/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Ghcid/ParseContext.hs @@ -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 diff --git a/lib/ghcitui-core/Ghcitui/Ghcid/StartupConfig.hs b/lib/ghcitui-core/Ghcitui/Ghcid/StartupConfig.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Ghcid/StartupConfig.hs @@ -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? + } diff --git a/lib/ghcitui-core/Ghcitui/Loc.hs b/lib/ghcitui-core/Ghcitui/Loc.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Loc.hs @@ -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 diff --git a/lib/ghcitui-core/Ghcitui/NameBinding.hs b/lib/ghcitui-core/Ghcitui/NameBinding.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/NameBinding.hs @@ -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] diff --git a/lib/ghcitui-core/Ghcitui/Util.hs b/lib/ghcitui-core/Ghcitui/Util.hs new file mode 100644 --- /dev/null +++ b/lib/ghcitui-core/Ghcitui/Util.hs @@ -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 diff --git a/test/LocSpec.hs b/test/LocSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -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"]