├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── config.yaml.example ├── help.txt ├── screenshot.gif ├── src ├── Control │ ├── Concurrent │ │ └── STM │ │ │ └── TPQueue.hs │ ├── Lens │ │ └── Compat.hs │ └── Monad │ │ └── State │ │ └── Extended.hs ├── Pipes │ └── Concurrent │ │ └── PQueue.hs └── Vgrep │ ├── Ansi.hs │ ├── Ansi │ ├── Parser.hs │ ├── Type.hs │ └── Vty │ │ └── Attributes.hs │ ├── App.hs │ ├── App │ └── Internal.hs │ ├── Command.hs │ ├── Environment.hs │ ├── Environment │ ├── Config.hs │ └── Config │ │ ├── Monoid.hs │ │ ├── Sources.hs │ │ └── Sources │ │ ├── Env.hs │ │ └── File.hs │ ├── Event.hs │ ├── Key.hs │ ├── KeybindingMap.hs │ ├── Parser.hs │ ├── Results.hs │ ├── System │ └── Grep.hs │ ├── Text.hs │ ├── Type.hs │ ├── Widget.hs │ └── Widget │ ├── HorizontalSplit.hs │ ├── HorizontalSplit │ └── Internal.hs │ ├── Pager.hs │ ├── Pager │ └── Internal.hs │ ├── Results.hs │ ├── Results │ └── Internal.hs │ └── Type.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── Data │ └── Text │ │ └── Testable.hs ├── Doctest.hs ├── Spec.hs ├── Test │ ├── Case.hs │ └── Vgrep │ │ ├── Widget.hs │ │ └── Widget │ │ ├── Pager.hs │ │ └── Results.hs └── Vgrep │ ├── Environment │ └── Testable.hs │ └── Widget │ ├── Pager │ └── Testable.hs │ └── Results │ └── Testable.hs └── vgrep.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | .*.swp 18 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: group 43 | 44 | # Folowing options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Long list align style takes effect when import is too long. This is 68 | # determined by 'columns' setting. 69 | # 70 | # - inline: This option will put as much specs on same line as possible. 71 | # 72 | # - new_line: Import list will start on new line. 73 | # 74 | # - new_line_multiline: Import list will start on new line when it's 75 | # short enough to fit to single line. Otherwise it'll be multiline. 76 | # 77 | # - multiline: One line per import list entry. 78 | # Type with contructor list acts like single import. 79 | # 80 | # > import qualified Data.Map as M 81 | # > ( empty 82 | # > , singleton 83 | # > , ... 84 | # > , delete 85 | # > ) 86 | # 87 | # Default: inline 88 | long_list_align: multiline 89 | 90 | # List padding determines indentation of import list on lines after import. 91 | # This option affects 'list_align' and 'long_list_align'. 92 | list_padding: 4 93 | 94 | # Separate lists option affects formating of import list for type 95 | # or class. The only difference is single space between type and list 96 | # of constructors, selectors and class functions. 97 | # 98 | # - true: There is single space between Foldable type and list of it's 99 | # functions. 100 | # 101 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 102 | # 103 | # - false: There is no space between Foldable type and list of it's 104 | # functions. 105 | # 106 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 107 | # 108 | # Default: true 109 | separate_lists: true 110 | 111 | # Language pragmas 112 | - language_pragmas: 113 | # We can generate different styles of language pragma lists. 114 | # 115 | # - vertical: Vertical-spaced language pragmas, one per line. 116 | # 117 | # - compact: A more compact style. 118 | # 119 | # - compact_line: Similar to compact, but wrap each line with 120 | # `{-#LANGUAGE #-}'. 121 | # 122 | # Default: vertical. 123 | style: vertical 124 | 125 | # Align affects alignment of closing pragma brackets. 126 | # 127 | # - true: Brackets are aligned in same collumn. 128 | # 129 | # - false: Brackets are not aligned together. There is only one space 130 | # between actual import and closing bracket. 131 | # 132 | # Default: true 133 | align: true 134 | 135 | # stylish-haskell can detect redundancy of some language pragmas. If this 136 | # is set to true, it will remove those redundant pragmas. Default: true. 137 | remove_redundant: true 138 | 139 | # Replace tabs by spaces. This is disabled by default. 140 | # - tabs: 141 | # # Number of spaces to use for each tab. Default: 8, as specified by the 142 | # # Haskell report. 143 | # spaces: 8 144 | 145 | # Remove trailing whitespace 146 | - trailing_whitespace: {} 147 | 148 | # A common setting is the number of columns (parts of) code will be wrapped 149 | # to. Different steps take this into account. Default: 80. 150 | columns: 80 151 | 152 | # By default, line endings are converted according to the OS. You can override 153 | # preferred format here. 154 | # 155 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 156 | # 157 | # - lf: Convert to LF ("\n"). 158 | # 159 | # - crlf: Convert to CRLF ("\r\n"). 160 | # 161 | # Default: native. 162 | newline: lf 163 | 164 | # Sometimes, language extensions are specified in a cabal file or from the 165 | # command line instead of using language pragmas in the file. stylish-haskell 166 | # needs to be aware of these, so it can parse the file correctly. 167 | # 168 | # No language extensions are enabled by default. 169 | language_extensions: 170 | - LambdaCase 171 | - MultiWayIf 172 | - MultiParamTypeClasses 173 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Stack's standard Travis config, taken from 2 | # http://docs.haskellstack.org/en/stable/GUIDE.html#travis-with-caching 3 | 4 | # Use new container infrastructure to enable caching 5 | sudo: false 6 | 7 | # Choose a lightweight base image; we provide our own build tools. 8 | language: generic 9 | 10 | # GHC depends on GMP. You can add other dependencies here as well. 11 | addons: 12 | apt: 13 | packages: 14 | - libgmp-dev 15 | 16 | # The different configurations we want to test. You could also do things like 17 | # change flags or use --stack-yaml to point to a different file. 18 | matrix: 19 | fast_finish: true 20 | include: 21 | - env: ARGS="" SKIP_DOCTESTS=false 22 | - env: ARGS="--resolver lts" SKIP_DOCTESTS=false 23 | - env: ARGS="--resolver nightly" SKIP_DOCTESTS=false 24 | - env: ARGS="--resolver lts-17" SKIP_DOCTESTS=false 25 | - env: ARGS="--resolver lts-16" SKIP_DOCTESTS=false 26 | - env: ARGS="--resolver lts-15" SKIP_DOCTESTS=false 27 | - env: ARGS="--resolver lts-14" SKIP_DOCTESTS=false 28 | - env: ARGS="--resolver lts-13" SKIP_DOCTESTS=false 29 | - env: ARGS="--resolver lts-12" SKIP_DOCTESTS=false 30 | 31 | before_install: 32 | # Download and unpack the stack executable 33 | - mkdir -p ~/.local/bin 34 | - export PATH=$HOME/.local/bin:$PATH 35 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 36 | 37 | - stack $ARGS --no-terminal setup 38 | - stack $ARGS --no-terminal install hlint hscolour 39 | 40 | script: 41 | - stack $ARGS --no-terminal build --pedantic 42 | 43 | # Tests 44 | - stack $ARGS --no-terminal test --pedantic :vgrep-test 45 | - $SKIP_DOCTESTS || stack $ARGS --no-terminal test --pedantic :doctest 46 | - stack $ARGS --no-terminal haddock --no-haddock-deps 47 | 48 | - stack $ARGS --no-terminal sdist 49 | - hlint src test app 50 | 51 | # Caching so the next build will be fast too. 52 | cache: 53 | directories: 54 | - $HOME/.stack 55 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | ## v0.2.3 5 | 6 | * Replace `lens` dependency with `microlens` for faster builds 7 | * Compatibility with GHC 8.4 to 8.10, stackage LTS-12 to LTS-17 8 | * Explicitly passing a tty to the editor process, rather than stdin, to work 9 | around a vim bug 10 | 11 | ## v0.2.2 12 | 13 | * Add support for aeson 1.2.x to enable build with Stackage LTS 10.x 14 | 15 | ## v0.2.1 16 | 17 | * Add support for aeson 1.x to enable build with Stackage LTS 9.x 18 | * Add `less`-like keybindings Ctrl-u, Ctrl-d (half-page-up/down, only in pager) 19 | and Ctrl-b, Ctrl-f (full-page-up/down). 20 | 21 | ## v0.2 22 | 23 | * Added support for a config file: 24 | A YAML file located at `~/.vgrep/config.yaml` is recognized as configuration 25 | file for colors, keybindings and other settings. The default config file can 26 | be produced using `vgrep --dump-default-config > ~/.vgrep/config.yaml`. 27 | * Added support for colorized input 28 | ([ANSI CSI/SGR escape codes](https://en.wikipedia.org/wiki/ANSI_escape_code#graphics)). 29 | `vgrep` can now be used together wit `grep --color=always` (and `git grep 30 | --color=always`), which is now enabled by default when using `vgrep` as 31 | drop-in replacement for `grep`. 32 | 33 | 34 | ## v0.1.4.1 35 | 36 | * Switch to strict `Text` 37 | * Less dependent on `template-haskell` 38 | 39 | 40 | ## v0.1.4 41 | 42 | * User events (like key events) now have priority over other events, the UI does 43 | not block any more. 44 | * `--help` and `--version` now produce sensible output. 45 | 46 | 47 | ## v0.1.3 48 | 49 | * Fix pageUp in Results view 50 | 51 | 52 | ## v0.1.2 53 | 54 | * Performance improvements 55 | * Tests for Pager and Results widget 56 | * Haddock documentation 57 | 58 | 59 | ## v0.1.1 60 | 61 | * Fixed `j`/`k` keys in pager view 62 | * Additional `h`/`l`/`←`/`→` keybindings for horizontal scrolling in pager 63 | * Matching lines are now highlighted in pager view 64 | 65 | 66 | ## v0.1 67 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Franz Thoma (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Franz Thoma nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | `vgrep` -- A pager for `grep` 2 | ============================= 3 | 4 | ![Screenshot](./screenshot.gif) 5 | 6 | ## Usage 7 | 8 | * As a pager: 9 | 10 | ```bash 11 | grep -rn data /some/path | vgrep # -n for line numbers 12 | ``` 13 | 14 | * As a drop-in replacement for `grep`: 15 | 16 | ```bash 17 | vgrep data /some/path # recursive by default 18 | vgrep data /some/path | vgrep default # works with pipes, too 19 | ``` 20 | 21 | * With a `git` alias defined in your `~/.gitconfig`: 22 | 23 | ```bash 24 | git config --global alias.vgrep '!__git_vgrep () { git grep --color=always "$@" | vgrep; }; __git_vgrep' 25 | git vgrep data 26 | ``` 27 | 28 | * Using [`ack`][ack]/[`ag`][ag] instead of `grep`? No problem: 29 | 30 | ```bash 31 | ack data | vgrep # Output of `ack` is compatible 32 | ack --color data | vgrep # Even coloring works 33 | ag --color data | vgrep # Same for `ag` 34 | ``` 35 | [ack]: http://beyondgrep.com/ 36 | [ag]: https://github.com/ggreer/the_silver_searcher 37 | 38 | Keybindings: 39 | 40 | * Use `hjkl` or the arrow keys to navigate 41 | * `Enter` opens a pager with the selected file 42 | * `e` opens the selected file in `$EDITOR` 43 | * `Tab` switches between results list and pager 44 | * `q` closes the pager and then the entire application. 45 | 46 | ## Installation 47 | 48 | ### Via [`nix`] from [nixpkgs] 49 | 50 | ``` 51 | nix-env -iA nixpkgs.haskellPackages.vgrep 52 | ``` 53 | 54 | ### From [Hackage] 55 | 56 | Installation from Hackage via [`stack`] is recommended: 57 | ```bash 58 | stack update 59 | stack install vgrep 60 | ``` 61 | This will install `vgrep` to your `~/.local/bin` directory. 62 | 63 | ### From [source] 64 | 65 | ```bash 66 | git clone https://github.com/fmthoma/vgrep.git 67 | cd vgrep 68 | stack setup 69 | stack install 70 | ``` 71 | 72 | [`nix`]: https://nixos.org/ 73 | [nixpkgs]: https://github.com/NixOS/nixpkgs 74 | [Hackage]: https://hackage.haskell.org/package/vgrep 75 | [`stack`]: https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md 76 | [source]: https://github.com/fmthoma/vgrep 77 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Main (main) where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Lens.Compat 8 | import Control.Monad.Reader 9 | import Data.Maybe 10 | import Data.Ratio 11 | import Data.Sequence (Seq, (|>)) 12 | import qualified Data.Sequence as S 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Lazy as TL 16 | import qualified Data.Text.Lazy.IO as TL 17 | import Data.Version (showVersion) 18 | import qualified Graphics.Vty as Vty 19 | import Graphics.Vty.Input.Events hiding (Event) 20 | import Graphics.Vty.Picture 21 | import Language.Haskell.TH 22 | import Pipes as P 23 | import Pipes.Concurrent 24 | import qualified Pipes.Prelude as P 25 | import System.Directory 26 | import System.Environment (getArgs) 27 | import System.Exit 28 | import System.IO 29 | import System.Process 30 | import System.Posix.IO 31 | 32 | import Paths_vgrep 33 | import Vgrep.App as App 34 | import Vgrep.Command 35 | import Vgrep.Environment 36 | import Vgrep.Event 37 | import qualified Vgrep.Key as Key 38 | import qualified Vgrep.KeybindingMap as KeybindingMap 39 | import Vgrep.Parser 40 | import Vgrep.System.Grep 41 | import Vgrep.Text 42 | import Vgrep.Type 43 | import qualified Vgrep.Widget as Widget 44 | import Vgrep.Widget.HorizontalSplit 45 | import Vgrep.Widget.Pager 46 | import Vgrep.Widget.Results 47 | 48 | 49 | main :: IO () 50 | main = do 51 | args <- getArgs 52 | when ("-V" `elem` args || "--version" `elem` args) (printVersion >> exitSuccess) 53 | when ("--help" `elem` args) (printHelp >> exitSuccess) 54 | when ("--dump-default-config" `elem` args) (printDefaultConfig >> exitSuccess) 55 | 56 | hSetBuffering stdin LineBuffering 57 | hSetBuffering stdout LineBuffering 58 | cfg <- loadConfig mempty 59 | inputFromTerminal <- hIsTerminalDevice stdin 60 | outputToTerminal <- hIsTerminalDevice stdout 61 | case (inputFromTerminal, outputToTerminal) of 62 | (True, False) -> runHeadless (const recursiveGrep) 63 | (False, False) 64 | | null args -> doNothingJustPipe 65 | | otherwise -> runHeadless grep 66 | (False, True) 67 | | null args -> runGui cfg id 68 | | otherwise -> runGui cfg grepForApp 69 | (True, True) -> runGui cfg (const recursiveGrep) 70 | where 71 | stdinText = P.stdinLn >-> P.map T.pack 72 | stdoutText = P.stdoutLn <-< P.map T.unpack 73 | runHeadless grepCommand = runEffect (grepCommand stdinText >-> stdoutText) 74 | runGui cfg grepCommand = withSpawn unbounded $ 75 | \(evSink, evSource) -> do 76 | let stdinText' = stdinText >-> P.tee (P.map ReceiveInputEvent >-> toOutput evSink) 77 | grepThread <- async . runEffect $ 78 | grepCommand stdinText' >-> P.map ReceiveResultEvent 79 | >-> toOutput evSink 80 | runApp_ app cfg (fromInput evSource) 81 | cancel grepThread 82 | doNothingJustPipe = runEffect (P.stdinLn >-> P.stdoutLn) 83 | printVersion = do 84 | putStrLn ("vgrep " <> showVersion version) 85 | putStrLn "" 86 | putStrLn "grep version: " 87 | runEffect (grepVersion >-> P.take 1 >-> P.map (" " <>) >-> stdoutText) 88 | printHelp = putStrLn helpText 89 | where helpText = $(runIO (readFile "help.txt") >>= stringE) 90 | printDefaultConfig = putStrLn defaultConfigFile 91 | where defaultConfigFile = $(runIO (readFile "config.yaml.example") >>= stringE) 92 | 93 | 94 | type MainWidget = HSplitWidget Results Pager 95 | type WidgetState = HSplit Results Pager 96 | 97 | data AppState = AppState { _widgetState :: WidgetState 98 | , _inputLines :: Seq Text } 99 | 100 | data Event = VtyEvent Vty.Event 101 | | ReceiveInputEvent Text 102 | | ReceiveResultEvent Text 103 | 104 | 105 | app :: App Event AppState 106 | app = App 107 | { App.initialize = initSplitView 108 | , App.liftEvent = VtyEvent 109 | , App.handleEvent = eventHandler 110 | , App.render = renderMainWidget } 111 | where 112 | initSplitView :: MonadIO m => m AppState 113 | initSplitView = pure AppState 114 | { _widgetState = Widget.initialize mainWidget 115 | , _inputLines = S.empty } 116 | renderMainWidget :: Monad m => VgrepT AppState m Vty.Picture 117 | renderMainWidget = fmap picForImage (zoom widgetState (Widget.draw mainWidget)) 118 | 119 | mainWidget :: MainWidget 120 | mainWidget = hSplitWidget resultsWidget pagerWidget 121 | 122 | 123 | --------------------------------------------------------------------------- 124 | -- Events 125 | 126 | eventHandler 127 | :: MonadIO m 128 | => Event 129 | -> Environment 130 | -> AppState 131 | -> Next (VgrepT AppState m Redraw) 132 | eventHandler = \case 133 | ReceiveInputEvent line -> \_ _ -> handleFeedInput line 134 | ReceiveResultEvent line -> \_ _ -> handleFeedResult line 135 | VtyEvent event -> handleVty event 136 | where 137 | handleFeedResult, handleFeedInput 138 | :: MonadIO m 139 | => Text 140 | -> Next (VgrepT AppState m Redraw) 141 | handleFeedResult line = Continue $ case parseLine line of 142 | Just l -> do 143 | l' <- traverseOf (lineReference . lineText) expandFormattedLine l 144 | zoom results (feedResult l') 145 | Nothing -> pure Unchanged 146 | handleFeedInput line = Continue $ do 147 | expandedLine <- expandLineForDisplay line 148 | modifying inputLines (|> expandedLine) 149 | pure Unchanged 150 | 151 | handleVty 152 | :: MonadIO m 153 | => Vty.Event 154 | -> Environment 155 | -> AppState 156 | -> Next (VgrepT AppState m Redraw) 157 | handleVty = \case 158 | EvResize w h -> \_ _ -> handleResizeEvent w h 159 | ev | Just chord <- Key.fromVty ev -> handleKeyEvent chord 160 | | otherwise -> \_ _ -> Skip 161 | 162 | handleResizeEvent :: Monad m => Int -> Int -> Next (VgrepT AppState m Redraw) 163 | handleResizeEvent w h = Continue $ do 164 | modifyEnvironment . set viewport $ 165 | Viewport { _vpWidth = w, _vpHeight = h } 166 | pure Redraw 167 | 168 | handleKeyEvent 169 | :: MonadIO m 170 | => Key.Chord 171 | -> Environment 172 | -> AppState 173 | -> Next (VgrepT AppState m Redraw) 174 | handleKeyEvent chord environment state = 175 | executeCommand command state 176 | where 177 | globalBindings = view (config . keybindings . globalKeybindings) environment 178 | resultsBindings = view (config . keybindings . resultsKeybindings) environment 179 | pagerBindings = view (config . keybindings . pagerKeybindings) environment 180 | localBindings = case view (widgetState . currentWidget) state of 181 | Left _ -> resultsBindings 182 | Right _ -> pagerBindings 183 | lookupCmd = fromMaybe Unset . KeybindingMap.lookup chord 184 | command = case lookupCmd localBindings of 185 | Unset -> lookupCmd globalBindings 186 | defined -> defined 187 | 188 | 189 | executeCommand :: MonadIO m => Command -> AppState -> Next (VgrepT AppState m Redraw) 190 | executeCommand = \case 191 | Unset -> skip 192 | DisplayPagerOnly -> continue (zoom widgetState rightOnly) 193 | DisplayResultsOnly -> continue (zoom widgetState leftOnly) 194 | SplitFocusPager -> continue splitViewPager 195 | SplitFocusResults -> continue splitViewResults 196 | PagerUp -> continue (zoom pager (scroll (-1))) 197 | PagerDown -> continue (zoom pager (scroll 1)) 198 | PagerPageUp -> continue (zoom pager (scrollPage (-1))) 199 | PagerPageDown -> continue (zoom pager (scrollPage 1)) 200 | PagerHalfPageUp -> continue (zoom pager (scrollPageFraction (-1%2))) 201 | PagerHalfPageDown -> continue (zoom pager (scrollPageFraction (1%2))) 202 | PagerScrollLeft -> continue (zoom pager (hScroll (-1))) 203 | PagerScrollRight -> continue (zoom pager (hScroll 1)) 204 | ResultsUp -> continue (zoom results prevLine >> pure Redraw) 205 | ResultsDown -> continue (zoom results nextLine >> pure Redraw) 206 | ResultsPageUp -> continue (zoom results pageUp >> pure Redraw) 207 | ResultsPageDown -> continue (zoom results pageDown >> pure Redraw) 208 | PrevResult -> continue (zoom results prevLine >> loadSelectedFileToPager) 209 | NextResult -> continue (zoom results nextLine >> loadSelectedFileToPager) 210 | PagerGotoResult -> continue (loadSelectedFileToPager >> splitViewPager) 211 | OpenFileInEditor -> invokeEditor 212 | Exit -> halt 213 | where 214 | continue = const . Continue 215 | skip = const Skip 216 | halt = const (Interrupt Halt) 217 | 218 | splitViewPager, splitViewResults :: Monad m => VgrepT AppState m Redraw 219 | splitViewPager = zoom widgetState (splitView FocusRight (1 % 3)) 220 | splitViewResults = zoom widgetState (splitView FocusLeft (2 % 3)) 221 | 222 | loadSelectedFileToPager :: MonadIO m => VgrepT AppState m Redraw 223 | loadSelectedFileToPager = do 224 | maybeFileName <- use (results . currentFileName . to (fmap T.unpack)) 225 | whenJust maybeFileName $ \selectedFile -> do 226 | fileExists <- liftIO (doesFileExist selectedFile) 227 | fileContent <- if fileExists 228 | then readLinesFrom selectedFile 229 | else use inputLines 230 | displayContent <- expandForDisplay fileContent 231 | highlightedLines <- use (results . currentFileResults) 232 | zoom pager (replaceBufferContents displayContent highlightedLines) 233 | moveToSelectedLineNumber 234 | pure Redraw 235 | where 236 | readLinesFrom f = liftIO $ do 237 | content <- TL.readFile f 238 | pure (fileLines content) 239 | fileLines = S.fromList . map TL.toStrict . TL.lines 240 | 241 | 242 | moveToSelectedLineNumber :: Monad m => VgrepT AppState m () 243 | moveToSelectedLineNumber = 244 | use (results . currentLineNumber) 245 | >>= (`whenJust` (void . zoom pager . moveToLine)) 246 | 247 | whenJust :: (Monoid r, Monad m) => Maybe a -> (a -> m r) -> m r 248 | whenJust item action = maybe (pure mempty) action item 249 | 250 | invokeEditor :: AppState -> Next (VgrepT AppState m Redraw) 251 | invokeEditor state = case view (results . currentFileName . to (fmap T.unpack)) state of 252 | Just selectedFile -> Interrupt $ Suspend $ \environment -> do 253 | let configuredEditor = view (config . editor) environment 254 | selectedLineNumber = view (results . currentLineNumber . to (fromMaybe 0)) state 255 | liftIO $ doesFileExist selectedFile >>= \case 256 | True -> exec configuredEditor ['+' : show selectedLineNumber, selectedFile] 257 | False -> hPutStrLn stderr ("File not found: " ++ show selectedFile) 258 | Nothing -> Skip 259 | 260 | exec :: MonadIO io => FilePath -> [String] -> io () 261 | exec command args = liftIO $ do 262 | tty <- openFd "/dev/tty" ReadWrite Nothing defaultFileFlags >>= fdToHandle 263 | (_,_,_,h) <- createProcess (proc command args) {std_in = UseHandle tty} 264 | void (waitForProcess h) 265 | hClose tty 266 | 267 | --------------------------------------------------------------------------- 268 | -- Lenses 269 | 270 | widgetState :: Lens' AppState WidgetState 271 | widgetState = lens _widgetState (\s ws -> s { _widgetState = ws }) 272 | 273 | inputLines :: Lens' AppState (Seq Text) 274 | inputLines = lens _inputLines (\s l -> s { _inputLines = l }) 275 | 276 | results :: Lens' AppState Results 277 | results = widgetState . leftWidget 278 | 279 | pager :: Lens' AppState Pager 280 | pager = widgetState . rightWidget 281 | -------------------------------------------------------------------------------- /config.yaml.example: -------------------------------------------------------------------------------- 1 | ## Color configuration 2 | ## 3 | ## For each item, the following three attributes can be specified: 4 | ## * fore-color: The text color 5 | ## * back-color: The background color 6 | ## * Valid colors are the usual 16 terminal colors: 7 | ## black, red, green, blue, yellow, magenta, cyan, white, 8 | ## bright-black, bright-red, bright-green, bright-yellow, 9 | ## bright-blue, bright-magenta, bright-cyan, bright-white 10 | ## * style: 11 | ## * Valid styles are: 12 | ## standout, underline, reverse-video, blink, dim, bold 13 | ## Please note that not all styles are necessarily supported 14 | ## by your terminal. 15 | ## 16 | ## If a color/style is not given, it falls back to the terminal 17 | ## default: 18 | ## 19 | ## # terminal-default back-color and style 20 | ## line-numbers: 21 | ## fore-color: blue 22 | ## ... 23 | ## 24 | ## # reset line-numbers to terminal default 25 | ## line-numbers: {} 26 | ## ... 27 | ## 28 | ## If no config is given for a color, the vgrep default config 29 | ## steps in (which may differ from your terminal's default): 30 | ## 31 | ## # use vgrep default config for line numbers 32 | ## line-numbers: 33 | ## ... 34 | ## 35 | colors: 36 | 37 | # Line numbers 38 | line-numbers: 39 | fore-color: blue 40 | 41 | # Highlighted line numbers 42 | line-numbers-hl: 43 | fore-color: blue 44 | style: bold 45 | 46 | # Normal text 47 | normal: {} 48 | 49 | # Highlighted text 50 | normal-hl: 51 | style: bold 52 | 53 | # The file names in the results list 54 | file-headers: 55 | back-color: green 56 | 57 | # The line currently selected by the cursor 58 | selected: 59 | style: standout 60 | 61 | 62 | ## The tabstop witdth (a tab character moves the indentation to the 63 | ## next multiple of this value) 64 | ## 65 | tabstop: 8 66 | 67 | 68 | ## The editor to be used by the 'e' key (read from $EDITOR by 69 | ## default, but can be overridden here). 70 | ## 71 | # editor: "vi" 72 | 73 | 74 | ## Keybindings 75 | ## 76 | ## The following commands can be mapped: 77 | ## * display-pager-only -- Display the pager full-screen 78 | ## * display-results-only -- Display the results list full-screen 79 | ## * split-focus-pager -- Split screen, focus on pager 80 | ## * split-focus-results -- Split screen, focus on results list 81 | ## * pager-up -- Scroll one line up in pager 82 | ## * pager-down -- Scroll one line down in pager 83 | ## * pager-page-up -- Scroll one page up in pager 84 | ## * pager-page-down -- Scroll one page down in pager 85 | ## * pager-half-page-up -- Scroll half a page up in pager 86 | ## * pager-half-page-down -- Scroll half a page down in pager 87 | ## * pager-scroll-left -- Scroll eight characters left in pager 88 | ## * pager-scroll-right -- Scroll eight characters right in pager 89 | ## * results-up -- Move to previous result 90 | ## * results-down -- Move to next result 91 | ## * results-page-up -- Move one page up in results list 92 | ## * results-page-down -- Move one page down in results list 93 | ## * prev-result -- Move to previous result and update pager 94 | ## * next-result -- Move to next result and update pager 95 | ## * pager-goto-result -- Update pager with currently selected result 96 | ## * open-file-in-editor -- Open file in external editor and jump to 97 | ## currently selected result 98 | ## * exit -- Exit the application 99 | ## * unset -- Treat keybinding as if not present, fall back to 100 | ## -- alternative binding (used to override keybindings) 101 | ## A command can be mapped to multiple keys. 102 | ## 103 | ## Key notation examples 104 | ## * j -- the 'j' key 105 | ## * J -- the 'J' key (Shift-'j') 106 | ## * Up, Down, Left, Right -- the corresponding arrow keys 107 | ## * S-Up, C-Up, M-Up -- Modifiers Shift, Ctrl, Alt/Meta combined with the 108 | ## Up key 109 | ## * C-M-S-Up, C-S-M-Up -- Modifiers can be combined, the order is irrelevant 110 | ## (both correspond to Control-Alt-Shift-Up) 111 | ## * The Shift key can only be applied to non-character keys (like Up, Down, 112 | ## Space, Enter): Shift-'j' is represented by 'J', not by 'S-j'. 113 | ## 114 | ## Default keybindings: 115 | keybindings: 116 | 117 | # These keybindings are always in effect, but can be overridden. 118 | global-keybindings: 119 | q : exit 120 | e : open-file-in-editor 121 | 122 | # These keybindings apply when navigating the results list. They override 123 | # any colliding global-keybinding. 124 | results-keybindings: 125 | Up : results-up 126 | Down : results-down 127 | PageUp : results-page-up 128 | PageDown : results-page-down 129 | Enter : pager-goto-result 130 | k : results-up 131 | j : results-down 132 | C-b : results-page-up 133 | C-f : results-page-down 134 | f : display-results-only 135 | Tab : split-focus-pager 136 | 137 | # These apply when navigating the pager. They override any colliding 138 | # global-keybinding. 139 | pager-keybindings: 140 | Up : pager-up 141 | Down : pager-down 142 | PageUp : pager-page-up 143 | PageDown : pager-page-down 144 | Left : pager-scroll-left 145 | Right : pager-scroll-right 146 | k : pager-up 147 | j : pager-down 148 | h : pager-scroll-left 149 | l : pager-scroll-right 150 | C-u : pager-half-page-up 151 | C-d : pager-half-page-down 152 | C-b : pager-page-up 153 | C-f : pager-page-down 154 | Tab : split-focus-results 155 | f : display-pager-only 156 | q : display-results-only 157 | 158 | ## Alternative keybindings: tig-style 159 | ## (jk to navigate the pager, Up/Down to navigate the results list) 160 | ## 161 | # keybindings: 162 | # results-keybindings: 163 | # O : display-results-only 164 | # f : unset 165 | # pager-keybindings: 166 | # O : display-pager-only 167 | # Up : prev-result 168 | # Down : next-result 169 | # f : unset 170 | -------------------------------------------------------------------------------- /help.txt: -------------------------------------------------------------------------------- 1 | vgrep, a pager for grep 2 | 3 | 4 | Usage: 5 | as a drop-in replacement for `grep -r`: 6 | vgrep [GREP_OPTION...] PATTERN [FILE] 7 | 8 | at the end of a pipeline: 9 | ... | vgrep [-nH] PATTERN 10 | 11 | as a pager for `grep -nH` output: 12 | grep -nH [GREP_OPTION...] PATTERN [FILE] | vgrep 13 | 14 | 15 | Additional options: 16 | --help, -V Prints this help. 17 | 18 | --version Prints version info and exits 19 | 20 | --dump-default-config 21 | Prints the default config file to stdout and exits. 22 | (Usage: `vgrep --dump-default-config > ~/.vgrep/config.yaml`) 23 | 24 | 25 | For documentation on grep options an patterns see `grep --help`. 26 | -------------------------------------------------------------------------------- /screenshot.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fmthoma/vgrep/451cd841ad54746eed1273393676637b2af0d0a3/screenshot.gif -------------------------------------------------------------------------------- /src/Control/Concurrent/STM/TPQueue.hs: -------------------------------------------------------------------------------- 1 | -- | A transactional priority queue, based on a Finger Tree. 2 | module Control.Concurrent.STM.TPQueue 3 | ( TPQueue () 4 | , newTPQueue 5 | , newTPQueueIO 6 | , writeTPQueue 7 | , readTPQueue 8 | , tryReadTPQueue 9 | , peekTPQueue 10 | , tryPeekTPQueue 11 | , isEmptyTPQueue 12 | ) where 13 | 14 | import Control.Concurrent.STM.TVar 15 | import Control.Monad.STM 16 | import Data.PriorityQueue.FingerTree (PQueue) 17 | import qualified Data.PriorityQueue.FingerTree as PQueue 18 | 19 | -- | 'TPQueue' is an unbounded priority queue based on a Finger Tree. 20 | newtype TPQueue k v = TPQueue (TVar (PQueue k v)) 21 | 22 | mkTPQueue :: Functor f => f (TVar (PQueue k v)) -> f (TPQueue k v) 23 | mkTPQueue = fmap TPQueue 24 | 25 | -- | Build a new 'TPQueue'. 26 | newTPQueue :: Ord k => STM (TPQueue k v) 27 | newTPQueue = mkTPQueue (newTVar PQueue.empty) 28 | 29 | -- | IO version of 'newTPQueue'. This is useful for creating top-level 30 | -- 'TPQueues' using 'unsafePerformIO', because using 'atomically' inside 31 | -- 'unsafePerformIO' isn't possible. 32 | newTPQueueIO :: Ord k => IO (TPQueue k v) 33 | newTPQueueIO = mkTPQueue (newTVarIO PQueue.empty) 34 | 35 | -- | Write a value to a 'TPQueue'. 36 | writeTPQueue :: Ord k => TPQueue k v -> k -> v -> STM () 37 | writeTPQueue (TPQueue h) k v = modifyTVar' h (PQueue.add k v) 38 | 39 | -- | Read the next minimal value from a 'TPQueue'. 40 | readTPQueue :: Ord k => TPQueue k v -> STM v 41 | readTPQueue (TPQueue h) = do 42 | xs <- readTVar h 43 | case PQueue.minView xs of 44 | Just (x, xs') -> writeTVar h xs' >> pure x 45 | Nothing -> retry 46 | 47 | -- | A version of 'readTPQueue' that does not retry, but returns 'Nothing' 48 | -- instead if no value is available. 49 | tryReadTPQueue :: Ord k => TPQueue k v -> STM (Maybe v) 50 | tryReadTPQueue (TPQueue h) = do 51 | xs <- readTVar h 52 | case PQueue.minView xs of 53 | Just (x, xs') -> writeTVar h xs' >> pure (Just x) 54 | Nothing -> pure Nothing 55 | 56 | -- | Get the next minimal value from a 'TPQueue' without removing it. 57 | peekTPQueue :: Ord k => TPQueue k v -> STM v 58 | peekTPQueue (TPQueue h) = do 59 | xs <- readTVar h 60 | case PQueue.minView xs of 61 | Just (x, _) -> pure x 62 | Nothing -> retry 63 | 64 | -- | A version of 'peekTPQueue' that does not retry, but returns 'Nothing' 65 | -- instead if no value is available. 66 | tryPeekTPQueue :: Ord k => TPQueue k v -> STM (Maybe v) 67 | tryPeekTPQueue (TPQueue h) = do 68 | xs <- readTVar h 69 | case PQueue.minView xs of 70 | Just (x, _) -> pure (Just x) 71 | Nothing -> pure Nothing 72 | 73 | -- | Returns 'True' if the 'TPQueue' is empty. 74 | isEmptyTPQueue :: Ord k => TPQueue k v -> STM Bool 75 | isEmptyTPQueue (TPQueue h) = fmap PQueue.null (readTVar h) 76 | -------------------------------------------------------------------------------- /src/Control/Lens/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# OPTIONS_GHC -fno-warn-dodgy-imports #-} 3 | module Control.Lens.Compat 4 | ( pre 5 | , assign 6 | , modifying 7 | , traverseOf 8 | 9 | , Getter 10 | 11 | , module Lens.Micro.Platform 12 | ) where 13 | 14 | import Data.Monoid (First) 15 | import Lens.Micro.Platform hiding (assign, modifying, traverseOf) 16 | import Control.Monad.State (MonadState, modify) 17 | 18 | 19 | pre :: Getting (First a) s a -> Getter s (Maybe a) 20 | pre l = to (preview l) 21 | {-# INLINE pre #-} 22 | 23 | assign :: MonadState s m => ASetter s s a b -> b -> m () 24 | assign l b = modify (set l b) 25 | {-# INLINE assign #-} 26 | 27 | modifying :: MonadState s m => ASetter s s a b -> (a -> b) -> m () 28 | modifying l f = modify (over l f) 29 | {-# INLINE modifying #-} 30 | 31 | traverseOf :: a -> a 32 | traverseOf = id 33 | {-# INLINE traverseOf #-} 34 | 35 | type Getter s a = SimpleGetter s a 36 | 37 | -- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function. 38 | -- See "Control.Lens".'Lens.to' for details. 39 | -- 40 | -- In , the constraint 41 | -- @'Functor' f@ is missing from the definition of 'Lens.to'. When compiling 42 | -- with GHC 8.0, this leads to warnings for definitions like 43 | -- 44 | -- @ 45 | -- foo :: Getter Bar Foo 46 | -- foo = to fooFromBar 47 | -- @ 48 | -- 49 | -- because of the redundant @'Functor' f@ constraint. This definition is 50 | -- identical to "Control.Lens".'Lens.to' except for the additional constraint 51 | -- @'Functor' f@. 52 | -- to :: (Profunctor p, Functor f, Contravariant f) => (s -> a) -> Optic' p f s a 53 | -- to k = getter 54 | -- where 55 | -- getter = Lens.to k 56 | -- _fakeFunctorConstraint = rmap (fmap undefined) . getter 57 | -------------------------------------------------------------------------------- /src/Control/Monad/State/Extended.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.State.Extended 2 | ( module Control.Monad.State.Strict 3 | , liftState 4 | , whenS 5 | , unlessS 6 | ) where 7 | 8 | import Control.Monad.State.Strict 9 | 10 | liftState :: MonadState s m => State s a -> m a 11 | liftState = state . runState 12 | 13 | whenS :: MonadState s m => (s -> Bool) -> m () -> m () 14 | whenS predicate action = do 15 | condition <- fmap predicate get 16 | when condition action 17 | 18 | unlessS :: MonadState s m => (s -> Bool) -> m () -> m () 19 | unlessS predicate = whenS (not . predicate) 20 | -------------------------------------------------------------------------------- /src/Pipes/Concurrent/PQueue.hs: -------------------------------------------------------------------------------- 1 | -- | A variant of "Pipes.Concurrent" that uses a Finger Tree-based Priority 2 | -- Queue ('TPQueue.TPQueue') instead of a normal 'TQueue'. 3 | module Pipes.Concurrent.PQueue 4 | ( spawn 5 | , withSpawn 6 | -- * Re-exports from "Pipes.Concurrent" 7 | , Input (..) 8 | , Output (..) 9 | , fromInput 10 | , toOutput 11 | ) where 12 | 13 | import Control.Applicative 14 | import Control.Concurrent.STM as STM 15 | import qualified Control.Concurrent.STM.TPQueue as TPQueue 16 | import Control.Exception (bracket) 17 | import Control.Monad 18 | import Pipes.Concurrent 19 | ( Input (..) 20 | , Output (..) 21 | , fromInput 22 | , toOutput 23 | ) 24 | 25 | 26 | -- | Spawn a mailbox to store prioritized messages in a Mailbox. Using 'recv' on 27 | -- the 'Input' will return 'Just' the minimal element, or 'Nothing' if the 28 | -- mailbox is closed. 29 | -- 30 | -- This function is analogous to 31 | -- @"Pipes.Concurrent".'Pipes.Concurrent.spawn'' 'Pipes.Concurrent.Unbounded'@, 32 | -- but it uses a 'TPQueue.TPQueue' instead of a 'TQueue' to store messages. 33 | spawn :: Ord p => IO (Output (p, a), Input a, STM ()) 34 | spawn = do 35 | q <- TPQueue.newTPQueueIO 36 | sealed <- STM.newTVarIO False 37 | let seal = STM.writeTVar sealed True 38 | 39 | {- Use weak TVars to keep track of whether the 'Input' or 'Output' has been 40 | garbage collected. Seal the mailbox when either of them becomes garbage 41 | collected. 42 | -} 43 | rSend <- STM.newTVarIO () 44 | void (STM.mkWeakTVar rSend (STM.atomically seal)) 45 | rRecv <- STM.newTVarIO () 46 | void (STM.mkWeakTVar rRecv (STM.atomically seal)) 47 | 48 | let sendOrEnd p a = do 49 | isSealed <- readTVar sealed 50 | if isSealed 51 | then pure False 52 | else TPQueue.writeTPQueue q p a >> pure True 53 | 54 | readOrEnd = fmap Just (TPQueue.readTPQueue q) 55 | <|> (readTVar sealed >>= check >> pure Nothing) 56 | 57 | _send (p, a) = sendOrEnd p a <* readTVar rSend 58 | _recv = readOrEnd <* readTVar rRecv 59 | return (Output _send, Input _recv, seal) 60 | {-# INLINABLE spawn #-} 61 | 62 | -- | 'withSpawn' passes its enclosed action an 'Output' and 'Input' like you'd 63 | -- get from 'spawn', but automatically @seal@s them after the action completes. 64 | -- This can be used when you need the @seal@ing behavior available from 'spawn', 65 | -- but want to work at a bit higher level: 66 | -- 67 | -- > withSpawn buffer $ \(output, input) -> ... 68 | -- 69 | -- 'withSpawn' is exception-safe, since it uses 'bracket' internally. 70 | withSpawn :: Ord p => ((Output (p, a), Input a) -> IO r) -> IO r 71 | withSpawn action = bracket spawn 72 | (\(_, _, seal) -> atomically seal) 73 | (\(output, input, _) -> action (output, input)) 74 | -------------------------------------------------------------------------------- /src/Vgrep/Ansi.hs: -------------------------------------------------------------------------------- 1 | -- | Utilities for printing ANSI formatted text. 2 | module Vgrep.Ansi ( 3 | -- * ANSI formatted text 4 | AnsiFormatted 5 | , Formatted () 6 | -- ** Smart constructors 7 | , emptyFormatted 8 | , bare 9 | , format 10 | , cat 11 | -- ** Modifying text nodes 12 | , mapText 13 | , mapTextWithPos 14 | , takeFormatted 15 | , dropFormatted 16 | , padFormatted 17 | 18 | -- * Converting ANSI formatted text 19 | , renderAnsi 20 | , stripAnsi 21 | ) where 22 | 23 | import Data.Text (Text) 24 | import qualified Graphics.Vty as Vty 25 | 26 | import Vgrep.Ansi.Type 27 | import Vgrep.Ansi.Vty.Attributes 28 | 29 | 30 | -- | Converts ANSI formatted text to an 'Vty.Image'. Nested formattings are 31 | -- combined with 'combineStyles'. The given 'Vty.Attr' is used as style for the 32 | -- root of the 'Formatted' tree. 33 | -- 34 | -- >>> import Graphics.Vty.Image.Internal (Image (HorizText, attr)) 35 | -- >>> let HorizText { attr = attr } = renderAnsi Vty.defAttr (bare "Text") 36 | -- >>> attr 37 | -- Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default} 38 | -- 39 | renderAnsi :: Attr -> AnsiFormatted -> Vty.Image 40 | renderAnsi attr = \case 41 | Empty -> Vty.emptyImage 42 | Text _ t -> Vty.text' attr t 43 | Format _ attr' t -> renderAnsi (combineStyles attr attr') t 44 | Cat _ ts -> Vty.horizCat (map (renderAnsi attr) ts) 45 | 46 | -- | Strips away all formattings to plain 'Text'. 47 | stripAnsi :: Formatted a -> Text 48 | stripAnsi = \case 49 | Empty -> mempty 50 | Text _ t -> t 51 | Format _ _ t -> stripAnsi t 52 | Cat _ ts -> foldMap stripAnsi ts 53 | -------------------------------------------------------------------------------- /src/Vgrep/Ansi/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Vgrep.Ansi.Parser 3 | ( parseAnsi 4 | , ansiFormatted 5 | , attrChange 6 | ) where 7 | 8 | 9 | import Control.Applicative 10 | import Data.Attoparsec.Text 11 | import Data.Bits 12 | import Data.Functor 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import Graphics.Vty.Attributes (Attr) 16 | import qualified Graphics.Vty.Attributes as Vty 17 | 18 | import Vgrep.Ansi.Type 19 | 20 | 21 | {- | 22 | Directly parses ANSI formatted text using 'ansiFormatted'. 23 | 24 | Parsing ANSI color codes: 25 | 26 | >>> parseAnsi "Hello \ESC[31mWorld\ESC[m!" 27 | Cat 12 [Text 6 "Hello ",Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 5 "World"),Text 1 "!"] 28 | 29 | More elaborate example with nested foreground and background colors: 30 | 31 | >>> parseAnsi "\ESC[m\ESC[40mHello \ESC[31mWorld\ESC[39m!" 32 | Cat 12 [Format 6 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 6 "Hello "),Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 5 "World"),Format 1 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 1 "!")] 33 | 34 | Some CSI sequences are ignored, since they are not supported by 'Vty': 35 | 36 | >>> parseAnsi "\ESC[A\ESC[B\ESC[31mfoo\ESC[1K\ESC[mbar" 37 | Cat 6 [Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 3 "foo"),Text 3 "bar"] 38 | 39 | Non-CSI sequences are not parsed, but included in the output: 40 | 41 | >>> parseAnsi "\ESC]710;font\007foo\ESC[31mbar" 42 | Cat 17 [Text 14 "\ESC]710;font\afoo",Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 3 "bar")] 43 | 44 | -} 45 | parseAnsi :: Text -> AnsiFormatted 46 | parseAnsi = either error id . parseOnly ansiFormatted 47 | -- The use of 'error' ↑ is safe: 'ansiFormatted' does not fail. 48 | 49 | 50 | -- | Parser for ANSI formatted text. Recognized escape sequences are the SGR 51 | -- (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'. 52 | -- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are 53 | -- ignored. Other (non-CSI) escape sequences are not parsed, and included in the 54 | -- output. 55 | -- 56 | -- This parser does not fail, it will rather consume and return the remaining 57 | -- input as unformatted text. 58 | ansiFormatted :: Parser AnsiFormatted 59 | ansiFormatted = go mempty 60 | where 61 | go :: Attr -> Parser AnsiFormatted 62 | go attr = endOfInput $> mempty 63 | <|> formattedText attr 64 | 65 | formattedText :: Attr -> Parser AnsiFormatted 66 | formattedText attr = do 67 | acs <- many attrChange 68 | let attr' = foldr ($) attr (reverse acs) 69 | t <- rawText 70 | rest <- go attr' 71 | pure (format attr' (bare t) <> rest) 72 | 73 | rawText :: Parser Text 74 | rawText = atLeastOneTill (== '\ESC') <|> endOfInput $> "" 75 | 76 | atLeastOneTill :: (Char -> Bool) -> Parser Text 77 | atLeastOneTill = liftA2 T.cons anyChar . takeTill 78 | 79 | 80 | -- | Parser for ANSI CSI escape sequences. Recognized escape sequences are the 81 | -- SGR (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'. 82 | -- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are 83 | -- ignored by returning 'id'. 84 | -- 85 | -- This parser fails when encountering any other (non-CSI) escape sequence. 86 | attrChange :: Parser (Attr -> Attr) 87 | attrChange = fmap csiToAttrChange csi 88 | 89 | csiEscape :: Parser Text 90 | csiEscape = "\ESC[" 91 | 92 | csi :: Parser Csi 93 | csi = csiEscape >> liftA2 Csi (decimal `sepBy` char ';') anyChar 94 | 95 | data Csi = Csi [Int] Char 96 | 97 | csiToAttrChange :: Csi -> Attr -> Attr 98 | csiToAttrChange = \case 99 | Csi [] 'm' -> const mempty 100 | Csi is 'm' -> foldMap attrChangeFromCode is 101 | _otherwise -> id 102 | 103 | attrChangeFromCode :: Int -> Attr -> Attr 104 | attrChangeFromCode = \case 105 | 0 -> const mempty 106 | 1 -> withStyle Vty.bold 107 | 3 -> withStyle Vty.standout 108 | 4 -> withStyle Vty.underline 109 | 5 -> withStyle Vty.blink 110 | 6 -> withStyle Vty.blink 111 | 7 -> withStyle Vty.reverseVideo 112 | 21 -> withoutStyle Vty.bold 113 | 22 -> withoutStyle Vty.bold 114 | 23 -> withoutStyle Vty.standout 115 | 24 -> withoutStyle Vty.underline 116 | 25 -> withoutStyle Vty.blink 117 | 27 -> withoutStyle Vty.reverseVideo 118 | i | i >= 30 && i <= 37 -> withForeColor (rawColor (i - 30)) 119 | | i >= 40 && i <= 47 -> withBackColor (rawColor (i - 40)) 120 | | i >= 90 && i <= 97 -> withForeColor (rawBrightColor (i - 90)) 121 | | i >= 100 && i <= 107 -> withBackColor (rawBrightColor (i - 100)) 122 | 39 -> resetForeColor 123 | 49 -> resetBackColor 124 | _ -> id 125 | where 126 | rawColor = \case 127 | 0 -> Vty.black 128 | 1 -> Vty.red 129 | 2 -> Vty.green 130 | 3 -> Vty.yellow 131 | 4 -> Vty.blue 132 | 5 -> Vty.magenta 133 | 6 -> Vty.cyan 134 | _ -> Vty.white 135 | rawBrightColor = \case 136 | 0 -> Vty.brightBlack 137 | 1 -> Vty.brightRed 138 | 2 -> Vty.brightGreen 139 | 3 -> Vty.brightYellow 140 | 4 -> Vty.brightBlue 141 | 5 -> Vty.brightMagenta 142 | 6 -> Vty.brightCyan 143 | _ -> Vty.brightWhite 144 | withStyle = flip Vty.withStyle 145 | withForeColor = flip Vty.withForeColor 146 | withBackColor = flip Vty.withBackColor 147 | withoutStyle style attr = case Vty.attrStyle attr of 148 | Vty.SetTo oldStyle | oldStyle `Vty.hasStyle` style 149 | -> attr { Vty.attrStyle = Vty.SetTo (oldStyle .&. complement style) } 150 | _otherwise -> attr 151 | resetForeColor attr = attr { Vty.attrForeColor = Vty.KeepCurrent } 152 | resetBackColor attr = attr { Vty.attrBackColor = Vty.KeepCurrent } 153 | -------------------------------------------------------------------------------- /src/Vgrep/Ansi/Type.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Ansi.Type 2 | ( Formatted (..) 3 | , AnsiFormatted 4 | -- * Smart constructors 5 | , emptyFormatted 6 | , bare 7 | , format 8 | , cat 9 | -- * Modifying the underlying text 10 | , mapText 11 | , mapTextWithPos 12 | , takeFormatted 13 | , dropFormatted 14 | , padFormatted 15 | -- * Internal helpers 16 | , fuse 17 | ) where 18 | 19 | import Data.Foldable (foldl') 20 | import Data.Text (Text) 21 | import qualified Data.Text as T 22 | import Graphics.Vty (Attr) 23 | import Prelude hiding (length) 24 | 25 | 26 | -- | A representattion of formatted 'Text'. The attribute is usually a 'Monoid' 27 | -- so that different formattings can be combined by nesting them. 28 | data Formatted attr 29 | = Empty 30 | -- ^ An empty block 31 | 32 | | Text !Int Text 33 | -- ^ A bare (unformatted) text node 34 | 35 | | Format !Int attr (Formatted attr) 36 | -- ^ Adds formatting to a block 37 | 38 | | Cat !Int [Formatted attr] 39 | -- ^ Concatenates several blocks of formatted text 40 | 41 | deriving (Eq, Show) 42 | 43 | instance Functor Formatted where 44 | fmap f = \case 45 | Empty -> Empty 46 | Text l t -> Text l t 47 | Format l a t -> Format l (f a) (fmap f t) 48 | Cat l ts -> Cat l (map (fmap f) ts) 49 | 50 | instance (Eq attr, Semigroup attr) => Semigroup (Formatted attr) where 51 | (<>) = fuse 52 | 53 | instance (Eq attr, Semigroup attr) => Monoid (Formatted attr) where 54 | mempty = Empty 55 | 56 | 57 | -- | Type alias for Text formatted with 'Attr' from "Graphics.Vty". 58 | type AnsiFormatted = Formatted Attr 59 | 60 | 61 | -- | Smart constructor for an empty 'Formatted' text. 62 | emptyFormatted :: Formatted attr 63 | emptyFormatted = Empty 64 | 65 | -- | Smart constructor for bare (unformatted) text. 66 | -- 67 | -- >>> bare "" 68 | -- Empty 69 | -- 70 | -- >>> bare "Text" 71 | -- Text 4 "Text" 72 | -- 73 | bare :: Text -> Formatted attr 74 | bare t 75 | | T.null t = emptyFormatted 76 | | otherwise = Text (T.length t) t 77 | 78 | -- | Adds formatting to a 'Formatted' text. The 'Eq' and 'Monoid' instances for 79 | -- @attr@ are used to flatten redundant formattings. 80 | -- 81 | -- >>> format (Just ()) (format Nothing (bare "Text")) 82 | -- Format 4 (Just ()) (Text 4 "Text") 83 | -- 84 | -- >>> format (Just ()) (format (Just ()) (bare "Text")) 85 | -- Format 4 (Just ()) (Text 4 "Text") 86 | -- 87 | -- >>> format Nothing (bare "Text") 88 | -- Text 4 "Text" 89 | -- 90 | format :: (Eq attr, Monoid attr) => attr -> Formatted attr -> Formatted attr 91 | format attr formatted 92 | | attr == mempty = formatted 93 | | Format l attr' formatted' <- formatted 94 | = Format l (attr <> attr') formatted' 95 | | otherwise = format' attr formatted 96 | 97 | format' :: attr -> Formatted attr -> Formatted attr 98 | format' attr formatted = Format (length formatted) attr formatted 99 | 100 | -- | Concatenates pieces of 'Formatted' text. Redundant formattings and blocks 101 | -- of equal formatting are 'fuse'd together. 102 | cat :: (Eq attr, Monoid attr) => [Formatted attr] -> Formatted attr 103 | cat = \case 104 | [] -> emptyFormatted 105 | [t] -> t 106 | ts -> foldl' fuse emptyFormatted ts 107 | 108 | cat' :: [Formatted attr] -> Formatted attr 109 | cat' = \case 110 | [] -> emptyFormatted 111 | [t] -> t 112 | ts -> Cat (sum (fmap length ts)) ts 113 | 114 | -- | Simplifies 'Formatted' text by leaving out redundant empty bits, joining 115 | -- pieces of text with the same formatting, and flattening redundant 116 | -- applications of the same style. 117 | -- 118 | -- >>> emptyFormatted `fuse` bare "Text" 119 | -- Text 4 "Text" 120 | -- 121 | -- >>> format (Just ()) (bare "Left") `fuse` format (Just ()) (bare "Right") 122 | -- Format 9 (Just ()) (Text 9 "LeftRight") 123 | -- 124 | fuse :: (Eq attr, Semigroup attr) => Formatted attr -> Formatted attr -> Formatted attr 125 | fuse left right = case (left, right) of 126 | (Empty, formatted) -> formatted 127 | (formatted, Empty) -> formatted 128 | (Text l t, Text l' t') -> Text (l + l') (t <> t') 129 | (Format l attr t, Format l' attr' t') 130 | | attr' == attr -> Format (l + l') attr (t <> t') 131 | 132 | (Cat l ts, Cat l' ts') -> Cat (l + l') (ts ++ ts') 133 | (Cat l ts, formatted) -> Cat (l + length formatted) (ts ++ [formatted]) 134 | (formatted, Cat _ (t:ts)) -> case formatted `fuse` t of 135 | Cat _ ts' -> cat' (ts' ++ ts) 136 | t' -> cat' (t' : ts) 137 | (formatted, formatted') -> cat' [formatted, formatted'] 138 | 139 | length :: Formatted attr -> Int 140 | length = \case 141 | Empty -> 0 142 | Text l _ -> l 143 | Format l _ _ -> l 144 | Cat l _ -> l 145 | 146 | 147 | 148 | -- | Apply a function to each piece of text in the 'Formatted' tree. 149 | -- 150 | -- >>> mapText T.toUpper (Cat 11 [Text 6 "Hello ", Format 5 () (Text 5 "World")]) 151 | -- Cat 11 [Text 6 "HELLO ",Format 5 () (Text 5 "WORLD")] 152 | -- 153 | mapText :: (Text -> Text) -> Formatted a -> Formatted a 154 | mapText f = \case 155 | Empty -> emptyFormatted 156 | Text _ t -> bare (f t) 157 | Format _ attr t -> format' attr (mapText f t) 158 | Cat _ ts -> cat' (map (mapText f) ts) 159 | 160 | -- | Like 'mapText', but passes the position of the text chunk to the function 161 | -- as well. Can be used for formatting text position-dependently, e.g. for 162 | -- expanding tabs to spaces. 163 | mapTextWithPos :: (Int -> Text -> Text) -> Formatted a -> Formatted a 164 | mapTextWithPos f = go 0 165 | where 166 | go pos = \case 167 | Empty -> emptyFormatted 168 | Text _ t -> bare (f pos t) 169 | Format _ attr t -> format' attr (go pos t) 170 | Cat _ ts -> cat' (go2 pos ts) 171 | go2 pos = \case 172 | [] -> [] 173 | t : ts -> let t' = go pos t 174 | l' = length t' 175 | ts' = go2 (pos + l') ts 176 | in t' : ts' 177 | 178 | 179 | -- | Crops the text to a given length. If the text is already shorter than the 180 | -- desired width, it is returned as-is. 181 | takeFormatted :: Int -> Formatted a -> Formatted a 182 | takeFormatted w txt 183 | | length txt > w = mapTextWithPos cropChunk txt 184 | | otherwise = txt 185 | where 186 | cropChunk pos 187 | | pos >= w = const T.empty 188 | | otherwise = T.take (w - pos) 189 | 190 | -- | Drops a prefix of the given length. If the text is already shorter than the 191 | -- number of characters to be dropped, 'emptyFormatted' is returned. 192 | dropFormatted :: Int -> Formatted a -> Formatted a 193 | dropFormatted amount txt 194 | | amount <= 0 = txt 195 | | length txt < amount = emptyFormatted 196 | | otherwise = case txt of 197 | Empty -> emptyFormatted 198 | Text _ t -> bare (T.drop amount t) 199 | Format _ attr t -> format' attr (dropFormatted amount t) 200 | Cat _ ts -> cat' (dropChunks amount ts) 201 | where 202 | dropChunks n = \case 203 | [] -> [] 204 | t:ts -> dropFormatted n t : dropChunks (n - length t) ts 205 | 206 | -- | Pads the text to a given width. If the text is already longer than the 207 | -- desired width, it is returned as-is. 208 | padFormatted :: Int -> Char -> Formatted a -> Formatted a 209 | padFormatted w c txt 210 | | w > length txt = cat' [txt, padding (w - length txt)] 211 | | otherwise = txt 212 | where 213 | padding l = bare (T.replicate l (T.singleton c)) 214 | -------------------------------------------------------------------------------- /src/Vgrep/Ansi/Vty/Attributes.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Ansi.Vty.Attributes 2 | ( Attr () 3 | , combineStyles 4 | ) where 5 | 6 | import Data.Bits ((.|.)) 7 | import Graphics.Vty.Attributes (Attr (..), MaybeDefault (..), defAttr) 8 | 9 | -- | Combines two 'Attr's. This differs from 'mappend' from the 'Monoid' 10 | -- instance of 'Attr' in that 'Vty.Style's are combined rather than 11 | -- overwritten. 12 | combineStyles :: Attr -> Attr -> Attr 13 | combineStyles l r = defAttr 14 | { attrStyle = case (attrStyle l, attrStyle r) of 15 | (SetTo l', SetTo r') -> SetTo (l' .|. r') 16 | (l', r') -> l' <> r' 17 | , attrForeColor = attrForeColor l <> attrForeColor r 18 | , attrBackColor = attrBackColor l <> attrBackColor r 19 | } 20 | -------------------------------------------------------------------------------- /src/Vgrep/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TupleSections #-} 4 | module Vgrep.App 5 | ( App(..) 6 | , runApp, runApp_ 7 | ) where 8 | 9 | import Control.Concurrent.Async 10 | import Graphics.Vty (Vty) 11 | import qualified Graphics.Vty as Vty 12 | import Pipes 13 | import Pipes.Concurrent.PQueue 14 | import Pipes.Prelude as P 15 | 16 | import Vgrep.App.Internal 17 | import Vgrep.Environment 18 | import Vgrep.Event 19 | import Vgrep.Type 20 | 21 | 22 | -- | The 'App' type is parameterized over the type 'e' of events it handles 23 | -- and the type 's' of its state. 24 | data App e s = App 25 | { initialize :: forall m. MonadIO m => m s 26 | -- ^ Creates the initial state for the app. 27 | 28 | , liftEvent :: Vty.Event -> e 29 | -- ^ How to convert an external 'Vty.Event' to the App's event 30 | 31 | , handleEvent :: forall m. MonadIO m => e -> Environment -> s -> Next (VgrepT s m Redraw) 32 | -- ^ Handles an event, possibly modifying the App's state. 33 | -- 34 | -- @ 35 | -- handleEvent e s = case e of 36 | -- 'Vty.EvKey' 'Vty.KEnter' [] -> 'Continue' ('pure' 'Unchanged') 37 | -- -- Handles the @Enter@ key, but does nothing. 38 | -- 39 | -- 'Vty.EvKey' 'Vty.KUp' [] -> 'Continue' ('pure' 'Redraw') 40 | -- -- Handles the @Up@ key and triggers a redraw. 41 | -- 42 | -- _otherwise -> 'Skip' 43 | -- -- Does not handle the event, so other handlers may be invoked. 44 | -- @ 45 | 46 | , render :: forall m. Monad m => VgrepT s m Vty.Picture 47 | -- ^ Creates a 'Vty.Picture' to be displayed. May modify the App's 48 | -- state (e. g. for resizing). 49 | } 50 | 51 | 52 | -- | Like 'runApp', but does not return the final state. 53 | runApp_ :: App e s -> Config -> Producer e IO () -> IO () 54 | runApp_ app conf externalEvents = void (runApp app conf externalEvents) 55 | 56 | -- | Runs runs the event loop until an @'Interrupt' 'Halt'@ is encountered. 57 | -- Events handled with @'Interrupt' ('Suspend' action)@ will shut down 58 | -- 'Vty.Vty', run the action (e. g. invoking an external editor), and start 59 | -- 'Vty.Vty' again. 60 | runApp :: App e s -> Config -> Producer e IO () -> IO s 61 | runApp app conf externalEvents = withSpawn $ \(evSink, evSource) -> do 62 | initialViewport <- viewportHack 63 | let userEventSink = contramap (User,) evSink 64 | systemEventSink = contramap (System,) evSink 65 | externalEventThread <- (async . runEffect) (externalEvents >-> toOutput systemEventSink) 66 | initialState <- initialize app 67 | (_, finalState) <- runVgrepT (appEventLoop app evSource userEventSink) 68 | initialState 69 | (Env conf initialViewport) 70 | cancel externalEventThread 71 | pure finalState 72 | 73 | -- | Monomorphic version of 'Data.Functor.Contravariant.contramap', to 74 | -- avoid having to update pipes-concurrency. 75 | contramap :: (b -> a) -> Output a -> Output b 76 | contramap f (Output a) = Output (a . f) 77 | 78 | 79 | appEventLoop :: forall e s. App e s -> Input e -> Output e -> VgrepT s IO () 80 | appEventLoop app evSource evSink = eventLoop 81 | 82 | where 83 | eventLoop :: VgrepT s IO () 84 | eventLoop = startEventLoop >>= suspendAndResume 85 | 86 | startEventLoop :: VgrepT s IO Interrupt 87 | startEventLoop = withVgrepVty $ \vty -> withEvThread vtyEventSink vty $ do 88 | refresh vty 89 | runEffect ((fromInput evSource >> pure Halt) >-> eventHandler vty) 90 | 91 | suspendAndResume :: Interrupt -> VgrepT s IO () 92 | suspendAndResume = \case 93 | Halt -> pure () 94 | Suspend outsideAction -> do env <- ask 95 | outsideAction env 96 | eventLoop 97 | 98 | eventHandler :: Vty -> Consumer e (VgrepT s IO) Interrupt 99 | eventHandler vty = go 100 | where 101 | go = do 102 | event <- await 103 | currentState <- get 104 | env <- ask 105 | case handleAppEvent event env currentState of 106 | Skip -> go 107 | Continue action -> lift action >>= \case 108 | Unchanged -> go 109 | Redraw -> lift (refresh vty) >> go 110 | Interrupt int -> pure int 111 | 112 | refresh :: Vty -> VgrepT s IO () 113 | refresh vty = render app >>= lift . Vty.update vty 114 | vtyEventSink = P.map (liftEvent app) >-> toOutput evSink 115 | handleAppEvent = handleEvent app 116 | -------------------------------------------------------------------------------- /src/Vgrep/App/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Vgrep.App.Internal where 4 | 5 | import Control.Concurrent.Async 6 | import Control.Exception 7 | import Graphics.Vty (Vty) 8 | import qualified Graphics.Vty as Vty 9 | import Pipes 10 | import System.Posix.IO 11 | import System.Posix.Types (Fd) 12 | 13 | import Vgrep.Type 14 | 15 | 16 | -- | 'User' events do have higher priority than 'System' events, so that 17 | -- the application stays responsive even in case of event queue congestion. 18 | data EventPriority = User | System deriving (Eq, Ord, Enum) 19 | 20 | 21 | -- | We need the viewport in order to initialize the app, which in turn will 22 | -- start 'Vty.Vty'. To resolve this circular dependency, we start once 'Vty.Vty' 23 | -- in order to determine the display viewport, and shut it down again 24 | -- immediately. 25 | viewportHack :: IO Viewport 26 | viewportHack = withVty $ \vty -> do 27 | (width, height) <- Vty.displayBounds (Vty.outputIface vty) 28 | pure Viewport { _vpWidth = width , _vpHeight = height } 29 | 30 | -- | Spawns a thread parallel to the action that listens to 'Vty' events and 31 | -- redirects them to the 'Consumer'. 32 | withEvThread :: Consumer Vty.Event IO () -> Vty -> VgrepT s IO a -> VgrepT s IO a 33 | withEvThread sink vty = 34 | vgrepBracket createEvThread cancel . const 35 | where 36 | createEvThread = (async . runEffect) $ lift (Vty.nextEvent vty) >~ sink 37 | 38 | 39 | -- | Passes a 'Vty' instance to the action and shuts it down properly after the 40 | -- action finishes. The 'Vty.inputFd' and 'Vty.outputFd' handles are connected 41 | -- to @\/dev\/tty@ (see 'tty'). 42 | withVty :: (Vty -> IO a) -> IO a 43 | -- | Like 'withVty', but lifted to @'VgrepT' s 'IO'@. 44 | withVgrepVty :: (Vty -> VgrepT s IO a) -> VgrepT s IO a 45 | (withVty, withVgrepVty) = 46 | let initVty fd = do 47 | cfg <- Vty.standardIOConfig 48 | Vty.mkVty cfg { Vty.inputFd = Just fd 49 | , Vty.outputFd = Just fd } 50 | in ( \action -> withTty $ \fd -> bracket (initVty fd) Vty.shutdown action 51 | , \action -> withVgrepTty $ \fd -> vgrepBracket (initVty fd) Vty.shutdown action) 52 | 53 | 54 | -- | Passes two file descriptors for read and write access to @\/dev\/tty@ to 55 | -- the action, and closes them after the action has finished. 56 | withTty :: (Fd -> IO a) -> IO a 57 | -- | Like 'withTty', but lifted to @'VgrepT' s 'IO'@. 58 | withVgrepTty :: (Fd -> VgrepT s IO a) -> VgrepT s IO a 59 | (withTty, withVgrepTty) = (bracket before after, vgrepBracket before after) 60 | where 61 | before = tty 62 | after fd = closeFd fd `catch` ignoreIOException 63 | ignoreIOException :: IOException -> IO () 64 | ignoreIOException _ = pure () 65 | 66 | -- | Opens @\/dev\/tty@ in Read/Write mode. Should be connected to the @stdin@ and 67 | -- @stdout@ of a GUI process (e. g. 'Vty.Vty'). 68 | tty :: IO Fd 69 | tty = openFd "/dev/tty" ReadWrite Nothing defaultFileFlags 70 | -------------------------------------------------------------------------------- /src/Vgrep/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module Vgrep.Command where 3 | 4 | import GHC.Generics 5 | 6 | data Command 7 | = DisplayPagerOnly -- ^ Display the pager full-screen 8 | | DisplayResultsOnly -- ^ Display the results list full-screen 9 | | SplitFocusPager -- ^ Split screen, focus on pager 10 | | SplitFocusResults -- ^ Split screen, focus on results list 11 | 12 | | PagerUp -- ^ Scroll one line up in pager 13 | | PagerDown -- ^ Scroll one line down in pager 14 | | PagerPageUp -- ^ Scroll one page up in pager 15 | | PagerPageDown -- ^ Scroll one page down in pager 16 | | PagerHalfPageUp -- ^ Scroll half a page up in pager 17 | | PagerHalfPageDown -- ^ Scroll half a page down in pager 18 | | PagerScrollLeft -- ^ Scroll eight characters left in pager 19 | | PagerScrollRight -- ^ Scroll eight characters right in pager 20 | 21 | | ResultsUp -- ^ Move to previous result 22 | | ResultsDown -- ^ Move to next result 23 | | ResultsPageUp -- ^ Move one page up in results list 24 | | ResultsPageDown -- ^ Move one page down in results list 25 | 26 | | PrevResult -- ^ Move to previous result and update pager 27 | | NextResult -- ^ Move to next result and update pager 28 | | PagerGotoResult -- ^ Update pager with currently selected result 29 | 30 | | OpenFileInEditor -- ^ Open file in external editor and jump to 31 | -- currently selected result 32 | 33 | | Exit -- ^ Exit the application 34 | 35 | | Unset -- ^ Treat keybinding as if not present, fall back to 36 | -- alternative binding (used to override keybindings) 37 | 38 | deriving (Eq, Show, Generic) 39 | -------------------------------------------------------------------------------- /src/Vgrep/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Vgrep.Environment 3 | ( Environment (..) 4 | , Viewport (..) 5 | 6 | -- * Auto-generated Lenses 7 | , config 8 | , viewport 9 | , vpHeight 10 | , vpWidth 11 | 12 | -- * Convenience Lenses 13 | , viewportWidth 14 | , viewportHeight 15 | 16 | -- * Re-exports 17 | , module Vgrep.Environment.Config 18 | ) where 19 | 20 | import Control.Lens.Compat 21 | 22 | import Vgrep.Environment.Config 23 | 24 | 25 | -- | The bounds (width and height) of a display viewport. 26 | data Viewport = Viewport { _vpWidth :: Int, _vpHeight :: Int } 27 | deriving (Eq, Show) 28 | 29 | makeLenses ''Viewport 30 | 31 | 32 | -- | 'Vgrep.Type.VgrepT' actions can read from the environment. 33 | data Environment = Env 34 | { _config :: Config 35 | -- ^ External configuration (colors, editor executable, …) 36 | 37 | , _viewport :: Viewport 38 | -- ^ The bounds (width and height) of the display viewport where the 39 | -- 'Vgrep.App.App' or the current 'Vgrep.Widget.Widget' is displayed 40 | } deriving (Eq, Show) 41 | 42 | makeLenses ''Environment 43 | 44 | 45 | viewportHeight, viewportWidth :: Lens' Environment Int 46 | viewportHeight = viewport . vpHeight 47 | viewportWidth = viewport . vpWidth 48 | -------------------------------------------------------------------------------- /src/Vgrep/Environment/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Vgrep.Environment.Config where 4 | 5 | import Control.Lens.Compat 6 | import Control.Monad.IO.Class 7 | import Data.Maybe 8 | import Data.Monoid 9 | import Graphics.Vty.Attributes 10 | ( Attr 11 | , blue 12 | , bold 13 | , defAttr 14 | , green 15 | , standout 16 | , withBackColor 17 | , withForeColor 18 | , withStyle 19 | ) 20 | 21 | import Vgrep.Command 22 | import Vgrep.Environment.Config.Monoid 23 | import Vgrep.Environment.Config.Sources 24 | import qualified Vgrep.Key as Key 25 | import Vgrep.KeybindingMap (KeybindingMap (..)) 26 | import qualified Vgrep.KeybindingMap as KeybindingMap 27 | 28 | 29 | -------------------------------------------------------------------------- 30 | -- * Types 31 | -------------------------------------------------------------------------- 32 | 33 | data Config = Config 34 | { _colors :: Colors 35 | -- ^ Color configuration 36 | 37 | , _tabstop :: Int 38 | -- ^ Tabstop width (default: 8) 39 | 40 | , _editor :: String 41 | -- ^ Executable for @e@ key (default: environment variable @$EDITOR@, 42 | -- or @vi@ if @$EDITOR@ is not set) 43 | 44 | , _keybindings :: Keybindings 45 | 46 | } deriving (Eq, Show) 47 | 48 | data Colors = Colors 49 | { _lineNumbers :: Attr 50 | -- ^ Line numbers (default: blue) 51 | 52 | , _lineNumbersHl :: Attr 53 | -- ^ Highlighted line numbers (default: bold blue) 54 | 55 | , _normal :: Attr 56 | -- ^ Normal text (default: terminal default) 57 | 58 | , _normalHl :: Attr 59 | -- ^ Highlighted text (default: bold) 60 | 61 | , _fileHeaders :: Attr 62 | -- ^ File names in results view (default: terminal default color on 63 | -- green background) 64 | 65 | , _selected :: Attr 66 | -- ^ Selected entry (default: terminal default, inverted) 67 | 68 | } deriving (Eq, Show) 69 | 70 | data Keybindings = Keybindings 71 | { _resultsKeybindings :: KeybindingMap 72 | -- ^ Keybindings in effect when results list is focused. 73 | 74 | , _pagerKeybindings :: KeybindingMap 75 | -- ^ Keybindings in effect when pager is focused. 76 | 77 | , _globalKeybindings :: KeybindingMap 78 | -- ^ Global keybindings are in effect both for pager and results list, but 79 | -- can be overridden by either one. 80 | 81 | } deriving (Eq, Show) 82 | 83 | 84 | -------------------------------------------------------------------------- 85 | -- * Auto-generated Lenses 86 | -------------------------------------------------------------------------- 87 | 88 | makeLenses ''Config 89 | makeLenses ''Colors 90 | makeLenses ''Keybindings 91 | 92 | 93 | -------------------------------------------------------------------------- 94 | -- * Read Config from Monoid 95 | -------------------------------------------------------------------------- 96 | 97 | -- | Convert a 'ConfigMonoid' to a 'Config'. Missing (@'mempty'@) values in the 98 | -- 'ConfigMonoid' are supplied from the 'defaultConfig'. 99 | fromConfigMonoid :: ConfigMonoid -> Config 100 | fromConfigMonoid ConfigMonoid{..} = Config 101 | { _colors = fromColorsMonoid _mcolors 102 | , _tabstop = fromFirst (_tabstop defaultConfig) _mtabstop 103 | , _editor = fromFirst (_editor defaultConfig) _meditor 104 | , _keybindings = fromKeybindingsMonoid _mkeybindings } 105 | 106 | -- | Convert a 'ColorsMonoid' to a 'Colors' config. 107 | fromColorsMonoid :: ColorsMonoid -> Colors 108 | fromColorsMonoid ColorsMonoid{..} = Colors 109 | { _lineNumbers = fromFirst (_lineNumbers defaultColors) _mlineNumbers 110 | , _lineNumbersHl = fromFirst (_lineNumbersHl defaultColors) _mlineNumbersHl 111 | , _normal = fromFirst (_normal defaultColors) _mnormal 112 | , _normalHl = fromFirst (_normalHl defaultColors) _mnormalHl 113 | , _fileHeaders = fromFirst (_fileHeaders defaultColors) _mfileHeaders 114 | , _selected = fromFirst (_selected defaultColors) _mselected } 115 | 116 | fromFirst :: a -> First a -> a 117 | fromFirst a = fromMaybe a . getFirst 118 | 119 | fromKeybindingsMonoid :: KeybindingsMonoid -> Keybindings 120 | fromKeybindingsMonoid KeybindingsMonoid{..} = Keybindings 121 | { _resultsKeybindings = fromMaybe mempty _mresultsKeybindings <> _resultsKeybindings defaultKeybindings 122 | , _pagerKeybindings = fromMaybe mempty _mpagerKeybindings <> _pagerKeybindings defaultKeybindings 123 | , _globalKeybindings = fromMaybe mempty _mglobalKeybindings <> _globalKeybindings defaultKeybindings } 124 | 125 | 126 | -------------------------------------------------------------------------- 127 | -- * Default Config 128 | -------------------------------------------------------------------------- 129 | 130 | defaultConfig :: Config 131 | defaultConfig = Config 132 | { _colors = defaultColors 133 | , _tabstop = 8 134 | , _editor = "vi" 135 | , _keybindings = defaultKeybindings } 136 | 137 | defaultColors :: Colors 138 | defaultColors = Colors 139 | { _lineNumbers = defAttr `withForeColor` blue 140 | , _lineNumbersHl = defAttr `withForeColor` blue 141 | `withStyle` bold 142 | , _normal = defAttr 143 | , _normalHl = defAttr `withStyle` bold 144 | , _fileHeaders = defAttr `withBackColor` green 145 | , _selected = defAttr `withStyle` standout } 146 | 147 | defaultKeybindings :: Keybindings 148 | defaultKeybindings = Keybindings 149 | { _resultsKeybindings = KeybindingMap.fromList 150 | [ (Key.key Key.Up, ResultsUp) 151 | , (Key.key Key.Down, ResultsDown) 152 | , (Key.key Key.PageUp, ResultsPageUp) 153 | , (Key.key Key.PageDown, ResultsPageDown) 154 | , (Key.key Key.Enter, PagerGotoResult) 155 | , (Key.key (Key.Char 'k'), ResultsUp) 156 | , (Key.key (Key.Char 'j'), ResultsDown) 157 | , (Key.key (Key.Char 'b') `Key.withModifier` Key.Ctrl, ResultsPageUp) 158 | , (Key.key (Key.Char 'f') `Key.withModifier` Key.Ctrl, ResultsPageDown) 159 | , (Key.key (Key.Char 'f'), DisplayResultsOnly) 160 | , (Key.key Key.Tab, SplitFocusPager) ] 161 | , _pagerKeybindings = KeybindingMap.fromList 162 | [ (Key.key Key.Up, PagerUp) 163 | , (Key.key Key.Down, PagerDown) 164 | , (Key.key Key.PageUp, PagerPageUp) 165 | , (Key.key Key.PageDown, PagerPageDown) 166 | , (Key.key Key.Left, PagerScrollLeft) 167 | , (Key.key Key.Right, PagerScrollRight) 168 | , (Key.key (Key.Char 'k'), PagerUp) 169 | , (Key.key (Key.Char 'j'), PagerDown) 170 | , (Key.key (Key.Char 'h'), PagerScrollLeft) 171 | , (Key.key (Key.Char 'l'), PagerScrollRight) 172 | , (Key.key (Key.Char 'u') `Key.withModifier` Key.Ctrl, PagerHalfPageUp) 173 | , (Key.key (Key.Char 'd') `Key.withModifier` Key.Ctrl, PagerHalfPageDown) 174 | , (Key.key (Key.Char 'b') `Key.withModifier` Key.Ctrl, PagerPageUp) 175 | , (Key.key (Key.Char 'f') `Key.withModifier` Key.Ctrl, PagerPageDown) 176 | , (Key.key (Key.Char 'f'), DisplayPagerOnly) 177 | , (Key.key Key.Tab, SplitFocusResults) 178 | , (Key.key (Key.Char 'q'), DisplayResultsOnly) ] 179 | , _globalKeybindings = KeybindingMap.fromList 180 | [ (Key.key (Key.Char 'e'), OpenFileInEditor) 181 | , (Key.key (Key.Char 'q'), Exit) ] 182 | } 183 | 184 | 185 | -------------------------------------------------------------------------- 186 | -- * Config Loader 187 | -------------------------------------------------------------------------- 188 | 189 | -- | Gathers 'ConfigMonoid's from various sources and builds a 'Config' 190 | -- based on the 'defaultConfig': 191 | -- 192 | -- * Config from environment variables 193 | -- * The configuration specified in the config file 194 | -- * External config, e.g. from command line 195 | -- 196 | -- where the latter ones override the earlier ones. 197 | loadConfig 198 | :: MonadIO io 199 | => ConfigMonoid -- ^ External config from command line 200 | -> io Config 201 | loadConfig configFromArgs = do 202 | configs <- sequence 203 | [ pure configFromArgs 204 | , configFromFile 205 | , editorConfigFromEnv ] 206 | pure (fromConfigMonoid (mconcat configs)) 207 | -------------------------------------------------------------------------------- /src/Vgrep/Environment/Config/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module Vgrep.Environment.Config.Monoid 3 | ( ConfigMonoid (..) 4 | , ColorsMonoid (..) 5 | , KeybindingsMonoid (..) 6 | ) where 7 | 8 | import Data.Monoid 9 | import Generics.Deriving.Monoid (mappenddefault, memptydefault) 10 | import GHC.Generics 11 | import Graphics.Vty.Attributes (Attr) 12 | 13 | import Vgrep.KeybindingMap (KeybindingMap (..)) 14 | 15 | -- $setup 16 | -- >>> import Data.Map.Strict 17 | -- >>> import Vgrep.Command 18 | -- >>> import qualified Vgrep.Key as Key 19 | 20 | -- | A 'Monoid' for reading partial configs. The 'ConfigMonoid' can be converted 21 | -- to an actual 'Vgrep.Environment.Config.Config' using 22 | -- 'Vgrep.Environment.Config.fromConfigMonoid'. 23 | -- 24 | -- The Monoid consists mostly of 'First a' values, so the most important config 25 | -- (the one that overrides all the others) should be read first. 26 | data ConfigMonoid = ConfigMonoid 27 | { _mcolors :: ColorsMonoid 28 | , _mtabstop :: First Int 29 | , _meditor :: First String 30 | , _mkeybindings :: KeybindingsMonoid 31 | } deriving (Eq, Show, Generic) 32 | 33 | instance Semigroup ConfigMonoid where 34 | (<>) = mappenddefault 35 | 36 | instance Monoid ConfigMonoid where 37 | mempty = memptydefault 38 | 39 | 40 | -- | A 'Monoid' for reading partial 'Vgrep.Environment.Config.Colors' 41 | -- configurations. 42 | -- 43 | -- Note that the attributes are not merged, but overridden: 44 | -- 45 | -- >>> import Graphics.Vty.Attributes 46 | -- >>> let leftStyle = defAttr `withStyle` standout 47 | -- >>> let rightStyle = defAttr `withForeColor` black 48 | -- >>> let l = mempty { _mnormal = First (Just leftStyle)} 49 | -- >>> let r = mempty { _mnormal = First (Just rightStyle)} 50 | -- >>> _mnormal (l <> r) == First (Just (leftStyle <> rightStyle)) 51 | -- False 52 | -- >>> _mnormal (l <> r) == First (Just leftStyle) 53 | -- True 54 | data ColorsMonoid = ColorsMonoid 55 | { _mlineNumbers :: First Attr 56 | , _mlineNumbersHl :: First Attr 57 | , _mnormal :: First Attr 58 | , _mnormalHl :: First Attr 59 | , _mfileHeaders :: First Attr 60 | , _mselected :: First Attr 61 | } deriving (Eq, Show, Generic) 62 | 63 | instance Semigroup ColorsMonoid where 64 | (<>) = mappenddefault 65 | 66 | instance Monoid ColorsMonoid where 67 | mempty = memptydefault 68 | 69 | 70 | -- | A 'Monoid' for reading a partial 'Vgrep.Environment.Config.Keybindings' 71 | -- configuration. 72 | -- 73 | -- Mappings are combined using left-biased 'Data.Map.Strict.union': 74 | -- 75 | -- >>> let l = Just (KeybindingMap (fromList [(Key.Chord mempty Key.Down, ResultsDown), (Key.Chord mempty Key.Up, ResultsUp)])) 76 | -- >>> let r = Just (KeybindingMap (fromList [(Key.Chord mempty Key.Down, PagerDown)])) 77 | -- >>> l <> r 78 | -- Just (KeybindingMap {unKeybindingMap = fromList [(Chord (fromList []) Up,ResultsUp),(Chord (fromList []) Down,ResultsDown)]}) 79 | -- >>> r <> l 80 | -- Just (KeybindingMap {unKeybindingMap = fromList [(Chord (fromList []) Up,ResultsUp),(Chord (fromList []) Down,PagerDown)]}) 81 | -- 82 | -- In particular, @'Just' ('Data.Map.Strict.fromList' [])@ (declaring an empty 83 | -- list of mappings) and @'Nothing'@ (not declaring anything) are equivalent, 84 | -- given that there are already default mappings: 85 | -- 86 | -- >>> l <> Just (KeybindingMap (fromList [])) == l <> Nothing 87 | -- True 88 | -- 89 | -- This means that new keybindings override the previous ones if they collide, 90 | -- otherwise they are simply added. To remove a keybinding, it has to be mapped 91 | -- to 'Unset' explicitly. 92 | data KeybindingsMonoid = KeybindingsMonoid 93 | { _mresultsKeybindings :: Maybe KeybindingMap 94 | , _mpagerKeybindings :: Maybe KeybindingMap 95 | , _mglobalKeybindings :: Maybe KeybindingMap 96 | } deriving (Eq, Show, Generic) 97 | 98 | instance Semigroup KeybindingsMonoid where 99 | (<>) = mappenddefault 100 | 101 | instance Monoid KeybindingsMonoid where 102 | mempty = memptydefault 103 | -------------------------------------------------------------------------------- /src/Vgrep/Environment/Config/Sources.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Environment.Config.Sources 2 | ( module Vgrep.Environment.Config.Sources.Env 3 | , module Vgrep.Environment.Config.Sources.File 4 | ) where 5 | 6 | import Vgrep.Environment.Config.Sources.Env (editorConfigFromEnv) 7 | import Vgrep.Environment.Config.Sources.File (configFromFile) 8 | -------------------------------------------------------------------------------- /src/Vgrep/Environment/Config/Sources/Env.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Environment.Config.Sources.Env where 2 | 3 | import Control.Monad.IO.Class 4 | import Data.Monoid 5 | import System.Environment 6 | 7 | import Vgrep.Environment.Config.Monoid 8 | 9 | 10 | -- | Determines the 'ConfigMonoid' value for 'Vgrep.Environment.Config._editor' 11 | -- ('_meditor') from the environment variable @$EDITOR@. 12 | editorConfigFromEnv :: MonadIO io => io ConfigMonoid 13 | editorConfigFromEnv = do 14 | configuredEditor <- liftIO (lookupEnv "EDITOR") 15 | pure (mempty { _meditor = First configuredEditor }) 16 | -------------------------------------------------------------------------------- /src/Vgrep/Environment/Config/Sources/File.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of camelTo 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | 8 | module Vgrep.Environment.Config.Sources.File 9 | ( configFromFile 10 | , Attr 11 | , Color 12 | , Style 13 | ) where 14 | 15 | import Control.Monad ((<=<)) 16 | import Control.Monad.IO.Class 17 | import Data.Aeson.Types 18 | ( FromJSON (..) 19 | , Options (..) 20 | , Parser 21 | , camelTo 22 | , defaultOptions 23 | , genericParseJSON 24 | , withObject 25 | , (.!=) 26 | , (.:?) 27 | ) 28 | import Data.Map.Strict (Map) 29 | import qualified Data.Map.Strict as M 30 | import Data.Maybe 31 | import Data.Monoid 32 | import Data.Yaml.Aeson 33 | ( decodeFileEither 34 | , prettyPrintParseException 35 | ) 36 | import GHC.Generics 37 | import qualified Graphics.Vty.Attributes as Vty 38 | import System.Directory 39 | import System.IO 40 | import Text.Read (readMaybe) 41 | 42 | import Vgrep.Command 43 | import Vgrep.Environment.Config.Monoid 44 | import qualified Vgrep.Key as Key 45 | import Vgrep.KeybindingMap 46 | 47 | -- $setup 48 | -- >>> import Data.Either (isLeft) 49 | -- >>> import Data.Yaml.Aeson (decodeEither', ParseException(..)) 50 | 51 | 52 | {- | 53 | Reads the configuration from a JSON or YAML file. The file should be 54 | located in one of the following places: 55 | 56 | * @~\/.vgrep\/config.yaml@, 57 | * @~\/.vgrep\/config.yml@, 58 | * @~\/.vgrep\/config.json@ or 59 | * @~\/.vgrep\/config@. 60 | 61 | When none of these files exist, no error is raised. When a file exists, but 62 | cannot be parsed, a warning is written to stderr. 63 | 64 | Supported formats are JSON and YAML. The example YAML config given in the 65 | project directory (@config.yaml.example@) is equivalent to the default 66 | config: 67 | 68 | >>> import qualified Vgrep.Environment.Config as C 69 | >>> Right config <- decodeFileEither "config.yaml.example" :: IO (Either ParseException ConfigMonoid) 70 | >>> C.fromConfigMonoid config == C.defaultConfig 71 | True 72 | 73 | Example YAML config file for 'Vgrep.Environment.Config.defaultConfig': 74 | 75 | > colors: 76 | > line-numbers: 77 | > fore-color: blue 78 | > line-numbers-hl: 79 | > fore-color: blue 80 | > style: bold 81 | > normal: {} 82 | > normal-hl: 83 | > style: bold 84 | > file-headers: 85 | > back-color: green 86 | > selected: 87 | > style: standout 88 | > tabstop: 8 89 | > editor: "vi" 90 | 91 | Example JSON file for the same config: 92 | 93 | > { 94 | > "colors": { 95 | > "line-numbers" : { 96 | > "fore-color": "blue" 97 | > }, 98 | > "line-numbers-hl": { 99 | > "fore-color": "blue", 100 | > "style": "bold" 101 | > }, 102 | > "normal": {}, 103 | > "normal-hl": { 104 | > "style": "bold" 105 | > }, 106 | > "file-headers": { 107 | > "back-color": "green" 108 | > }, 109 | > "selected": { 110 | > "style": "standout" 111 | > } 112 | > }, 113 | > "tabstop": 8, 114 | > "editor": "vi" 115 | > } 116 | 117 | The JSON/YAML keys correspond to the lenses in "Vgrep.Environment.Config", 118 | the values for 'Vty.Color' and 'Vty.Style' can be obtained from the 119 | corresponding predefined constants in "Graphics.Vty.Attributes". 120 | -} 121 | configFromFile :: MonadIO io => io ConfigMonoid 122 | configFromFile = liftIO $ do 123 | configDir <- getAppUserDataDirectory "vgrep" 124 | let configFiles = map (configDir ) 125 | [ "config.yaml" 126 | , "config.yml" 127 | , "config.json" 128 | , "config" ] 129 | findExistingFile configFiles >>= \case 130 | Nothing -> pure mempty 131 | Just configFile -> decodeFileEither configFile >>= \case 132 | Right config -> pure config 133 | Left err -> do 134 | hPutStrLn stderr $ 135 | "Could not parse config file " ++ configFile ++ ":" 136 | ++ "\n" ++ prettyPrintParseException err 137 | ++ "\nFalling back to default config." 138 | pure mempty 139 | where 140 | findExistingFile :: [FilePath] -> IO (Maybe FilePath) 141 | findExistingFile = \case 142 | [] -> pure Nothing 143 | f : fs -> do 144 | exists <- doesFileExist f 145 | if exists then pure (Just f) else findExistingFile fs 146 | 147 | () :: FilePath -> FilePath -> FilePath 148 | dir file = dir <> "/" <> file 149 | 150 | 151 | instance FromJSON ConfigMonoid where 152 | parseJSON = withObject "ConfigMonoid" $ \o -> do 153 | _mcolors <- o .:? "colors" .!= mempty 154 | _mtabstop <- fmap First (o .:? "tabstop") 155 | _meditor <- fmap First (o .:? "editor") 156 | _mkeybindings <- o .:? "keybindings" .!= mempty 157 | pure ConfigMonoid{..} 158 | 159 | instance FromJSON ColorsMonoid where 160 | parseJSON = genericParseJSON jsonOptions 161 | 162 | instance FromJSON Vty.Attr where 163 | parseJSON = fmap attrToVty . parseJSON 164 | 165 | 166 | {- | 167 | A JSON-parsable data type for 'Vty.Attr'. 168 | 169 | JSON example: 170 | 171 | >>> decodeEither' "{\"fore-color\": \"black\", \"style\": \"standout\"}" :: Either ParseException Attr 172 | Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout}) 173 | 174 | JSON example without quotes: 175 | >>> decodeEither' "{fore-color: black, style: standout}" :: Either ParseException Attr 176 | Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout}) 177 | 178 | YAML example: 179 | 180 | >>> :{ 181 | >>> decodeEither' 182 | >>> $ "fore-color: \"blue\"\n" 183 | >>> <> "back-color: \"bright-blue\"\n" 184 | >>> <> "style: \"reverse-video\"\n" 185 | >>> :: Either ParseException Attr 186 | >>> :} 187 | Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo}) 188 | 189 | YAML example without quotes: 190 | 191 | >>> :{ 192 | >>> decodeEither' 193 | >>> $ "fore-color: blue\n" 194 | >>> <> "back-color: bright-blue\n" 195 | >>> <> "style: reverse-video\n" 196 | >>> :: Either ParseException Attr 197 | >>> :} 198 | Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo}) 199 | 200 | An empty JSON/YAML object yields the default colors: 201 | 202 | >>> decodeEither' "{}" :: Either ParseException Attr 203 | Right (Attr {foreColor = Nothing, backColor = Nothing, style = Nothing}) 204 | -} 205 | data Attr = Attr 206 | { foreColor :: Maybe Color 207 | , backColor :: Maybe Color 208 | , style :: Maybe Style 209 | } 210 | deriving (Eq, Show, Generic) 211 | 212 | instance FromJSON Attr where 213 | parseJSON = genericParseJSON jsonOptions 214 | 215 | attrToVty :: Attr -> Vty.Attr 216 | attrToVty Attr{..} = foldAttrs 217 | [ fmap (flip Vty.withForeColor . colorToVty) foreColor 218 | , fmap (flip Vty.withBackColor . colorToVty) backColor 219 | , fmap (flip Vty.withStyle . styleToVty) style ] 220 | where 221 | foldAttrs = foldr ($) Vty.defAttr . catMaybes 222 | 223 | 224 | {- | 225 | A JSON-parsable data type for 'Vty.Color'. 226 | 227 | >>> decodeEither' "[\"black\",\"red\",\"bright-black\"]" :: Either ParseException [Color] 228 | Right [Black,Red,BrightBlack] 229 | 230 | Also works without quotes: 231 | 232 | >>> decodeEither' "[black,red,bright-black]" :: Either ParseException [Color] 233 | Right [Black,Red,BrightBlack] 234 | 235 | Fails with error message if the 'Color' cannot be parsed: 236 | 237 | >>> isLeft (decodeEither' "foo" :: Either ParseException Color) 238 | True 239 | -} 240 | data Color 241 | = Black 242 | | Red 243 | | Green 244 | | Yellow 245 | | Blue 246 | | Magenta 247 | | Cyan 248 | | White 249 | | BrightBlack 250 | | BrightRed 251 | | BrightGreen 252 | | BrightYellow 253 | | BrightBlue 254 | | BrightMagenta 255 | | BrightCyan 256 | | BrightWhite 257 | deriving (Eq, Show, Generic) 258 | 259 | instance FromJSON Color where 260 | parseJSON = genericParseJSON jsonOptions 261 | 262 | colorToVty :: Color -> Vty.Color 263 | colorToVty = \case 264 | Black -> Vty.black 265 | Red -> Vty.red 266 | Green -> Vty.green 267 | Yellow -> Vty.yellow 268 | Blue -> Vty.blue 269 | Magenta -> Vty.magenta 270 | Cyan -> Vty.cyan 271 | White -> Vty.white 272 | BrightBlack -> Vty.brightBlack 273 | BrightRed -> Vty.brightRed 274 | BrightGreen -> Vty.brightGreen 275 | BrightYellow -> Vty.brightYellow 276 | BrightBlue -> Vty.brightBlue 277 | BrightMagenta -> Vty.brightMagenta 278 | BrightCyan -> Vty.brightCyan 279 | BrightWhite -> Vty.brightWhite 280 | 281 | 282 | {- | 283 | A JSON-parsable data type for 'Vty.Style'. 284 | 285 | >>> decodeEither' "[\"standout\", \"underline\", \"bold\"]" :: Either ParseException [Style] 286 | Right [Standout,Underline,Bold] 287 | 288 | Also works without quotes: 289 | 290 | >>> decodeEither' "[standout, underline, bold]" :: Either ParseException [Style] 291 | Right [Standout,Underline,Bold] 292 | 293 | Fails with error message if the 'Style' cannot be parsed: 294 | 295 | >>> isLeft (decodeEither' "foo" :: Either ParseException Color) 296 | True 297 | -} 298 | data Style 299 | = Standout 300 | | Underline 301 | | ReverseVideo 302 | | Blink 303 | | Dim 304 | | Bold 305 | deriving (Eq, Show, Generic) 306 | 307 | instance FromJSON Style where 308 | parseJSON = genericParseJSON jsonOptions 309 | 310 | styleToVty :: Style -> Vty.Style 311 | styleToVty = \case 312 | Standout -> Vty.standout 313 | Underline -> Vty.underline 314 | ReverseVideo -> Vty.reverseVideo 315 | Blink -> Vty.blink 316 | Dim -> Vty.dim 317 | Bold -> Vty.bold 318 | 319 | 320 | instance FromJSON KeybindingsMonoid where 321 | parseJSON = genericParseJSON jsonOptions 322 | 323 | instance FromJSON Command where 324 | parseJSON = genericParseJSON jsonOptions 325 | 326 | instance FromJSON KeybindingMap where 327 | parseJSON = fmap KeybindingMap . mapMKeys parseChord <=< parseJSON 328 | 329 | mapMKeys :: (Monad m, Ord k') => (k -> m k') -> Map k v -> m (Map k' v) 330 | mapMKeys f = fmap M.fromList . M.foldrWithKey go (pure []) 331 | where 332 | go k x mxs = do 333 | k' <- f k 334 | xs <- mxs 335 | pure ((k', x) : xs) 336 | 337 | parseChord :: String -> Parser Key.Chord 338 | parseChord = \case 339 | 'C' : '-' : t -> fmap (`Key.withModifier` Key.Ctrl) (parseChord t) 340 | 'S' : '-' : t -> fmap (`Key.withModifier` Key.Shift) (parseChord t) 341 | 'M' : '-' : t -> fmap (`Key.withModifier` Key.Meta) (parseChord t) 342 | [c] -> pure (Key.key (Key.Char c)) 343 | "PgUp" -> pure (Key.key Key.PageUp) 344 | "PgDown" -> pure (Key.key Key.PageDown) 345 | "PgDn" -> pure (Key.key Key.PageDown) 346 | s | Just k <- readMaybe s 347 | -> pure (Key.key k) 348 | | otherwise -> fail ("Unknown key '" <> s <> "'") 349 | 350 | jsonOptions :: Options 351 | jsonOptions = defaultOptions 352 | { constructorTagModifier = camelTo '-' 353 | , fieldLabelModifier = camelTo '-' . stripPrefix } 354 | where 355 | stripPrefix = \case 356 | '_' : 'm' : name -> name 357 | '_' : name -> name 358 | name -> name 359 | -------------------------------------------------------------------------------- /src/Vgrep/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module Vgrep.Event ( 3 | -- * Event handling 4 | -- | An event handler is a function 5 | -- 6 | -- @ 7 | -- handleEvent :: 'Control.Monad.State.MonadState' s m => e -> s -> 'Next' (m 'Redraw') 8 | -- @ 9 | -- 10 | -- where @e@ is the event type and @s@ is the state of the handler. The 11 | -- 'Next' type determines the type of action to be performed. The state 12 | -- @s@ is passed as a parameter so the handler can decide which type of 13 | -- action to perform, while not being able to modify the state. 14 | -- 15 | -- Event handlers form a 'Monoid' where the first handler that triggers 16 | -- will perform the action: 17 | -- 18 | -- @ 19 | -- (handleSome <> handleOther) event state 20 | -- @ 21 | -- 22 | -- is identical to 23 | -- 24 | -- @ 25 | -- case handleSome event state of 26 | -- Skip -> handleOther event state 27 | -- action -> action 28 | -- @ 29 | Next (..) 30 | , Redraw (..) 31 | , Interrupt (..) 32 | 33 | -- * Dispatching Events 34 | , dispatch 35 | , dispatchMap 36 | 37 | -- ** Re-exports 38 | , module Data.Map 39 | ) where 40 | 41 | import Control.Monad.IO.Class 42 | import Data.Map (Map, fromList) 43 | import qualified Data.Map as M 44 | 45 | import Vgrep.Environment 46 | 47 | 48 | -- | The type of action to be performed on an event. 49 | data Next a 50 | = Skip 51 | -- ^ Do not handle the event (fall-through to other event handlers) 52 | 53 | | Continue a 54 | -- ^ Handle the event by performing an action 55 | 56 | | Interrupt Interrupt 57 | -- ^ Interrupt the application 58 | 59 | -- | The first event handler that triggers (i. e. does not return 'Skip') 60 | -- handles the event. 61 | instance Semigroup (Next a) where 62 | Skip <> next = next 63 | next <> _other = next 64 | 65 | instance Monoid (Next a) where 66 | mempty = Skip 67 | 68 | instance Functor Next where 69 | fmap f = \case Skip -> Skip 70 | Continue a -> Continue (f a) 71 | Interrupt i -> Interrupt i 72 | 73 | data Redraw 74 | = Redraw 75 | -- ^ Indicates that the state has been changed visibly, so the screen 76 | -- should be refreshed. 77 | 78 | | Unchanged 79 | -- ^ The state has not changed or the change would not be visible, so 80 | -- refreshing the screen is not required. 81 | 82 | instance Semigroup Redraw where 83 | Unchanged <> Unchanged = Unchanged 84 | _ <> _ = Redraw 85 | 86 | instance Monoid Redraw where 87 | mempty = Unchanged 88 | 89 | 90 | data Interrupt 91 | = Suspend (forall m. MonadIO m => Environment -> m ()) 92 | -- ^ Suspend the application and run the action, e. g. invoking an 93 | -- external process, then resume the application. 94 | 95 | | Halt 96 | -- ^ Shut down. 97 | 98 | 99 | 100 | -- | If the lookup returns @'Just' action@, then handle it with 101 | -- @'Continue' action'@, otherwise 'Skip' this event handler. 102 | dispatch :: (e -> Maybe a) -> e -> Next a 103 | dispatch f = maybe Skip Continue . f 104 | 105 | -- | Special case of 'dispatch' where actions are looked up from a map. 106 | dispatchMap :: Ord e => Map e a -> e -> Next a 107 | dispatchMap m = dispatch (`M.lookup` m) 108 | -------------------------------------------------------------------------------- /src/Vgrep/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | -- | Basic definitions for 'Key's, 'Mod'ifiers, and 'Chord's of 'Key's and 3 | -- 'Mod'ifiers. We can read key 'Chord's from "Graphics.Vty" 'Vty.EvKey' events 4 | -- using 'fromVty'. 5 | -- 6 | -- This module is intended for qualified import: 7 | -- 8 | -- > import qualified Vgrep.Key as Key 9 | -- 10 | -- We define our own 'Key' and 'Mod' types rather than using "Graphics.Vty"'s 11 | -- 'Vty.Key' and 'Vty.Modifier', because it simplifies parsing (of keys like 12 | -- 'Space' and 'Tab', which are represented as @' '@ and @'\t'@ in 13 | -- "Graphics.Vty"), and because a 'Set' of 'Mod's is simpler to check for 14 | -- equality than a list of 'Vty.Modifier's. 15 | module Vgrep.Key 16 | ( Chord (..) 17 | , Key (..) 18 | , Mod (..) 19 | , fromVty 20 | , key 21 | , withModifier 22 | )where 23 | 24 | import Control.Applicative 25 | import Data.Set (Set) 26 | import qualified Data.Set as S 27 | import GHC.Generics 28 | import qualified Graphics.Vty.Input.Events as Vty 29 | import Prelude hiding (Left, Right) 30 | 31 | 32 | -- | A chord of keys and modifiers pressed simultaneously. 33 | data Chord = Chord (Set Mod) Key 34 | deriving (Eq, Ord, Show, Generic) 35 | 36 | data Key 37 | = Char Char | Space 38 | | Esc | Backspace | Enter | Del | Tab 39 | | Left | Right | Up | Down 40 | | Home | End | PageUp | PageDown 41 | deriving (Eq, Ord, Show, Read, Generic) 42 | 43 | data Mod 44 | = Ctrl 45 | | Meta 46 | | Shift 47 | deriving (Eq, Ord, Show, Generic) 48 | 49 | 50 | -- | Reads the key and modifiers from an 'Vty.Event'. Non-key events and events 51 | -- with unknown keys are mapped to 'Nothing'. 52 | fromVty :: Vty.Event -> Maybe Chord 53 | fromVty = \case 54 | Vty.EvKey k ms -> liftA2 Chord (mapModifiers ms) (mapKey k) 55 | _otherwise -> Nothing 56 | 57 | mapModifiers :: [Vty.Modifier] -> Maybe (Set Mod) 58 | mapModifiers = Just . S.fromList . map go 59 | where 60 | go = \case 61 | Vty.MCtrl -> Ctrl 62 | Vty.MShift -> Shift 63 | Vty.MMeta -> Meta 64 | Vty.MAlt -> Meta 65 | 66 | mapKey :: Vty.Key -> Maybe Key 67 | mapKey = \case 68 | Vty.KChar ' ' -> Just Space 69 | Vty.KEsc -> Just Esc 70 | Vty.KBS -> Just Backspace 71 | Vty.KEnter -> Just Enter 72 | Vty.KDel -> Just Del 73 | Vty.KChar '\t' -> Just Tab 74 | Vty.KLeft -> Just Left 75 | Vty.KRight -> Just Right 76 | Vty.KUp -> Just Up 77 | Vty.KDown -> Just Down 78 | Vty.KHome -> Just Home 79 | Vty.KEnd -> Just End 80 | Vty.KPageUp -> Just PageUp 81 | Vty.KPageDown -> Just PageDown 82 | Vty.KChar c -> Just (Char c) 83 | _otherwise -> Nothing 84 | 85 | 86 | -- | Build a 'Chord' from a single 'Key' 87 | key :: Key -> Chord 88 | key = Chord S.empty 89 | 90 | -- | Add a 'Mod'ifier to a 'Chord' 91 | withModifier :: Chord -> Mod -> Chord 92 | withModifier (Chord ms k) m = Chord (S.insert m ms) k 93 | -------------------------------------------------------------------------------- /src/Vgrep/KeybindingMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Vgrep.KeybindingMap where 3 | 4 | import Data.Map.Strict (Map) 5 | import qualified Data.Map.Strict as M 6 | import Vgrep.Command 7 | import qualified Vgrep.Key as Key 8 | 9 | 10 | newtype KeybindingMap = KeybindingMap { unKeybindingMap :: Map Key.Chord Command } 11 | deriving (Show, Eq, Semigroup, Monoid) 12 | 13 | lookup :: Key.Chord -> KeybindingMap -> Maybe Command 14 | lookup chord (KeybindingMap m) = M.lookup chord m 15 | 16 | fromList :: [(Key.Chord, Command)] -> KeybindingMap 17 | fromList = KeybindingMap . M.fromList 18 | -------------------------------------------------------------------------------- /src/Vgrep/Parser.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Parser ( 2 | -- * Parsing @grep@ output 3 | parseGrepOutput 4 | , parseLine 5 | 6 | -- ** Re-export 7 | , FileLineReference 8 | ) where 9 | 10 | import Control.Applicative 11 | import Data.Attoparsec.Text 12 | import Data.Maybe 13 | import Data.Text hiding (takeWhile) 14 | import Prelude hiding (takeWhile) 15 | 16 | import Vgrep.Ansi (stripAnsi) 17 | import Vgrep.Ansi.Parser (attrChange, parseAnsi) 18 | import Vgrep.Results (File (..), FileLineReference (..), LineReference (..)) 19 | 20 | 21 | -- | Parses lines of 'Text', skipping lines that are not valid @grep@ 22 | -- output. 23 | parseGrepOutput :: [Text] -> [FileLineReference] 24 | parseGrepOutput = mapMaybe parseLine 25 | 26 | -- | Parses a line of @grep@ output. Returns 'Nothing' if the line cannot 27 | -- be parsed. 28 | -- 29 | -- The output should consist of a file name, line number and the content, 30 | -- separated by colons: 31 | -- 32 | -- >>> parseLine "path/to/file:123:foobar" 33 | -- Just (FileLineReference {_file = File {_fileName = "path/to/file"}, _lineReference = LineReference {_lineNumber = Just 123, _lineText = Text 6 "foobar"}}) 34 | -- 35 | -- Omitting the line number still produces valid output: 36 | -- 37 | -- >>> parseLine "path/to/file:foobar" 38 | -- Just (FileLineReference {_file = File {_fileName = "path/to/file"}, _lineReference = LineReference {_lineNumber = Nothing, _lineText = Text 6 "foobar"}}) 39 | -- 40 | -- However, an file name must be present: 41 | -- 42 | -- >>> parseLine "foobar" 43 | -- Nothing 44 | -- 45 | -- ANSI escape codes in the line text are parsed correctly: 46 | -- 47 | -- >>> parseLine "path/to/file:foo\ESC[31mbar\ESC[mbaz" 48 | -- Just (FileLineReference {_file = File {_fileName = "path/to/file"}, _lineReference = LineReference {_lineNumber = Nothing, _lineText = Cat 9 [Text 3 "foo",Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 3 "bar"),Text 3 "baz"]}}) 49 | -- 50 | parseLine :: Text -> Maybe FileLineReference 51 | parseLine line = case parseOnly lineParser line of 52 | Left _ -> Nothing 53 | Right result -> Just result 54 | 55 | lineParser :: Parser FileLineReference 56 | lineParser = do 57 | file <- takeWhile (/= ':') <* char ':' 58 | lineNumber <- optional (skipMany attrChange *> decimal <* skipMany attrChange <* char ':') 59 | result <- takeText 60 | pure FileLineReference 61 | { _file = File 62 | { _fileName = stripAnsi (parseAnsi file) } 63 | , _lineReference = LineReference 64 | { _lineNumber = lineNumber 65 | , _lineText = parseAnsi result } } 66 | -------------------------------------------------------------------------------- /src/Vgrep/Results.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Vgrep.Results 3 | ( File (..) 4 | , fileName 5 | 6 | , LineReference (..) 7 | , lineNumber 8 | , lineText 9 | 10 | , FileLineReference (..) 11 | , file 12 | , lineReference 13 | ) where 14 | 15 | import Lens.Micro.Platform 16 | import Data.Text (Text) 17 | 18 | import Vgrep.Ansi (AnsiFormatted) 19 | 20 | 21 | newtype File = File 22 | { _fileName :: Text 23 | } deriving (Eq, Show) 24 | 25 | makeLenses ''File 26 | 27 | data LineReference = LineReference 28 | { _lineNumber :: Maybe Int 29 | , _lineText :: AnsiFormatted 30 | } deriving (Eq, Show) 31 | 32 | makeLenses ''LineReference 33 | 34 | data FileLineReference = FileLineReference 35 | { _file :: File 36 | , _lineReference :: LineReference 37 | } deriving (Eq, Show) 38 | 39 | makeLenses ''FileLineReference 40 | -------------------------------------------------------------------------------- /src/Vgrep/System/Grep.hs: -------------------------------------------------------------------------------- 1 | -- | Utilities for invoking @grep@ 2 | {-# LANGUAGE Rank2Types #-} 3 | module Vgrep.System.Grep 4 | ( grep 5 | , grepForApp 6 | , recursiveGrep 7 | , grepVersion 8 | ) where 9 | 10 | import Control.Concurrent 11 | import Control.Monad 12 | import Control.Monad.IO.Class 13 | import Data.Maybe 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Pipes as P 17 | import qualified Pipes.Prelude as P 18 | import System.Environment (getArgs) 19 | import System.Exit 20 | import System.Process 21 | 22 | import Vgrep.Parser 23 | 24 | import System.IO 25 | 26 | -- | Like 'grep', but if the input is not prefixed with a file and line 27 | -- number, i. e. is not valid @grep -nH@ output, then adds @-nH@ (@-n@: 28 | -- with line number, @-H@: with file name) to the @grep@ command line 29 | -- arguments. 30 | grepForApp :: Producer Text IO () -> Producer Text IO () 31 | grepForApp input = do 32 | (firstInputLine, input') <- peek input 33 | when (isNothing firstInputLine) (lift exitFailure) 34 | case firstInputLine >>= parseLine of 35 | Just _line -> grep input' 36 | Nothing -> grepWithFileAndLineNumber input' 37 | 38 | grepWithFileAndLineNumber :: Producer Text IO () -> Producer Text IO () 39 | grepWithFileAndLineNumber input = do 40 | args <- liftIO getArgs 41 | grepPipe (withFileName : withLineNumber : args) input 42 | 43 | -- | Takes a 'Text' stream and runs it through a @grep@ process, returning 44 | -- a stream of results. The original command line arguments are passed to 45 | -- the process. 46 | grep :: Producer Text IO () -> Producer Text IO () 47 | grep input = do 48 | args <- liftIO getArgs 49 | grepPipe args input 50 | 51 | grepPipe :: [String] -> Producer Text IO () -> Producer Text IO () 52 | grepPipe args input = do 53 | (hIn, hOut) <- createGrepProcess (lineBuffered : colorized : args) 54 | _threadId <- liftIO . forkIO . runEffect $ input >-> textToHandle hIn 55 | streamResultsFrom hOut 56 | 57 | -- | Invokes @grep -nH -rI@ (@-n@: with line number, @-H@: with file name, 58 | -- @-r@: recursive, @-I@: ignore binary files) and returns the results as a 59 | -- stream. More arguments (e. g. pattern and directory) are taken from the 60 | -- command line. 61 | recursiveGrep :: Producer Text IO () 62 | recursiveGrep = do 63 | args <- lift getArgs 64 | let grepArgs = recursive 65 | : withFileName 66 | : withLineNumber 67 | : skipBinaryFiles 68 | : lineBuffered 69 | : colorized 70 | : args 71 | (_hIn, hOut) <- createGrepProcess grepArgs 72 | streamResultsFrom hOut 73 | 74 | grepVersion :: Producer Text IO () 75 | grepVersion = do 76 | (_, hOut) <- createGrepProcess [version] 77 | streamResultsFrom hOut 78 | 79 | recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered, colorized, version :: String 80 | recursive = "-r" 81 | withFileName = "-H" 82 | withLineNumber = "-n" 83 | skipBinaryFiles = "-I" 84 | lineBuffered = "--line-buffered" 85 | colorized = "--color=always" 86 | version = "--version" 87 | 88 | 89 | createGrepProcess :: MonadIO io => [String] -> io (Handle, Handle) 90 | createGrepProcess args = liftIO $ do 91 | (Just hIn, Just hOut, _hErr, _processHandle) <- createProcess 92 | (proc "grep" args) { std_in = CreatePipe, std_out = CreatePipe } 93 | hSetBuffering hIn LineBuffering 94 | hSetBuffering hOut LineBuffering 95 | pure (hIn, hOut) 96 | 97 | streamResultsFrom :: Handle -> Producer Text IO () 98 | streamResultsFrom handle = do 99 | (maybeFirstLine, grepOutput) <- peek (textFromHandle handle) 100 | when (isNothing maybeFirstLine) (lift exitFailure) 101 | grepOutput 102 | 103 | 104 | textFromHandle :: MonadIO m => Handle -> Producer' Text m () 105 | textFromHandle h = P.fromHandle h >-> P.map T.pack 106 | 107 | textToHandle :: MonadIO m => Handle -> Consumer' Text m () 108 | textToHandle h = P.map T.unpack >-> P.toHandle h 109 | 110 | peek :: Monad m => Producer a m r -> Producer a m (Maybe a, Producer a m r) 111 | peek producer = do 112 | eitherNext <- lift (next producer) 113 | pure $ case eitherNext of 114 | Left r -> (Nothing, pure r) 115 | Right (a, producer') -> (Just a, P.yield a >> producer') 116 | -------------------------------------------------------------------------------- /src/Vgrep/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Vgrep.Text ( 3 | -- * Utilities for rendering 'Text' 4 | -- | Tabs and other characters below ASCII 32 cause problems in 5 | -- "Graphics.Vty", so we expand them to readable characters, e.g. @\\r@ to 6 | -- @^13@. Tabs are expanded to the configured 'Vgrep.Environment._tabstop'. 7 | expandForDisplay 8 | , expandLineForDisplay 9 | , expandFormattedLine 10 | ) where 11 | 12 | import Control.Lens.Compat 13 | import Control.Monad.Reader.Class 14 | import Data.Char 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | 18 | import Vgrep.Ansi 19 | import Vgrep.Environment 20 | 21 | 22 | -- | Expand a list of lines 23 | expandForDisplay 24 | :: (Functor f, MonadReader Environment m) 25 | => f Text -> m (f Text) 26 | expandForDisplay inputLines = do 27 | tw <- tabWidth 28 | pure (fmap (expandText tw) inputLines) 29 | 30 | -- | Expand a single line 31 | expandLineForDisplay :: MonadReader Environment m => Text -> m Text 32 | expandLineForDisplay inputLine = do 33 | tw <- tabWidth 34 | pure (expandText tw inputLine) 35 | 36 | -- | Expand an ANSI formatted line 37 | expandFormattedLine :: MonadReader Environment m => Formatted a -> m (Formatted a) 38 | expandFormattedLine inputLine = do 39 | tw <- tabWidth 40 | pure (mapTextWithPos (expandTextAt tw . Position) inputLine) 41 | 42 | 43 | newtype TabWidth = TabWidth Int 44 | newtype Position = Position Int 45 | 46 | tabWidth :: MonadReader Environment m => m TabWidth 47 | tabWidth = view (config . tabstop . to TabWidth) 48 | 49 | expandText :: TabWidth -> Text -> Text 50 | expandText tw = expandTextAt tw (Position 0) 51 | 52 | expandTextAt :: TabWidth -> Position -> Text -> Text 53 | expandTextAt tw pos = 54 | T.pack . expandSpecialChars . expandTabs tw pos . T.unpack 55 | 56 | expandTabs :: TabWidth -> Position -> String -> String 57 | expandTabs (TabWidth tw) (Position p) = go p 58 | where go pos (c:cs) 59 | | c == '\t' = let shift = tw - (pos `mod` tw) 60 | in replicate shift ' ' ++ go (pos + shift) cs 61 | | otherwise = c : go (pos + 1) cs 62 | go _ [] = [] 63 | 64 | expandSpecialChars :: String -> String 65 | expandSpecialChars = \case 66 | c:cs | ord c < 32 -> ['^', chr (ord c + 64)] ++ expandSpecialChars cs 67 | | otherwise -> c : expandSpecialChars cs 68 | [] -> [] 69 | -------------------------------------------------------------------------------- /src/Vgrep/Type.hs: -------------------------------------------------------------------------------- 1 | -- | The 'VgrepT' monad transformer allows reading from the 'Environment' 2 | -- and changing the state of the 'Vgrep.App.App' or a 'Vgrep.Widget.Widget'. 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | module Vgrep.Type 12 | ( -- * The 'VgrepT' monad transformer 13 | VgrepT () 14 | , Vgrep 15 | 16 | , mkVgrepT 17 | , runVgrepT 18 | 19 | -- ** Modifying the environment 20 | , modifyEnvironment 21 | 22 | -- ** Utilities 23 | , vgrepBracket 24 | 25 | -- * Re-exports 26 | , lift 27 | , hoist 28 | , module Vgrep.Environment 29 | , module Export 30 | ) where 31 | 32 | import qualified Control.Exception as E 33 | import Control.Lens.Compat 34 | import Control.Monad.Identity 35 | import Control.Monad.Morph 36 | import Control.Monad.Reader 37 | import qualified Control.Monad.Reader as Export 38 | ( MonadReader 39 | , ask 40 | , local 41 | ) 42 | import Control.Monad.State.Extended 43 | import qualified Control.Monad.State.Extended as Export 44 | ( MonadState 45 | , get 46 | , modify 47 | , put 48 | ) 49 | import Lens.Micro.Mtl.Internal 50 | 51 | import Vgrep.Environment 52 | 53 | -- | The 'VgrepT' monad transformer is parameterized over the state @s@ of 54 | -- a 'Vgrep.Widget.Widget' or an 'Vgepr.App.App'. 55 | newtype VgrepT s m a = VgrepT (StateT s (StateT Environment m) a) 56 | deriving ( Functor 57 | , Applicative 58 | , Monad 59 | , MonadIO ) 60 | 61 | -- | 'VgrepT' can read from the 'Environment'. Modifications to the 62 | -- enviromnent are only possible globally (see 'modifyEnvironment'), the 63 | -- 'local' environment is pure. 64 | instance Monad m => MonadReader Environment (VgrepT s m) where 65 | ask = VgrepT (lift get) 66 | local f action = mkVgrepT $ \s env -> runVgrepT action s (f env) 67 | 68 | instance Monad m => MonadState s (VgrepT s m) where 69 | get = VgrepT get 70 | put = VgrepT . put 71 | 72 | instance MonadTrans (VgrepT s) where 73 | lift = VgrepT . lift . lift 74 | 75 | instance MFunctor (VgrepT s) where 76 | hoist f (VgrepT action) = VgrepT (hoist (hoist f) action) 77 | 78 | type instance Zoomed (VgrepT s m) = Zoomed (StateT s (StateT Environment m)) 79 | 80 | instance Monad m => Zoom (VgrepT s m) (VgrepT t m) s t where 81 | zoom l (VgrepT m) = VgrepT (zoom l m) 82 | 83 | -- | Lift a monadic action to 'VgrepT'. 84 | mkVgrepT 85 | :: Monad m 86 | => (s -> Environment -> m (a, s)) 87 | -> VgrepT s m a 88 | mkVgrepT action = 89 | let action' s env = fmap (, env) (action s env) 90 | in VgrepT (StateT (StateT . action')) 91 | 92 | -- | Pass an initial state and an 'Environment' and reduce a 'VgrepT' 93 | -- action to an action in the base monad. 94 | runVgrepT 95 | :: Monad m 96 | => VgrepT s m a 97 | -> s 98 | -> Environment 99 | -> m (a, s) 100 | runVgrepT (VgrepT action) s env = do 101 | ((a, s'), _env') <- runStateT (runStateT action s) env 102 | pure (a, s') 103 | 104 | type Vgrep s = VgrepT s Identity 105 | 106 | 107 | -- | A version of 'E.bracket' where the action is lifted to 'VgrepT'. 108 | vgrepBracket 109 | :: IO a 110 | -> (a -> IO c) 111 | -> (a -> VgrepT s IO b) 112 | -> VgrepT s IO b 113 | vgrepBracket before after action = mkVgrepT $ \s env -> 114 | let baseAction a = runVgrepT (action a) s env 115 | in E.bracket before after baseAction 116 | 117 | 118 | -- | The 'Environment' of 'VgrepT' is not stateful, however it can be 119 | -- modified globally. An example is resizing the application by changing 120 | -- the display bounds. 121 | modifyEnvironment :: Monad m => (Environment -> Environment) -> VgrepT s m () 122 | modifyEnvironment = VgrepT . lift . modify 123 | -------------------------------------------------------------------------------- /src/Vgrep/Widget.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Widget 2 | ( module Vgrep.Widget.Type 3 | ) where 4 | 5 | import Vgrep.Widget.Type 6 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/HorizontalSplit.hs: -------------------------------------------------------------------------------- 1 | -- | A split-view widget that displays two widgets side-by-side. 2 | module Vgrep.Widget.HorizontalSplit ( 3 | -- * Horizontal split view widget 4 | hSplitWidget 5 | , HSplitWidget 6 | 7 | -- ** Widget state 8 | , HSplit () 9 | , Focus (..) 10 | 11 | -- ** Widget actions 12 | , leftOnly 13 | , rightOnly 14 | , splitView 15 | , switchFocus 16 | 17 | -- ** Lenses 18 | , leftWidget 19 | , rightWidget 20 | , currentWidget 21 | , leftWidgetFocused 22 | , rightWidgetFocused 23 | ) where 24 | 25 | import Control.Applicative (liftA2) 26 | import Control.Lens.Compat 27 | import Graphics.Vty.Image 28 | 29 | import Vgrep.Environment 30 | import Vgrep.Event 31 | import Vgrep.Type 32 | import Vgrep.Widget.HorizontalSplit.Internal 33 | import Vgrep.Widget.Type 34 | 35 | 36 | type HSplitWidget s t = Widget (HSplit s t) 37 | 38 | -- | Compose two 'Widget's side-by-side 39 | -- 40 | -- * __Initial state__ 41 | -- 42 | -- Initially, the left widget is rendered full-screen. 43 | -- 44 | -- * __Drawing the Widgets__ 45 | -- 46 | -- Drawing is delegated to the child widgets in a local environment 47 | -- reduced to thir respective 'Viewport'. 48 | hSplitWidget 49 | :: Widget s 50 | -> Widget t 51 | -> HSplitWidget s t 52 | hSplitWidget left right = Widget 53 | { initialize = initHSplit left right 54 | , draw = drawWidgets left right } 55 | 56 | initHSplit :: Widget s -> Widget t -> HSplit s t 57 | initHSplit left right = HSplit 58 | { _leftWidget = initialize left 59 | , _rightWidget = initialize right 60 | , _layout = LeftOnly } 61 | 62 | 63 | -- | Display the left widget full-screen 64 | leftOnly :: Monad m => VgrepT (HSplit s t) m Redraw 65 | leftOnly = use layout >>= \case 66 | LeftOnly -> pure Unchanged 67 | _other -> assign layout LeftOnly >> pure Redraw 68 | 69 | -- | Display the right widget full-screen 70 | rightOnly :: Monad m => VgrepT (HSplit s t) m Redraw 71 | rightOnly = use layout >>= \case 72 | RightOnly -> pure Unchanged 73 | _other -> assign layout RightOnly >> pure Redraw 74 | 75 | -- | Display both widgets in a split view. 76 | splitView 77 | :: Monad m 78 | => Focus -- ^ Focus left or right area 79 | -> Rational -- ^ Left area width as fraction of overall width 80 | -> VgrepT (HSplit s t) m Redraw 81 | splitView focus ratio = assign layout (Split focus ratio) >> pure Redraw 82 | 83 | -- | Switch focus from left to right child widget and vice versa (only if 84 | -- the '_layout' is 'Split') 85 | switchFocus :: Monad m => VgrepT (HSplit s t) m Redraw 86 | switchFocus = use layout >>= \case 87 | Split focus ratio -> assign layout (switch focus ratio) >> pure Redraw 88 | _otherwise -> pure Unchanged 89 | where 90 | switch FocusLeft ratio = Split FocusRight (1 - ratio) 91 | switch FocusRight ratio = Split FocusLeft (1 - ratio) 92 | 93 | drawWidgets 94 | :: Monad m 95 | => Widget s 96 | -> Widget t 97 | -> VgrepT (HSplit s t) m Image 98 | drawWidgets left right = use layout >>= \case 99 | LeftOnly -> zoom leftWidget (draw left) 100 | RightOnly -> zoom rightWidget (draw right) 101 | Split _ ratio -> liftA2 (<|>) 102 | (runInLeftWidget ratio (draw left)) 103 | (runInRightWidget ratio (draw right)) 104 | 105 | runInLeftWidget 106 | :: Monad m 107 | => Rational 108 | -> VgrepT s m Image 109 | -> VgrepT (HSplit s t) m Image 110 | runInLeftWidget ratio action = 111 | let leftRegion = over viewportWidth $ \w -> 112 | ceiling (ratio * fromIntegral w) 113 | in zoom leftWidget (local leftRegion action) 114 | 115 | 116 | runInRightWidget 117 | :: Monad m 118 | => Rational 119 | -> VgrepT t m Image 120 | -> VgrepT (HSplit s t) m Image 121 | runInRightWidget ratio action = 122 | let rightRegion = over viewportWidth $ \w -> 123 | floor ((1-ratio) * fromIntegral w) 124 | in zoom rightWidget (local rightRegion action) 125 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/HorizontalSplit/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Vgrep.Widget.HorizontalSplit.Internal ( 3 | -- * Split-view widget state 4 | HSplit (..) 5 | , Layout (..) 6 | , Focus (..) 7 | 8 | -- ** Auto-generated lenses 9 | , leftWidget 10 | , rightWidget 11 | , layout 12 | 13 | -- ** Additional lenses 14 | , currentWidget 15 | , leftWidgetFocused 16 | , rightWidgetFocused 17 | 18 | -- ** Re-exports 19 | , (%) 20 | ) where 21 | 22 | import Control.Lens.Compat 23 | import Data.Ratio ((%)) 24 | 25 | 26 | -- $setup 27 | -- >>> :set -fno-warn-missing-fields 28 | 29 | -- | The internal state of the split-view widget. Tracks the state of both 30 | -- child widgets and the current layout. 31 | data HSplit s t = HSplit 32 | { _leftWidget :: s 33 | -- ^ State of the left widget 34 | 35 | , _rightWidget :: t 36 | -- ^ State of the right widget 37 | 38 | , _layout :: Layout 39 | -- ^ Current layout 40 | } 41 | 42 | data Focus = FocusLeft | FocusRight deriving (Eq) 43 | data Layout = LeftOnly | RightOnly | Split Focus Rational deriving (Eq) 44 | 45 | makeLenses ''HSplit 46 | 47 | 48 | -- | The currently focused child widget 49 | -- 50 | -- >>> view currentWidget $ HSplit { _leftWidget = "foo", _layout = LeftOnly } 51 | -- Left "foo" 52 | currentWidget :: Lens' (HSplit s t) (Either s t) 53 | currentWidget = lens getCurrentWidget setCurrentWidget 54 | where 55 | getCurrentWidget state = case view layout state of 56 | LeftOnly -> Left (view leftWidget state) 57 | Split FocusLeft _ -> Left (view leftWidget state) 58 | RightOnly -> Right (view rightWidget state) 59 | Split FocusRight _ -> Right (view rightWidget state) 60 | 61 | setCurrentWidget state newWidget = case (view layout state, newWidget) of 62 | (RightOnly, Left widgetL) -> set leftWidget widgetL state 63 | (Split FocusLeft _, Left widgetL) -> set leftWidget widgetL state 64 | (LeftOnly, Right widgetR) -> set rightWidget widgetR state 65 | (Split FocusRight _, Right widgetR) -> set rightWidget widgetR state 66 | (_, _ ) -> state 67 | 68 | -- | Traverses the left widget if focused 69 | -- 70 | -- >>> has leftWidgetFocused $ HSplit { _layout = LeftOnly } 71 | -- True 72 | -- 73 | -- >>> has leftWidgetFocused $ HSplit { _layout = RightOnly } 74 | -- False 75 | -- 76 | -- >>> has leftWidgetFocused $ HSplit { _layout = Split FocusLeft (1 % 2) } 77 | -- True 78 | leftWidgetFocused :: Traversal' (HSplit s t) s 79 | leftWidgetFocused = currentWidget . _Left 80 | 81 | -- | Traverses the right widget if focused 82 | -- 83 | -- >>> has rightWidgetFocused $ HSplit { _layout = RightOnly } 84 | -- True 85 | -- 86 | -- >>> has rightWidgetFocused $ HSplit { _layout = LeftOnly } 87 | -- False 88 | -- 89 | -- >>> has rightWidgetFocused $ HSplit { _layout = Split FocusRight (1 % 2) } 90 | -- True 91 | rightWidgetFocused :: Traversal' (HSplit s t) t 92 | rightWidgetFocused = currentWidget . _Right 93 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/Pager.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Vgrep.Widget.Pager ( 4 | -- * Pager widget 5 | pagerWidget 6 | , PagerWidget 7 | 8 | -- ** Internal state 9 | , Pager () 10 | 11 | -- ** Widget actions 12 | , moveToLine 13 | , scroll 14 | , scrollPage 15 | , scrollPageFraction 16 | , hScroll 17 | , replaceBufferContents 18 | ) where 19 | 20 | import Control.Applicative (liftA2) 21 | import Control.Lens.Compat 22 | import Data.Foldable 23 | import qualified Data.IntMap.Strict as Map 24 | import Data.Sequence (Seq, (><)) 25 | import qualified Data.Sequence as Seq 26 | import Data.Text (Text) 27 | import qualified Data.Text as T 28 | import Graphics.Vty.Attributes 29 | import Graphics.Vty.Image 30 | 31 | import Vgrep.Ansi 32 | import Vgrep.Environment 33 | import Vgrep.Event 34 | import Vgrep.Type 35 | import Vgrep.Widget.Pager.Internal 36 | import Vgrep.Widget.Type 37 | 38 | 39 | type PagerWidget = Widget Pager 40 | 41 | -- | Display lines of text with line numbers 42 | -- 43 | -- * __Initial state__ 44 | -- 45 | -- The pager is empty, i. e. no lines of text to display. 46 | -- 47 | -- * __Drawing the pager__ 48 | -- 49 | -- The lines of text are printed, starting at the current scroll 50 | -- position. If not enough lines are available, the scroll position is 51 | -- adjusted until either the screen is filled, or the first line is 52 | -- reached. Highlighted lines are displayed according to the config 53 | -- values 'normalHl' and 'lineNumbersHl' (default: bold). 54 | pagerWidget :: PagerWidget 55 | pagerWidget = Widget 56 | { initialize = initPager 57 | , draw = renderPager } 58 | 59 | initPager :: Pager 60 | initPager = Pager 61 | { _column = 0 62 | , _highlighted = Map.empty 63 | , _above = Seq.empty 64 | , _visible = Seq.empty } 65 | 66 | 67 | -- | Replace the currently displayed text. 68 | replaceBufferContents 69 | :: Monad m 70 | => Seq Text -- ^ Lines of text to display in the pager (starting with line 1) 71 | -> Map.IntMap AnsiFormatted -- ^ Line numbers and formatted text for highlighted lines 72 | -> VgrepT Pager m () 73 | replaceBufferContents newContent newHighlightedLines = put initPager 74 | { _visible = newContent 75 | , _highlighted = newHighlightedLines } 76 | 77 | -- | Scroll to the given line number. 78 | moveToLine :: Monad m => Int -> VgrepT Pager m Redraw 79 | moveToLine n = view viewportHeight >>= \height -> do 80 | setPosition (n - height `div` 2) 81 | pure Redraw 82 | 83 | -- | Scroll up or down one line. 84 | -- 85 | -- > scroll (-1) -- scroll one line up 86 | -- > scroll 1 -- scroll one line down 87 | scroll :: Monad m => Int -> VgrepT Pager m Redraw 88 | scroll n = do 89 | pos <- use position 90 | setPosition (pos + n) 91 | pure Redraw 92 | 93 | setPosition :: Monad m => Int -> VgrepT Pager m () 94 | setPosition n = view viewportHeight >>= \height -> do 95 | allLines <- liftA2 (+) (use (visible . to length)) (use (above . to length)) 96 | let newPosition = if 97 | | n < 0 || allLines < height -> 0 98 | | n > allLines - height -> allLines - height 99 | | otherwise -> n 100 | modify $ \pager@Pager{..} -> 101 | let (newAbove, newVisible) = Seq.splitAt newPosition (_above >< _visible) 102 | in pager 103 | { _above = newAbove 104 | , _visible = newVisible } 105 | 106 | -- | Scroll up or down one page. The first line on the current screen will 107 | -- be the last line on the scrolled screen and vice versa. 108 | -- 109 | -- > scrollPage (-1) -- scroll one page up 110 | -- > scrollPage 1 -- scroll one page down 111 | scrollPage :: Monad m => Int -> VgrepT Pager m Redraw 112 | scrollPage n = view viewportHeight >>= \height -> 113 | scroll (n * (height - 1)) 114 | -- gracefully leave one ^ line on the screen 115 | 116 | -- | Scroll up or down a fraction of a page. For integers, 117 | -- 'scrollPageFraction n == scrollPage n'. 118 | -- 119 | -- > scrollPageFraction (-1%2) -- scroll one half page up 120 | -- > scrollPageFraction (1%2) -- scroll one half page down 121 | -- > scrollPageFraction (fromRational 1) -- scroll one page down 122 | scrollPageFraction :: Monad m => Rational -> VgrepT Pager m Redraw 123 | scrollPageFraction a = view viewportHeight >>= \height -> 124 | scroll (round (a * (fromIntegral height - 1))) 125 | -- gracefully leave one ^ line on the screen 126 | 127 | -- | Horizontal scrolling. Increment is one 'tabstop'. 128 | -- 129 | -- > hScroll (-1) -- scroll one tabstop left 130 | -- > hScroll 1 -- scroll one tabstop right 131 | hScroll :: Monad m => Int -> VgrepT Pager m Redraw 132 | hScroll n = do 133 | tabWidth <- view (config . tabstop) 134 | modifying column $ \currentColumn -> 135 | let newColumn = currentColumn + n * tabWidth 136 | in if newColumn > 0 then newColumn else 0 137 | pure Redraw 138 | 139 | 140 | renderPager :: Monad m => VgrepT Pager m Image 141 | renderPager = do 142 | textColor <- view (config . colors . normal) 143 | textColorHl <- view (config . colors . normalHl) 144 | lineNumberColor <- view (config . colors . lineNumbers) 145 | lineNumberColorHl <- view (config . colors . lineNumbersHl) 146 | width <- view viewportWidth 147 | height <- view viewportHeight 148 | startPosition <- use position 149 | startColumn <- use (column . to fromIntegral) 150 | visibleLines <- use (visible . to (Seq.take height) . to toList) 151 | highlightedLines <- use highlighted 152 | 153 | let (renderedLineNumbers, renderedTextLines) 154 | = over both fold 155 | . unzip 156 | $ zipWith renderLine [startPosition+1..] visibleLines 157 | where 158 | renderLine :: Int -> Text -> (Image, Image) 159 | renderLine num txt = case Map.lookup num highlightedLines of 160 | Just formatted -> ( renderLineNumber lineNumberColorHl num 161 | , renderFormatted textColorHl formatted ) 162 | Nothing -> ( renderLineNumber lineNumberColor num 163 | , renderLineText textColor txt ) 164 | 165 | renderLineNumber :: Attr -> Int -> Image 166 | renderLineNumber attr 167 | = text' attr 168 | . (`T.snoc` ' ') 169 | . T.cons ' ' 170 | . T.pack 171 | . show 172 | 173 | renderLineText :: Attr -> Text -> Image 174 | renderLineText attr 175 | = text' attr 176 | . T.justifyLeft width ' ' 177 | . T.take width 178 | . T.cons ' ' 179 | . T.drop startColumn 180 | 181 | renderFormatted :: Attr -> AnsiFormatted -> Image 182 | renderFormatted attr 183 | = renderAnsi attr 184 | . padFormatted width ' ' 185 | . takeFormatted width 186 | . (bare " " <>) 187 | . dropFormatted startColumn 188 | 189 | 190 | pure (resizeWidth width (renderedLineNumbers <|> renderedTextLines)) 191 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/Pager/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Vgrep.Widget.Pager.Internal ( 3 | -- * Pager widget state 4 | Pager (..) 5 | 6 | -- * Lenses 7 | , position 8 | -- ** Auto-generated lenses 9 | , column 10 | , above 11 | , visible 12 | , highlighted 13 | ) where 14 | 15 | import Control.Lens.Compat 16 | import Data.IntMap.Strict (IntMap) 17 | import Data.Sequence (Seq) 18 | import Data.Text (Text) 19 | 20 | import Vgrep.Ansi 21 | 22 | 23 | -- | Keeps track of the lines of text to display, the current scroll 24 | -- positions, and the set of highlighted line numbers. 25 | data Pager = Pager 26 | { _column :: Int 27 | -- ^ The current column offset for horizontal scrolling 28 | 29 | , _highlighted :: IntMap AnsiFormatted 30 | -- ^ Set of line numbers that are highlighted (i.e. they contain matches) 31 | 32 | , _above :: Seq Text 33 | -- ^ Zipper: Lines above the screen 34 | 35 | , _visible :: Seq Text 36 | -- ^ Zipper: Lines on screen and below 37 | 38 | } deriving (Eq, Show) 39 | 40 | makeLenses ''Pager 41 | 42 | -- | The number of invisible lines above the screen 43 | position :: Getter Pager Int 44 | position = above . to length 45 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/Results.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | module Vgrep.Widget.Results ( 5 | -- * Results list widget 6 | resultsWidget 7 | , ResultsWidget 8 | 9 | -- ** Internal widget state 10 | , Results () 11 | 12 | -- ** Widget actions 13 | , feedResult 14 | , resizeToWindow 15 | , prevLine 16 | , nextLine 17 | , pageUp 18 | , pageDown 19 | 20 | -- ** Lenses 21 | , currentFileName 22 | , currentLineNumber 23 | , currentFileResults 24 | 25 | -- * Re-exports 26 | , module Vgrep.Results 27 | ) where 28 | 29 | import Control.Applicative 30 | import Control.Lens.Compat 31 | import Control.Monad.State.Extended 32 | import Data.Foldable 33 | import Data.Maybe 34 | import Data.Text (Text) 35 | import qualified Data.Text as T 36 | import Graphics.Vty.Attributes 37 | import Graphics.Vty.Image hiding ((<|>)) 38 | 39 | import Vgrep.Ansi 40 | import Vgrep.Environment 41 | import Vgrep.Event 42 | import Vgrep.Results 43 | import Vgrep.Type 44 | import Vgrep.Widget.Results.Internal as Internal 45 | import Vgrep.Widget.Type 46 | 47 | 48 | type ResultsWidget = Widget Results 49 | 50 | -- | The results widget displays a list of lines with line numbers, grouped 51 | -- by files. 52 | -- 53 | -- * __Initial state__ 54 | -- 55 | -- The initial buffer is empty and can be filled line by line using 56 | -- 'feedResult'. 57 | -- 58 | -- * __Drawing the results list__ 59 | -- 60 | -- Found matches are grouped by file name. Each file group has a header 61 | -- and a list of result lines with line numbers. The result lines can 62 | -- be selected with the cursor, the file group headers are skipped. 63 | -- When only part of a file group is shown at the top of the screen, 64 | -- the header is shown nevertheless. 65 | resultsWidget :: ResultsWidget 66 | resultsWidget = 67 | Widget { initialize = initResults 68 | , draw = renderResultList } 69 | 70 | initResults :: Results 71 | initResults = EmptyResults 72 | 73 | 74 | -- | Add a line to the results list. If the result is found in the same 75 | -- file as the current last result, it will be added to the same results 76 | -- group, otherwise a new group will be opened. 77 | feedResult :: Monad m => FileLineReference -> VgrepT Results m Redraw 78 | feedResult line = do 79 | modify (feed line) 80 | resizeToWindow 81 | 82 | -- | Move up/down one results page. File group headers will be skipped. 83 | pageUp, pageDown :: Monad m => VgrepT Results m () 84 | pageUp = do 85 | unlessS (isJust . moveUp) $ do 86 | modify (repeatedly (hideNext >=> showPrev)) 87 | void resizeToWindow 88 | modify (repeatedly moveUp) 89 | pageDown = do 90 | unlessS (isJust . moveDown) $ do 91 | modify (repeatedly hidePrev) 92 | void resizeToWindow 93 | modify (repeatedly moveDown) 94 | 95 | repeatedly :: (a -> Maybe a) -> a -> a 96 | repeatedly f = go 97 | where 98 | go x | Just x' <- f x = go x' 99 | | otherwise = x 100 | 101 | -- | Move up/down one results line. File group headers will be skipped. 102 | prevLine, nextLine :: Monad m => VgrepT Results m () 103 | prevLine = maybeModify tryPrevLine >> void resizeToWindow 104 | nextLine = maybeModify tryNextLine >> void resizeToWindow 105 | 106 | tryPrevLine, tryNextLine :: Results -> Maybe Results 107 | tryPrevLine buf = moveUp buf <|> (showPrev buf >>= tryPrevLine) 108 | tryNextLine buf = moveDown buf <|> (showNext buf >>= tryNextLine) 109 | 110 | maybeModify :: Monad m => (s -> Maybe s) -> VgrepT s m () 111 | maybeModify f = do 112 | s <- get 113 | case f s of 114 | Just s' -> put s' 115 | Nothing -> pure () 116 | 117 | 118 | renderResultList :: Monad m => VgrepT Results m Image 119 | renderResultList = do 120 | void resizeToWindow 121 | visibleLines <- use (to toLines) 122 | width <- view viewportWidth 123 | let render = renderLine width (lineNumberWidth visibleLines) 124 | renderedLines <- traverse render visibleLines 125 | pure (vertCat renderedLines) 126 | where lineNumberWidth 127 | = foldl' max 0 128 | . map (twoExtraSpaces . length . show) 129 | . mapMaybe displayLineNumber 130 | twoExtraSpaces = (+ 2) -- because line numbers are padded, 131 | -- see `justifyRight` below 132 | 133 | renderLine 134 | :: Monad m 135 | => Int 136 | -> Int 137 | -> DisplayLine 138 | -> VgrepT Results m Image 139 | renderLine width lineNumberWidth displayLine = do 140 | fileHeaderStyle <- view (config . colors . fileHeaders) 141 | lineNumberStyle <- view (config . colors . lineNumbers) 142 | resultLineStyle <- view (config . colors . normal) 143 | selectedStyle <- view (config . colors . selected) 144 | pure $ case displayLine of 145 | FileHeader (File f) 146 | -> renderFileHeader fileHeaderStyle f 147 | Line (LineReference n t) 148 | -> horizCat [ renderLineNumber lineNumberStyle n 149 | , renderLineText resultLineStyle t ] 150 | SelectedLine (LineReference n t) 151 | -> horizCat [ renderLineNumber lineNumberStyle n 152 | , renderLineText selectedStyle t ] 153 | where 154 | padWithSpace w = T.take (fromIntegral w) 155 | . T.justifyLeft (fromIntegral w) ' ' 156 | . T.cons ' ' 157 | justifyRight w s = T.justifyRight (fromIntegral w) ' ' (s <> " ") 158 | 159 | renderFileHeader :: Attr -> Text -> Image 160 | renderFileHeader attr = text' attr . padWithSpace width 161 | 162 | renderLineNumber :: Attr -> Maybe Int -> Image 163 | renderLineNumber attr = text' attr 164 | . justifyRight lineNumberWidth 165 | . maybe "" (T.pack . show) 166 | 167 | renderLineText :: Attr -> AnsiFormatted -> Image 168 | renderLineText attr txt 169 | = renderAnsi attr 170 | . takeFormatted (width - lineNumberWidth) 171 | . padFormatted (width - lineNumberWidth) ' ' 172 | $ cat [ bare " ", txt, bare (T.replicate width " ") ] 173 | 174 | resizeToWindow :: Monad m => VgrepT Results m Redraw 175 | resizeToWindow = do 176 | height <- view viewportHeight 177 | currentBuffer <- get 178 | case Internal.resize height currentBuffer of 179 | Just resizedBuffer -> put resizedBuffer >> pure Redraw 180 | Nothing -> pure Unchanged 181 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/Results/Internal.hs: -------------------------------------------------------------------------------- 1 | module Vgrep.Widget.Results.Internal ( 2 | -- * Results widget state 3 | Results (..) 4 | 5 | -- * Lenses 6 | , currentFileName 7 | , currentLineNumber 8 | , currentFileResults 9 | 10 | -- * Actions 11 | -- | In general, actions return @'Just' newResults@ if the buffer has 12 | -- changed, and @'Nothing'@ otherwise. This way it is easy to recognize 13 | -- whether or not a 'Vgrep.Event.Redraw' is necessary. 14 | , feed 15 | , showPrev, showNext 16 | , hidePrev, hideNext 17 | , moveUp, moveDown 18 | , resize 19 | 20 | -- * Utilities for displaying 21 | , DisplayLine(..) 22 | , toLines 23 | , displayLineNumber 24 | ) where 25 | 26 | import Control.Applicative 27 | import Control.Lens.Compat 28 | import Data.Foldable 29 | import Data.Function 30 | import Data.IntMap.Strict (IntMap) 31 | import qualified Data.IntMap.Strict as Map 32 | import Data.List (groupBy) 33 | import Data.Maybe 34 | import Data.Monoid 35 | import Data.Sequence 36 | ( Seq 37 | , ViewL (..) 38 | , ViewR (..) 39 | , viewl 40 | , viewr 41 | , (<|) 42 | , (|>) 43 | ) 44 | import qualified Data.Sequence as S 45 | import Data.Text (Text) 46 | import Prelude hiding (reverse) 47 | 48 | import Vgrep.Ansi (AnsiFormatted) 49 | import Vgrep.Results 50 | 51 | 52 | -- | Results widget state 53 | data Results 54 | = EmptyResults 55 | -- ^ The results list is empty 56 | 57 | | Results 58 | !(Seq FileLineReference) -- above screen (reversed) 59 | !(Seq FileLineReference) -- top of screen (reversed) 60 | !FileLineReference -- currently selected 61 | !(Seq FileLineReference) -- bottom of screen 62 | !(Seq FileLineReference) -- below screen 63 | -- ^ The structure of the Results buffer is a double Zipper: 64 | -- 65 | -- * lines above the current screen 66 | -- * lines on screen above the current item 67 | -- * the current item 68 | -- * lines on screen below the current item 69 | -- * lines below the current screen 70 | 71 | deriving (Eq, Show) 72 | 73 | 74 | -- | Append a line to the 'Results'. The line is appended below the visible 75 | -- screen, so use 'showNext' to make it visible. 76 | feed :: FileLineReference -> Results -> Results 77 | feed l = \case 78 | EmptyResults -> Results empty empty l empty empty 79 | Results as bs c ds es -> Results as bs c ds (es |> l) 80 | 81 | 82 | -- | Reverse the 'Results' 83 | reverse :: Results -> Results 84 | reverse = \case 85 | Results as bs c ds es -> Results es ds c bs as 86 | EmptyResults -> EmptyResults 87 | 88 | -- | Show one more item at the bottom of the screen if available. 89 | showNext :: Results -> Maybe Results 90 | showNext = \case 91 | Results as bs c ds es -> do e :< es' <- Just (viewl es) 92 | Just (Results as bs c (ds |> e) es') 93 | EmptyResults -> Nothing 94 | 95 | -- | Show one more item at the top of the screen if available. 96 | showPrev :: Results -> Maybe Results 97 | showPrev = fmap reverse . showNext . reverse 98 | 99 | -- | Remove the last item from the bottom of the screen and prepend it to 100 | -- the invisible items below. 101 | hideNext :: Results -> Maybe Results 102 | hideNext = \case 103 | Results as bs c ds es -> do ds' :> d <- Just (viewr ds) 104 | Just (Results as bs c ds' (d <| es)) 105 | EmptyResults -> Nothing 106 | 107 | -- | Remove the first item from the top of the screen and append it to the 108 | -- invisible items above. 109 | hidePrev :: Results -> Maybe Results 110 | hidePrev = fmap reverse . hideNext . reverse 111 | 112 | -- | Move the cursor one item down. 113 | moveDown :: Results -> Maybe Results 114 | moveDown = \case 115 | Results as bs c ds es -> do d :< ds' <- Just (viewl ds) 116 | Just (Results as (c <| bs) d ds' es) 117 | EmptyResults -> Nothing 118 | 119 | -- | Move the cursor one item up. 120 | moveUp :: Results -> Maybe Results 121 | moveUp = fmap reverse . moveDown . reverse 122 | 123 | -- | Adjust the number of on-screen items to the given height: 124 | -- 125 | -- * If the current list is too long for the new height, take items from 126 | -- the top until the current item is topmost, then from the bottom. 127 | -- * If the current list is too short for the new height, add items below 128 | -- until the buffer is empty, then above. 129 | resize 130 | :: Int -- ^ the new height 131 | -> Results 132 | -> Maybe Results -- ^ @'Nothing'@ if the height has not changed, 133 | -- @'Just' newResults@ otherwise 134 | resize height buffer 135 | | visibleHeight buffer < height - 1 = Just (doResize buffer) 136 | | visibleHeight buffer > height = Just (doResize buffer) 137 | | otherwise = Nothing 138 | where 139 | doResize buf 140 | -- FIXME we need some kind of bias 141 | -- to avoid running into an infinite 142 | -- loop, but this leaves some nasty 143 | -- artifacts when scrolling over the 144 | -- last line. -----------------v 145 | | visibleHeight buf < height - 1 146 | = maybe buf doResize (showNext buf <|> showPrev buf) 147 | 148 | | visibleHeight buf > height 149 | = maybe buf doResize (hidePrev buf <|> hideNext buf) 150 | 151 | | otherwise 152 | = buf 153 | 154 | visibleHeight :: Results -> Int 155 | visibleHeight = length . toLines 156 | 157 | 158 | -- | Ad-hoc data structure to render the (visible) 'Results' as list of 159 | -- lines. 160 | data DisplayLine = FileHeader File 161 | | Line LineReference 162 | | SelectedLine LineReference 163 | deriving (Eq) 164 | 165 | -- | Converts the visible 'Results' to a list of 'DisplayLine's. Each item 166 | -- in the returned list corresponds to a line on the screen. 167 | -- 168 | -- Each group of 'Line's that points to the same file is prepended with 169 | -- a 'FileHeader'. The item below the cursor becomes a 'SelectedLine'. 170 | toLines :: Results -> [DisplayLine] 171 | toLines EmptyResults = [] 172 | toLines (Results _ bs c ds _) = linesBefore <> selected c <> linesAfter 173 | 174 | where 175 | linesBefore = case viewl bs of 176 | b :< _ | b `pointsToSameFile` c -> go (S.reverse bs) 177 | _otherwise -> go (S.reverse bs) <> header c 178 | 179 | linesAfter = case viewl ds of 180 | d :< _ | c `pointsToSameFile` d -> drop 1 (go ds) 181 | _otherwise -> go ds 182 | 183 | go refs = do 184 | fileResults <- groupBy pointsToSameFile (toList refs) 185 | header (head fileResults) <> fmap (Line . view lineReference) fileResults 186 | 187 | header = pure . FileHeader . view file 188 | selected = pure . SelectedLine . view lineReference 189 | pointsToSameFile = (==) `on` view file 190 | 191 | -- | The line number of a 'DisplayLine'. 'Nothing' for 'FileHeader's. 192 | displayLineNumber :: DisplayLine -> Maybe Int 193 | displayLineNumber = \case 194 | FileHeader _ -> Nothing 195 | Line (LineReference n _) -> n 196 | SelectedLine (LineReference n _) -> n 197 | 198 | 199 | -- | The file name of the currently selected item 200 | currentFileName :: Getter Results (Maybe Text) 201 | currentFileName = 202 | to (preview (to current . _Just . file . fileName)) 203 | 204 | -- | The line number of the currently selected item 205 | currentLineNumber :: Getter Results (Maybe Int) 206 | currentLineNumber = 207 | to (preview (to current . _Just . lineReference . lineNumber . _Just)) 208 | 209 | current :: Results -> Maybe FileLineReference 210 | current = \case 211 | Results _ _ c _ _ -> Just c 212 | EmptyResults -> Nothing 213 | 214 | -- | The line numbers with matches in the file of the currentliy selected 215 | -- item 216 | currentFileResults :: Getter Results (IntMap AnsiFormatted) 217 | currentFileResults = 218 | to (Map.fromList . lineReferencesInCurrentFile) 219 | where 220 | lineReferencesInCurrentFile = do 221 | let sameFileAs = (==) `on` view file 222 | inCurrentFile <- sameFileAs . fromJust . current 223 | results <- map (view lineReference) . filter inCurrentFile . bufferToList 224 | pure [ (ln, txt) | LineReference (Just ln) txt <- results ] 225 | 226 | bufferToList :: Results -> [FileLineReference] 227 | bufferToList = \case 228 | EmptyResults -> [] 229 | Results as bs c ds es -> toList (as <> bs <> pure c <> ds <> es) 230 | -------------------------------------------------------------------------------- /src/Vgrep/Widget/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module Vgrep.Widget.Type 3 | ( Widget (..) 4 | 5 | -- ** Re-exports from "Vgrep.Event" 6 | , Redraw (..) 7 | , Next (..) 8 | ) where 9 | 10 | import Graphics.Vty.Image (Image) 11 | 12 | import Vgrep.Event (Next (..), Redraw (..)) 13 | import Vgrep.Type 14 | 15 | -- | A 'Widget' is a unit that is displayed on the screen. It is associated 16 | -- with a mutable state @s@. It provides an event handler with default 17 | -- keybindings and can generate a renderable 'Image'. 18 | -- 19 | -- Widget modules should provide a 'Widget' instance and additionally a 20 | -- collection of actions that can be invoked by external event handlers: 21 | -- 22 | -- @ 23 | -- widgetAction :: 'VgrepT' s m 'Redraw' 24 | -- @ 25 | data Widget s = Widget 26 | { initialize :: s 27 | -- ^ The initial state of the widget 28 | 29 | , draw :: forall m. Monad m => VgrepT s m Image 30 | -- ^ Generate a renderable 'Image' from the widget state. The state can 31 | -- be modified (e. g. for resizing). 32 | } 33 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-17.0 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | # We want a recent version of stylish-haskell. 13 | # This is olny for tooling, so does not affect 14 | # dependency management. 15 | - stylish-haskell-0.6.1.0 16 | 17 | # Override default flag values for local packages and extra-deps 18 | flags: {} 19 | 20 | # Extra package databases containing global packages 21 | extra-package-dbs: [] 22 | 23 | # Control whether we use the GHC we find on the path 24 | # system-ghc: true 25 | 26 | # Require a specific version of stack, using version ranges 27 | # require-stack-version: -any # Default 28 | # require-stack-version: >= 1.0.0 29 | 30 | # Override the architecture used by stack, especially useful on Windows 31 | # arch: i386 32 | # arch: x86_64 33 | 34 | # Extra directories used by stack for building 35 | # extra-include-dirs: [/path/to/dir] 36 | # extra-lib-dirs: [/path/to/dir] 37 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: stylish-haskell-0.6.1.0@sha256:7093bb2bf407cba89d4a03f4573b24048cf28583ce1a82c3ecc5fb09a1f7fef6,4216 9 | pantry-tree: 10 | size: 2370 11 | sha256: 4c4354acda5e1622fc118ebb8403a355e6680b10d01e111089c2e2d34c65e2af 12 | original: 13 | hackage: stylish-haskell-0.6.1.0 14 | snapshots: 15 | - completed: 16 | size: 563100 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/0.yaml 18 | sha256: e93a85871577ea3423d5f3454b2b6bd37c2c2123c79faf511dfb64f5b49a9f8b 19 | original: lts-17.0 20 | -------------------------------------------------------------------------------- /test/Data/Text/Testable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Data.Text.Testable ( module Data.Text ) where 3 | 4 | import Data.Text 5 | import Test.Tasty.QuickCheck 6 | 7 | instance Arbitrary Text where 8 | arbitrary = fmap pack arbitrary 9 | shrink = fmap pack . shrink . unpack 10 | -------------------------------------------------------------------------------- /test/Doctest.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = 5 | let extensions = 6 | [ "-XLambdaCase" 7 | , "-XMultiWayIf" 8 | , "-XOverloadedStrings" ] 9 | sourceFolders = 10 | [ "src" 11 | , "app" ] 12 | in doctest (extensions ++ sourceFolders) 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | 3 | import qualified Test.Vgrep.Widget as Widget 4 | 5 | main :: IO () 6 | main = defaultMain $ 7 | testGroup "Unit tests" [ Widget.test ] 8 | -------------------------------------------------------------------------------- /test/Test/Case.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | module Test.Case ( 9 | TestCase (..) 10 | , runTestCase 11 | , runTestCases 12 | 13 | , (~~) 14 | 15 | , testPropertyVgrep 16 | , monadicVgrep 17 | 18 | , module Vgrep.Type 19 | , TestTree () 20 | ) where 21 | 22 | import Control.Lens.Compat 23 | import Control.Monad 24 | import Data.Functor.Identity 25 | import Test.QuickCheck.Monadic 26 | import Test.Tasty 27 | import Test.Tasty.QuickCheck 28 | 29 | import Vgrep.Environment.Testable 30 | import Vgrep.Type 31 | 32 | data TestCase 33 | = forall s a prop. (Arbitrary s, Show s, Testable prop) 34 | => TestProperty 35 | { description :: TestName 36 | , testData :: Gen (s, Environment) 37 | , testCase :: PropertyM (Vgrep s) a 38 | , assertion :: a -> PropertyM (Vgrep s) prop } 39 | | forall s a r. (Arbitrary s, Show s, Eq r, Show r) 40 | => TestInvariant 41 | { description :: TestName 42 | , testData :: Gen (s, Environment) 43 | , testCase :: PropertyM (Vgrep s) a 44 | , invariant :: Getter s r } 45 | 46 | 47 | runTestCase :: TestCase -> TestTree 48 | runTestCase = \case 49 | TestProperty {..} -> testProperty description $ do 50 | (initialState, initialEnv) <- testData 51 | pure . monadic (`runVgrepForTest` (initialState, initialEnv)) . void $ do 52 | monitor (counterexample (show initialState)) 53 | monitor (counterexample (show initialEnv)) 54 | params <- testCase 55 | stop =<< assertion params 56 | TestInvariant {..} -> testProperty description $ do 57 | (initialState, initialEnv) <- testData 58 | pure . monadic (`runVgrepForTest` (initialState, initialEnv)) . void $ do 59 | monitor (counterexample (show initialState)) 60 | monitor (counterexample (show initialEnv)) 61 | invariantBefore <- use invariant 62 | void testCase 63 | invariantAfter <- use invariant 64 | stop (invariantAfter === invariantBefore) 65 | 66 | 67 | runTestCases :: TestName -> [TestCase] -> TestTree 68 | runTestCases name cases = testGroup name (map runTestCase cases) 69 | 70 | 71 | instance Monad m => MonadState s (PropertyM (VgrepT s m)) where 72 | get = run get 73 | put = run . put 74 | 75 | instance Monad m => MonadReader Environment (PropertyM (VgrepT s m)) where 76 | ask = run ask 77 | local f action = MkPropertyM $ \k -> fmap (local f) (unPropertyM action k) 78 | 79 | 80 | runVgrepForTest 81 | :: Vgrep s a 82 | -> (s, Environment) 83 | -> a 84 | runVgrepForTest action (s, env) = fst (runIdentity (runVgrepT action s env)) 85 | 86 | monadicVgrep 87 | :: (Arbitrary s, Testable a) 88 | => PropertyM (Vgrep s) a 89 | -> Gen Property 90 | monadicVgrep testcase = do 91 | initialState <- arbitrary 92 | initialEnv <- arbitrary 93 | pure (monadic (`runVgrepForTest` (initialState, initialEnv)) (fmap property testcase)) 94 | 95 | testPropertyVgrep 96 | :: (Arbitrary s, Testable a) 97 | => TestName 98 | -> PropertyM (Vgrep s) a 99 | -> TestTree 100 | testPropertyVgrep name prop = testProperty name (monadicVgrep prop) 101 | 102 | infix 4 ~~ 103 | (~~) 104 | :: (Eq a, Show a) 105 | => Getter s a 106 | -> Getter s a 107 | -> PropertyM (Vgrep s) Property 108 | prop1 ~~ prop2 = do 109 | p1 <- use prop1 110 | p2 <- use prop2 111 | pure (p1 === p2) 112 | -------------------------------------------------------------------------------- /test/Test/Vgrep/Widget.hs: -------------------------------------------------------------------------------- 1 | module Test.Vgrep.Widget (test) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Test.Vgrep.Widget.Pager as Pager 6 | import qualified Test.Vgrep.Widget.Results as Results 7 | 8 | test :: TestTree 9 | test = testGroup "Widgets" 10 | [ Pager.test 11 | , Results.test ] 12 | -------------------------------------------------------------------------------- /test/Test/Vgrep/Widget/Pager.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Test.Vgrep.Widget.Pager (test) where 4 | 5 | import Control.Applicative 6 | import Control.Lens.Compat 7 | import Control.Monad 8 | import qualified Data.Sequence as S 9 | import Data.Text.Testable () 10 | import qualified Data.Text.Testable as T 11 | import Test.Case 12 | import Test.QuickCheck as Q 13 | import Test.QuickCheck.Monadic as Q 14 | 15 | import Vgrep.Widget.Pager.Testable 16 | 17 | 18 | test :: TestTree 19 | test = runTestCases "Pager widget" 20 | [ TestInvariant 21 | { description = "Scrolling up and down leaves pager invariant" 22 | , testData = arbitrary `suchThat` (not . atTop) 23 | `suchThat` coversScreen 24 | , testCase = run (void (scroll (-1) >> scroll 1)) 25 | , invariant = id 26 | } 27 | , TestProperty 28 | { description = "Scrolling n pages at once is the same as scrolling n times one page" 29 | , testData = arbitrary 30 | , testCase = do 31 | n <- pick (arbitrary `suchThat` (/= 0)) 32 | initialState <- get 33 | run (void (scrollPage n)) 34 | nPagesAtOnce <- get 35 | put initialState 36 | replicateM_ (abs n) (run (scrollPage (signum n))) 37 | nTimesOnePage <- get 38 | pure (nPagesAtOnce, nTimesOnePage) 39 | , assertion = \(nPagesAtOnce, nTimesOnePage) -> 40 | pure (nPagesAtOnce === nTimesOnePage) 41 | } 42 | , TestProperty 43 | { description = "Scrolling by integral page fractions is the same as scrolling entire pages" 44 | , testData = arbitrary 45 | , testCase = do 46 | n <- pick (arbitrary `suchThat` (/= 0)) 47 | initialState <- get 48 | run (void (scrollPageFraction (fromIntegral n))) 49 | scrollNFractionalPages <- get 50 | put initialState 51 | run (void (scrollPage n)) 52 | scrollNPages <- get 53 | pure (scrollNFractionalPages, scrollNPages) 54 | , assertion = \(scrollNFractionalPages, scrollNPages) -> 55 | pure (scrollNFractionalPages === scrollNPages) 56 | } 57 | , TestInvariant 58 | { description = "Scrolling right and left leaves pager invariant" 59 | , testData = arbitrary 60 | , testCase = run (void (hScroll 1 >> hScroll (-1))) 61 | , invariant = id 62 | } 63 | , TestProperty 64 | { description = "MoveToLine displays the line on screen" 65 | , testData = arbitrary `suchThat` (not . emptyPager) 66 | , testCase = do 67 | numLines <- liftA2 (+) (use (above . to length)) (use (visible . to length)) 68 | line <- pick ( arbitrary `suchThat` (> 0) 69 | `suchThat` (<= numLines) ) 70 | run (void (moveToLine line)) 71 | pure line 72 | , assertion = \line -> do 73 | pos <- use position 74 | let posOnScreen = line - pos 75 | height <- view viewportHeight 76 | pure $ counterexample 77 | ("Failed: 0 <= " ++ show posOnScreen ++ " <= " ++ show height) 78 | (posOnScreen >= 0 .&&. posOnScreen <= height) 79 | } 80 | , TestProperty 81 | { description = "Scrolling stays within bounds" 82 | , testData = arbitrary `suchThat` coversScreen 83 | , testCase = do 84 | amount <- pick (scale (*10) arbitrary) 85 | run (void (scroll amount)) 86 | , assertion = const $ do 87 | pos <- use position 88 | linesVisible <- use (visible . to length) 89 | height <- view viewportHeight 90 | pure (pos >= 0 .&&. linesVisible >= height) 91 | } 92 | , TestProperty 93 | { description = "After replaceBufferContents the new content is visible" 94 | , testData = arbitrary 95 | , testCase = do 96 | newContent <- pick (fmap (S.fromList . map T.pack) arbitrary) 97 | run (replaceBufferContents newContent mempty) 98 | pure newContent 99 | , assertion = \expectedContent -> do 100 | actualContent <- use visible 101 | pure (actualContent === expectedContent) 102 | } 103 | ] 104 | 105 | 106 | emptyPager :: (Pager, Environment) -> Bool 107 | emptyPager (pager, _env) = view (visible . to length) pager == 0 108 | && view (above . to length) pager == 0 109 | 110 | coversScreen :: (Pager, Environment) -> Bool 111 | coversScreen (pager, env) = length (view visible pager) >= view viewportHeight env 112 | 113 | atTop :: (Pager, Environment) -> Bool 114 | atTop (pager, _env) = view position pager == 0 115 | -------------------------------------------------------------------------------- /test/Test/Vgrep/Widget/Results.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Test.Vgrep.Widget.Results (test) where 4 | 5 | import Control.Lens.Compat (Getter, over, to, view, (<&>), _1) 6 | import Control.Monad (void) 7 | import Data.Map.Strict ((!)) 8 | import qualified Data.Map.Strict as Map 9 | import Data.Sequence (Seq, ViewR (..)) 10 | import qualified Data.Sequence as Seq 11 | import Test.Case 12 | import Test.QuickCheck 13 | import Test.QuickCheck.Monadic 14 | 15 | import Vgrep.Widget.Results.Testable 16 | 17 | test :: TestTree 18 | test = runTestCases "Results widget" 19 | [ TestInvariant 20 | { description = "Scrolling one line down and up keeps selected line" 21 | , testData = arbitrary `suchThat` (not . lastLine) 22 | , testCase = run (nextLine >> prevLine) 23 | , invariant = selectedLine 24 | } 25 | , TestInvariant 26 | { description = "Scrolling one page down and up keeps selected line" 27 | , testData = fmap moveToLastLineOnScreen arbitrary 28 | `suchThat` \(results, env) -> linesBelowCurrent (> screenHeight env) results 29 | , testCase = run (pageDown >> pageUp) 30 | , invariant = selectedLine 31 | } 32 | , TestProperty 33 | { description = "Scrolling one page down jumps to end of screen" 34 | , testData = arbitrary 35 | , testCase = run pageDown 36 | , assertion = const $ get <&> \case 37 | EmptyResults -> True 38 | Results _ _ _ ds _ -> null ds 39 | } 40 | , TestProperty 41 | { description = "Scrolling one page up jumps to start of screen" 42 | , testData = arbitrary 43 | , testCase = run pageUp 44 | , assertion = const $ get <&> \case 45 | EmptyResults -> True 46 | Results _ bs _ _ _ -> null bs 47 | } 48 | , TestProperty 49 | { description = "Number of lines on screen is bounded by screen height after resizing" 50 | , testData = arbitrary 51 | , testCase = run resizeToWindow 52 | , assertion = const assertWidgetFitsOnScreen 53 | } 54 | , TestProperty 55 | { description = "Number of lines on screen is bounded by screen height after each action" 56 | , testData = arbitrary 57 | , testCase = do 58 | run (void resizeToWindow) 59 | -- ^ Precondition: widget is resized to display height 60 | run =<< arbitraryAction 61 | , assertion = const assertWidgetFitsOnScreen 62 | } 63 | , TestInvariant 64 | { description = "Results do not change order" 65 | , testData = arbitrary 66 | , testCase = run =<< arbitraryAction 67 | , invariant = resultsAsList 68 | } 69 | ] 70 | 71 | selectedLine :: Getter Results (Maybe FileLineReference) 72 | selectedLine = to $ \case 73 | EmptyResults -> Nothing 74 | Results _ _ c _ _ -> Just c 75 | 76 | linesBelowCurrent :: (Int -> Bool) -> Results -> Bool 77 | linesBelowCurrent p = \case 78 | EmptyResults -> p 0 79 | Results _ _ _ ds es -> p (length ds + length es) 80 | 81 | screenHeight :: Environment -> Int 82 | screenHeight = view viewportHeight 83 | 84 | moveToLastLineOnScreen :: (Results, Environment) -> (Results, Environment) 85 | moveToLastLineOnScreen = over _1 $ \case 86 | EmptyResults -> EmptyResults 87 | Results as bs c ds es -> case Seq.viewr ds of 88 | EmptyR -> Results as bs c ds es 89 | ds' :> d -> Results as (Seq.reverse ds' <> pure c <> bs) d Seq.empty es 90 | 91 | lastLine :: (Results, Environment) -> Bool 92 | lastLine (results, _env) = case results of 93 | EmptyResults -> True 94 | Results _ _ _ ds es -> null ds && null es 95 | 96 | resultsAsList :: Getter Results (Seq FileLineReference) 97 | resultsAsList = to $ \case 98 | EmptyResults -> mempty 99 | Results as bs c ds es -> mconcat 100 | [ Seq.reverse as, Seq.reverse bs, pure c, ds, es ] 101 | 102 | arbitraryAction :: Monad m => PropertyM m (Vgrep Results ()) 103 | arbitraryAction = do 104 | let actions = Map.fromList 105 | [ ("pageUp", pageUp) 106 | , ("pageDown", pageDown) 107 | , ("prevLine", prevLine) 108 | , ("nextLine", nextLine) ] 109 | actionName <- pick (elements ["pageUp", "pageDown", "prevLine", "nextLine"]) 110 | pure (actions ! actionName) 111 | 112 | assertWidgetFitsOnScreen 113 | :: (MonadState Results m, MonadReader Environment m) 114 | => m Property 115 | assertWidgetFitsOnScreen = do 116 | height <- view viewportHeight 117 | linesOnScreen <- numberOfLinesOnScreen 118 | pure $ counterexample 119 | (show linesOnScreen ++ " > " ++ show height) 120 | (linesOnScreen <= height) 121 | 122 | numberOfLinesOnScreen :: MonadState Results m => m Int 123 | numberOfLinesOnScreen = get <&> \case 124 | EmptyResults -> 0 125 | Results _ bs c ds _ -> length (mconcat [bs, pure c, ds]) 126 | -------------------------------------------------------------------------------- /test/Vgrep/Environment/Testable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Vgrep.Environment.Testable 3 | ( module Vgrep.Environment 4 | ) where 5 | 6 | import Test.QuickCheck 7 | 8 | import Vgrep.Environment 9 | 10 | 11 | instance Arbitrary Environment where 12 | arbitrary = do 13 | width <- arbitrary `suchThat` (> 0) -- FIXME tweak numbers 14 | height <- arbitrary `suchThat` (> 0) -- FIXME tweak numbers 15 | pure Env 16 | { _viewport = Viewport width height 17 | , _config = defaultConfig } 18 | -------------------------------------------------------------------------------- /test/Vgrep/Widget/Pager/Testable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Vgrep.Widget.Pager.Testable 3 | ( module Vgrep.Widget.Pager 4 | , module Vgrep.Widget.Pager.Internal 5 | ) where 6 | 7 | import Data.Sequence as Seq (fromList) 8 | import Data.Text.Testable () 9 | import Test.QuickCheck 10 | 11 | import Vgrep.Widget.Pager 12 | import Vgrep.Widget.Pager.Internal 13 | 14 | instance Arbitrary Pager where 15 | arbitrary = do 16 | linesOfText <- arbitrary 17 | pos <- case linesOfText of 18 | [] -> pure 0 19 | _ -> choose (0, length linesOfText - 1) 20 | pure Pager 21 | { _column = 0 22 | , _highlighted = mempty 23 | , _above = Seq.fromList (take pos linesOfText) 24 | , _visible = Seq.fromList (drop pos linesOfText) } 25 | -------------------------------------------------------------------------------- /test/Vgrep/Widget/Results/Testable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Vgrep.Widget.Results.Testable 4 | ( module Vgrep.Widget.Results 5 | , module Vgrep.Widget.Results.Internal 6 | ) where 7 | 8 | import qualified Data.List as List 9 | import qualified Data.Sequence as Seq 10 | import Data.Text (Text) 11 | import qualified Data.Text as Text 12 | import Test.QuickCheck 13 | 14 | import Vgrep.Ansi 15 | import Vgrep.Widget.Results hiding 16 | ( fileName 17 | , lineNumber 18 | , lineReference 19 | ) 20 | import Vgrep.Widget.Results.Internal 21 | 22 | instance Arbitrary Results where 23 | arbitrary = sized $ \n -> frequency 24 | [ (1, pure EmptyResults) 25 | , (n, generateResults) ] 26 | 27 | 28 | generateResults :: Gen Results 29 | generateResults = sized $ \n -> do 30 | streamOfResults <- arbitraryGrepResults 31 | numAs <- choose (0, n) 32 | numBs <- choose (0, n) 33 | numDs <- choose (0, n) 34 | numEs <- choose (0, n) 35 | let (as, as') = splitAt numAs streamOfResults 36 | (bs, bs') = splitAt numBs as' 37 | ([c], cs') = splitAt 1 bs' 38 | (ds, ds') = splitAt numDs cs' 39 | (es, _) = splitAt numEs ds' 40 | pure $ Results 41 | (Seq.fromList as) 42 | (Seq.fromList bs) 43 | c 44 | (Seq.fromList ds) 45 | (Seq.fromList es) 46 | 47 | 48 | arbitraryGrepResults :: Gen [FileLineReference] 49 | arbitraryGrepResults = fmap concat . infiniteListOf $ do 50 | fileName <- arbitraryText 51 | lineReferences <- do 52 | matches <- listOf arbitraryFormattedText 53 | lineNumbers <- maybeLineNumbers (length matches) 54 | pure (zipWith LineReference lineNumbers matches) 55 | pure [ FileLineReference (File fileName) lineReference 56 | | lineReference <- lineReferences ] 57 | 58 | 59 | arbitraryFormattedText :: Gen (Formatted attr) 60 | arbitraryFormattedText = fmap bare arbitraryText 61 | 62 | arbitraryText :: Gen Text 63 | arbitraryText = fmap Text.pack arbitrary 64 | 65 | ascendingListOf :: Ord a => Int -> Gen a -> Gen [a] 66 | ascendingListOf len things = sorted (vectorOf len things) 67 | 68 | maybeLineNumbers :: Int -> Gen [Maybe Int] 69 | maybeLineNumbers len = arbitrary >>= \case 70 | Just () -> ascendingListOf len (fmap Just positiveNumber) 71 | Nothing -> vectorOf len (pure Nothing) 72 | 73 | sorted :: (Functor f, Ord a) => f [a] -> f [a] 74 | sorted = fmap List.sort 75 | 76 | positiveNumber :: Gen Int 77 | positiveNumber = arbitrary `suchThat` (> 0) 78 | -------------------------------------------------------------------------------- /vgrep.cabal: -------------------------------------------------------------------------------- 1 | name: vgrep 2 | version: 0.2.3.0 3 | synopsis: A pager for grep 4 | description: 5 | @vgrep@ is a pager for navigating through @grep@ output. 6 | . 7 | Usage: 8 | . 9 | > grep -rn foo | vgrep 10 | > vgrep foo /some/path 11 | > vgrep foo /some/path | vgrep bar 12 | . 13 | Use @hjkl@ or arrow keys to navigate, @Enter@ to view file, @q@ to quit. 14 | . 15 | <> 16 | homepage: http://github.com/fmthoma/vgrep#readme 17 | license: BSD3 18 | license-file: LICENSE 19 | author: Franz Thoma 20 | maintainer: franz.thoma@tngtech.com 21 | copyright: 2016 Franz Thoma 22 | category: Web 23 | build-type: Simple 24 | extra-source-files: .stylish-haskell.yaml 25 | , .travis.yml 26 | , CHANGELOG.md 27 | , README.md 28 | , config.yaml.example 29 | , help.txt 30 | , screenshot.gif 31 | , stack.yaml 32 | cabal-version: >=1.10 33 | 34 | library 35 | hs-source-dirs: src 36 | ghc-options: -Wall 37 | default-extensions: LambdaCase 38 | , MultiWayIf 39 | exposed-Modules: Control.Concurrent.STM.TPQueue 40 | , Control.Lens.Compat 41 | , Control.Monad.State.Extended 42 | , Pipes.Concurrent.PQueue 43 | , Vgrep.Ansi 44 | , Vgrep.Ansi.Parser 45 | , Vgrep.Ansi.Type 46 | , Vgrep.Ansi.Vty.Attributes 47 | , Vgrep.App 48 | , Vgrep.App.Internal 49 | , Vgrep.Command 50 | , Vgrep.Environment 51 | , Vgrep.Environment.Config 52 | , Vgrep.Environment.Config.Monoid 53 | , Vgrep.Environment.Config.Sources 54 | , Vgrep.Environment.Config.Sources.Env 55 | , Vgrep.Environment.Config.Sources.File 56 | , Vgrep.Event 57 | , Vgrep.Key 58 | , Vgrep.KeybindingMap 59 | , Vgrep.Parser 60 | , Vgrep.Results 61 | , Vgrep.System.Grep 62 | , Vgrep.Text 63 | , Vgrep.Type 64 | , Vgrep.Widget 65 | , Vgrep.Widget.HorizontalSplit 66 | , Vgrep.Widget.HorizontalSplit.Internal 67 | , Vgrep.Widget.Pager 68 | , Vgrep.Widget.Pager.Internal 69 | , Vgrep.Widget.Results 70 | , Vgrep.Widget.Results.Internal 71 | , Vgrep.Widget.Type 72 | build-depends: base >= 4.11 && < 5 73 | , aeson (>= 0.11 && < 1.6) || (>= 0.9 && < 0.10) || (>= 2 && < 2.1) 74 | , async >= 2.0.2 75 | , attoparsec >= 0.12.1.6 76 | , containers >= 0.5.6.2 77 | , directory >= 1.2.2 78 | , fingertree >= 0.1.1 79 | , generic-deriving >= 1.5.0 80 | , lifted-base >= 0.2.3.6 81 | , microlens-mtl 82 | , microlens-platform 83 | , mmorph >= 1.0.4 84 | , mtl >= 2.2.1 85 | , pipes >= 4.1.6 86 | , pipes-concurrency >= 2.0.3 87 | , process >= 1.2.3 88 | , stm >= 2.4.4 89 | , text >= 1.2.1.3 90 | , transformers 91 | , unix >= 2.7.1 92 | , vty >= 5.4.0 93 | , yaml >= 0.8.12 94 | default-language: Haskell2010 95 | 96 | executable vgrep 97 | hs-source-dirs: app 98 | main-is: Main.hs 99 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 100 | default-extensions: LambdaCase 101 | , MultiWayIf 102 | other-modules: Paths_vgrep 103 | build-depends: base >= 4.11 && < 5 104 | , async >= 2.0.2 105 | , containers >= 0.5.6.2 106 | , directory >= 1.2.2 107 | , microlens-platform 108 | , mtl >= 2.2.1 109 | , pipes >= 4.1.6 110 | , pipes-concurrency >= 2.0.3 111 | , process >= 1.2.3 112 | , template-haskell >= 2.10 113 | , text >= 1.2.1.3 114 | , unix >= 2.7.1 115 | , vgrep 116 | , vty >= 5.4.0 117 | default-language: Haskell2010 118 | 119 | test-suite vgrep-test 120 | type: exitcode-stdio-1.0 121 | hs-source-dirs: test 122 | main-is: Spec.hs 123 | other-modules: Data.Text.Testable 124 | , Test.Case 125 | , Test.Vgrep.Widget 126 | , Test.Vgrep.Widget.Pager 127 | , Test.Vgrep.Widget.Results 128 | , Vgrep.Environment.Testable 129 | , Vgrep.Widget.Pager.Testable 130 | , Vgrep.Widget.Results.Testable 131 | build-depends: base 132 | , containers 133 | , QuickCheck 134 | , tasty 135 | , tasty-quickcheck 136 | , text 137 | , vgrep 138 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 139 | default-language: Haskell2010 140 | 141 | test-suite doctest 142 | type: exitcode-stdio-1.0 143 | hs-source-dirs: test 144 | main-is: Doctest.hs 145 | build-depends: base, doctest 146 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 147 | default-language: Haskell2010 148 | 149 | source-repository head 150 | type: git 151 | location: https://github.com/fmthoma/vgrep 152 | --------------------------------------------------------------------------------