vgrep 0.1.4.1 → 0.2.0.0
raw patch · 42 files changed
+2233/−425 lines, 42 filesdep +aesondep +generic-derivingdep +template-haskelldep ~basedep ~transformersdep ~vtybinary-added
Dependencies added: aeson, generic-deriving, template-haskell, yaml
Dependency ranges changed: base, transformers, vty
Files
- .stylish-haskell.yaml +172/−0
- .travis.yml +51/−0
- CHANGELOG.md +49/−0
- README.md +78/−0
- app/Main.hs +99/−80
- config.yaml.example +145/−0
- help.txt +25/−0
- screenshot.gif binary
- src/Control/Lens/Compat.hs +29/−0
- src/Vgrep/Ansi.hs +50/−0
- src/Vgrep/Ansi/Parser.hs +152/−0
- src/Vgrep/Ansi/Type.hs +212/−0
- src/Vgrep/Ansi/Vty/Attributes.hs +20/−0
- src/Vgrep/App.hs +20/−67
- src/Vgrep/App/Internal.hs +70/−0
- src/Vgrep/Command.hs +36/−0
- src/Vgrep/Environment.hs +24/−7
- src/Vgrep/Environment/Config.hs +142/−21
- src/Vgrep/Environment/Config/Monoid.hs +96/−0
- src/Vgrep/Environment/Config/Sources.hs +8/−0
- src/Vgrep/Environment/Config/Sources/Env.hs +15/−0
- src/Vgrep/Environment/Config/Sources/File.hs +346/−0
- src/Vgrep/Key.hs +92/−0
- src/Vgrep/Parser.hs +17/−9
- src/Vgrep/Results.hs +23/−6
- src/Vgrep/System/Grep.hs +6/−4
- src/Vgrep/Text.hs +36/−18
- src/Vgrep/Widget/HorizontalSplit.hs +7/−54
- src/Vgrep/Widget/HorizontalSplit/Internal.hs +2/−2
- src/Vgrep/Widget/Pager.hs +58/−58
- src/Vgrep/Widget/Pager/Internal.hs +10/−8
- src/Vgrep/Widget/Results.hs +20/−41
- src/Vgrep/Widget/Results/Internal.hs +26/−22
- src/Vgrep/Widget/Type.hs +0/−5
- stack.yaml +36/−0
- test/Test/Case.hs +2/−1
- test/Test/Vgrep/Widget/Pager.hs +9/−7
- test/Test/Vgrep/Widget/Results.hs +4/−3
- test/Vgrep/Environment/Testable.hs +2/−1
- test/Vgrep/Widget/Pager/Testable.hs +1/−1
- test/Vgrep/Widget/Results/Testable.hs +12/−4
- vgrep.cabal +31/−6
+ .stylish-haskell.yaml view
@@ -0,0 +1,172 @@+# stylish-haskell configuration file+# ==================================++# The stylish-haskell tool is mainly configured by specifying steps. These steps+# are a list, so they have an order, and one specific step may appear more than+# once (if needed). Each file is processed by these steps in the given order.+steps:+ # Convert some ASCII sequences to their Unicode equivalents. This is disabled+ # by default.+ # - unicode_syntax:+ # # In order to make this work, we also need to insert the UnicodeSyntax+ # # language pragma. If this flag is set to true, we insert it when it's+ # # not already present. You may want to disable it if you configure+ # # language extensions using some other method than pragmas. Default:+ # # true.+ # add_language_pragma: true++ # Align the right hand side of some elements. This is quite conservative+ # and only applies to statements where each element occupies a single+ # line.+ - simple_align:+ cases: true+ top_level_patterns: true+ records: true++ # Import cleanup+ - imports:+ # There are different ways we can align names and lists.+ #+ # - global: Align the import names and import list throughout the entire+ # file.+ #+ # - file: Like global, but don't add padding when there are no qualified+ # imports in the file.+ #+ # - group: Only align the imports per group (a group is formed by adjacent+ # import lines).+ #+ # - none: Do not perform any alignment.+ #+ # Default: global.+ align: group++ # Folowing options affect only import list alignment.+ #+ # List align has following options:+ #+ # - after_alias: Import list is aligned with end of import including+ # 'as' and 'hiding' keywords.+ #+ # > import qualified Data.List as List (concat, foldl, foldr, head,+ # > init, last, length)+ #+ # - with_alias: Import list is aligned with start of alias or hiding.+ #+ # > import qualified Data.List as List (concat, foldl, foldr, head,+ # > init, last, length)+ #+ # - new_line: Import list starts always on new line.+ #+ # > import qualified Data.List as List+ # > (concat, foldl, foldr, head, init, last, length)+ #+ # Default: after_alias+ list_align: after_alias++ # Long list align style takes effect when import is too long. This is+ # determined by 'columns' setting.+ #+ # - inline: This option will put as much specs on same line as possible.+ #+ # - new_line: Import list will start on new line.+ #+ # - new_line_multiline: Import list will start on new line when it's+ # short enough to fit to single line. Otherwise it'll be multiline.+ #+ # - multiline: One line per import list entry.+ # Type with contructor list acts like single import.+ #+ # > import qualified Data.Map as M+ # > ( empty+ # > , singleton+ # > , ...+ # > , delete+ # > )+ #+ # Default: inline+ long_list_align: multiline++ # List padding determines indentation of import list on lines after import.+ # This option affects 'list_align' and 'long_list_align'.+ list_padding: 4++ # Separate lists option affects formating of import list for type+ # or class. The only difference is single space between type and list+ # of constructors, selectors and class functions.+ #+ # - true: There is single space between Foldable type and list of it's+ # functions.+ #+ # > import Data.Foldable (Foldable (fold, foldl, foldMap))+ #+ # - false: There is no space between Foldable type and list of it's+ # functions.+ #+ # > import Data.Foldable (Foldable(fold, foldl, foldMap))+ #+ # Default: true+ separate_lists: true++ # Language pragmas+ - language_pragmas:+ # We can generate different styles of language pragma lists.+ #+ # - vertical: Vertical-spaced language pragmas, one per line.+ #+ # - compact: A more compact style.+ #+ # - compact_line: Similar to compact, but wrap each line with+ # `{-#LANGUAGE #-}'.+ #+ # Default: vertical.+ style: vertical++ # Align affects alignment of closing pragma brackets.+ #+ # - true: Brackets are aligned in same collumn.+ #+ # - false: Brackets are not aligned together. There is only one space+ # between actual import and closing bracket.+ #+ # Default: true+ align: true++ # stylish-haskell can detect redundancy of some language pragmas. If this+ # is set to true, it will remove those redundant pragmas. Default: true.+ remove_redundant: true++ # Replace tabs by spaces. This is disabled by default.+ # - tabs:+ # # Number of spaces to use for each tab. Default: 8, as specified by the+ # # Haskell report.+ # spaces: 8++ # Remove trailing whitespace+ - trailing_whitespace: {}++# A common setting is the number of columns (parts of) code will be wrapped+# to. Different steps take this into account. Default: 80.+columns: 80++# By default, line endings are converted according to the OS. You can override+# preferred format here.+#+# - native: Native newline format. CRLF on Windows, LF on other OSes.+#+# - lf: Convert to LF ("\n").+#+# - crlf: Convert to CRLF ("\r\n").+#+# Default: native.+newline: lf++# Sometimes, language extensions are specified in a cabal file or from the+# command line instead of using language pragmas in the file. stylish-haskell+# needs to be aware of these, so it can parse the file correctly.+#+# No language extensions are enabled by default.+language_extensions:+ - LambdaCase+ - MultiWayIf+ - MultiParamTypeClasses
+ .travis.yml view
@@ -0,0 +1,51 @@+# Stack's standard Travis config, taken from+# http://docs.haskellstack.org/en/stable/GUIDE.html#travis-with-caching++# Use new container infrastructure to enable caching+sudo: false++# Choose a lightweight base image; we provide our own build tools.+language: generic++# GHC depends on GMP. You can add other dependencies here as well.+addons:+ apt:+ packages:+ - libgmp-dev++# The different configurations we want to test. You could also do things like+# change flags or use --stack-yaml to point to a different file.+matrix:+ fast_finish: true+ include:+ - env: ARGS=""+ - env: ARGS="--resolver lts-5"+ - env: ARGS="--resolver lts-6"+ - env: ARGS="--resolver lts-7"+ - env: ARGS="--resolver lts"+ allow_failures:+ - env: ARGS="--resolver nightly"++before_install:+ # Download and unpack the stack executable+ - mkdir -p ~/.local/bin+ - export PATH=$HOME/.local/bin:$PATH+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'++ - stack $ARGS --no-terminal setup+ - stack $ARGS --no-terminal install hlint hscolour++script:+ - stack $ARGS --no-terminal build --pedantic++ # Tests+ - stack $ARGS --no-terminal test --pedantic+ - stack $ARGS --no-terminal haddock --no-haddock-deps++ - stack $ARGS --no-terminal sdist+ - hlint src test app++# Caching so the next build will be fast too.+cache:+ directories:+ - $HOME/.stack
+ CHANGELOG.md view
@@ -0,0 +1,49 @@+Changelog+=========++## v0.2++* Added support for a config file:+ A YAML file located at `~/.vgrep/config.yaml` is recognized as configuration+ file for colors, keybindings and other settings. The default config file can+ be produced using `vgrep --dump-default-config > ~/.vgrep/config.yaml`.+* Added support for colorized input+ ([ANSI CSI/SGR escape codes](https://en.wikipedia.org/wiki/ANSI_escape_code#graphics)).+ `vgrep` can now be used together wit `grep --color=always` (and `git grep+ --color=always`), which is now enabled by default when using `vgrep` as+ drop-in replacement for `grep`.+++## v0.1.4.1++* Switch to strict `Text`+* Less dependent on `template-haskell`+++## v0.1.4++* User events (like key events) now have priority over other events, the UI does+ not block any more.+* `--help` and `--version` now produce sensible output.+++## v0.1.3++* Fix pageUp in Results view+++## v0.1.2++* Performance improvements+* Tests for Pager and Results widget+* Haddock documentation+++## v0.1.1++* Fixed `j`/`k` keys in pager view+* Additional `h`/`l`/`←`/`→` keybindings for horizontal scrolling in pager+* Matching lines are now highlighted in pager view+++## v0.1
+ README.md view
@@ -0,0 +1,78 @@+`vgrep` -- A pager for `grep`+=============================++++## Usage++* As a pager:++ ```bash+ grep -rn data /some/path | vgrep # -n for line numbers+ ```++* As a drop-in replacement for `grep`:++ ```bash+ vgrep data /some/path # recursive by default+ vgrep data /some/path | vgrep default # works with pipes, too+ ```++* With a `git` alias defined in your `~/.gitconfig`:++ ```bash+ git config --global alias.vgrep '!__git_vgrep () { git grep --color=always "$@" | vgrep; }; __git_vgrep'+ git vgrep data+ ```++* Using [`ack`][ack]/[`ag`][ag] instead of `grep`? No problem:++ ```bash+ ack data | vgrep # Output of `ack` is compatible+ ack --color data | vgrep # Even coloring works+ ag --color data | vgrep # Same for `ag`+ ```+[ack]: http://beyondgrep.com/+[ag]: https://github.com/ggreer/the_silver_searcher++Keybindings:++* Use `hjkl` or the arrow keys to navigate+* `Enter` opens a pager with the selected file+* `e` opens the selected file in `$EDITOR`+* `Tab` switches between results list and pager+* `q` closes the pager and then the entire application.++## Installation++### Binaries++Debian/Ubuntu: `.deb` files are available for the [latest release][1].++```bash+wget https://github.com/fmthoma/vgrep/releases/download/v0.2.0.0/vgrep_0.2.0.0-1_amd64.deb+sudo dpkg -i vgrep_0.2.0.0-1_amd64.deb+```++### From [Hackage][2]++Installation from Hackage via [`stack`][3] is recommended:+```bash+stack update+stack install vgrep+```+This will install `vgrep` to your `~/.local/bin` directory.++### From [source][4]++```bash+git clone https://github.com/fmthoma/vgrep.git+cd vgrep+stack setup+stack install+```++[1]: https://github.com/fmthoma/vgrep/releases/latest+[2]: https://hackage.haskell.org/packages/vgrep+[3]: https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md+[4]: https://github.com/fmthoma/vgrep
app/Main.hs view
@@ -4,20 +4,23 @@ module Main (main) where import Control.Concurrent.Async-import Control.Lens+import Control.Lens.Compat import Control.Monad.Reader+import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import Data.Ratio import Data.Sequence (Seq) import qualified Data.Sequence as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL import Distribution.PackageDescription.TH import qualified Graphics.Vty as Vty import Graphics.Vty.Input.Events hiding (Event) import Graphics.Vty.Picture+import Language.Haskell.TH import Pipes as P import Pipes.Concurrent import qualified Pipes.Prelude as P@@ -25,17 +28,17 @@ import System.Environment (getArgs) import System.Exit import System.IO-import System.Posix.IO import System.Process import Vgrep.App as App+import Vgrep.Command import Vgrep.Environment import Vgrep.Event+import qualified Vgrep.Key as Key import Vgrep.Parser import Vgrep.System.Grep import Vgrep.Text import Vgrep.Type-import Vgrep.Widget hiding (handle) import qualified Vgrep.Widget as Widget import Vgrep.Widget.HorizontalSplit import Vgrep.Widget.Pager@@ -47,10 +50,11 @@ args <- getArgs when ("-V" `elem` args || "--version" `elem` args) (printVersion >> exitSuccess) when ("--help" `elem` args) (printHelp >> exitSuccess)+ when ("--dump-default-config" `elem` args) (printDefaultConfig >> exitSuccess) hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering- cfg <- withConfiguredEditor defaultConfig+ cfg <- loadConfig mempty inputFromTerminal <- hIsTerminalDevice stdin outputToTerminal <- hIsTerminalDevice stdout case (inputFromTerminal, outputToTerminal) of@@ -79,24 +83,10 @@ putStrLn "" putStrLn "grep version: " runEffect (grepVersion >-> P.take 1 >-> P.map (" " <>) >-> stdoutText)- printHelp = T.putStrLn helpText--helpText :: Text-helpText = T.unlines- [ "vgrep, a pager for grep"- , ""- , "Usage:"- , " as a drop-in replacement for `grep -r`:"- , " vgrep [GREP_OPTION...] PATTERN [FILE]"- , ""- , ""- , " at the end of a pipeline:"- , " ... | vgrep [-nH] PATTERN"- , ""- , " as a pager for `grep -nH` output:"- , " grep -nH [GREP_OPTION...] PATTERN [FILE] | vgrep"- , ""- , "For documentation on grep options an patterns see `grep --help`." ]+ printHelp = putStrLn helpText+ where helpText = $(runIO (readFile "help.txt") >>= stringE)+ printDefaultConfig = putStrLn defaultConfigFile+ where defaultConfigFile = $(runIO (readFile "config.yaml.example") >>= stringE) type MainWidget = HSplitWidget Results Pager@@ -122,7 +112,7 @@ { _widgetState = Widget.initialize mainWidget , _inputLines = S.empty } renderMainWidget :: Monad m => VgrepT AppState m Vty.Picture- renderMainWidget = fmap picForImage (zoom widgetState (draw mainWidget))+ renderMainWidget = fmap picForImage (zoom widgetState (Widget.draw mainWidget)) mainWidget :: MainWidget mainWidget = hSplitWidget resultsWidget pagerWidget@@ -134,22 +124,23 @@ eventHandler :: MonadIO m => Event+ -> Environment -> AppState -> Next (VgrepT AppState m Redraw) eventHandler = \case- ReceiveInputEvent line -> const (handleFeedInput line)- ReceiveResultEvent line -> const (handleFeedResult line)+ ReceiveInputEvent line -> \_ _ -> handleFeedInput line+ ReceiveResultEvent line -> \_ _ -> handleFeedResult line VtyEvent event -> handleVty event where handleFeedResult, handleFeedInput :: MonadIO m => Text -> Next (VgrepT AppState m Redraw)- handleFeedResult line = Continue $ do- expandedLine <- expandLineForDisplay line- case parseLine expandedLine of- Just l -> zoom results (feedResult l)- Nothing -> pure Unchanged+ handleFeedResult line = Continue $ case parseLine line of+ Just l -> do+ l' <- traverseOf (lineReference . lineText) expandFormattedLine l+ zoom results (feedResult l')+ Nothing -> pure Unchanged handleFeedInput line = Continue $ do expandedLine <- expandLineForDisplay line modifying inputLines (|> expandedLine)@@ -158,60 +149,93 @@ handleVty :: MonadIO m => Vty.Event+ -> Environment -> AppState -> Next (VgrepT AppState m Redraw)-handleVty event = do- localKeyBindings <- view (widgetState . currentWidget) >>= \case- Left _ -> pure resultsKeyBindings- Right _ -> pure pagerKeyBindings- (pure . localKeyBindings <> delegateToWidget <> globalEventBindings) event+handleVty = \case+ EvResize w h -> \_ _ -> handleResizeEvent w h+ ev | Just chord <- Key.fromVty ev -> handleKeyEvent chord+ | otherwise -> \_ _ -> Skip -delegateToWidget+handleResizeEvent :: Monad m => Int -> Int -> Next (VgrepT AppState m Redraw)+handleResizeEvent w h = Continue $ do+ modifyEnvironment . set viewport $+ Viewport { _vpWidth = w, _vpHeight = h }+ pure Redraw++handleKeyEvent :: MonadIO m- => Vty.Event+ => Key.Chord+ -> Environment -> AppState -> Next (VgrepT AppState m Redraw)-delegateToWidget event = fmap (zoom widgetState)- . Widget.handle mainWidget event- . view widgetState+handleKeyEvent chord environment state =+ executeCommand command state+ where+ globalBindings = view (config . keybindings . globalKeybindings) environment+ resultsBindings = view (config . keybindings . resultsKeybindings) environment+ pagerBindings = view (config . keybindings . pagerKeybindings) environment+ localBindings = case view (widgetState . currentWidget) state of+ Left _ -> resultsBindings+ Right _ -> pagerBindings+ lookupCmd = fromMaybe Unset . M.lookup chord+ command = case lookupCmd localBindings of+ Unset -> lookupCmd globalBindings+ defined -> defined -resultsKeyBindings :: MonadIO m => Vty.Event -> Next (VgrepT AppState m Redraw)-resultsKeyBindings = dispatchMap $ fromList- [ (EvKey KEnter [], loadSelectedFileToPager) ] -pagerKeyBindings :: Vty.Event -> Next (VgrepT AppState m Redraw)-pagerKeyBindings = dispatchMap $ fromList- []--globalEventBindings- :: MonadIO m- => Vty.Event- -> AppState- -> Next (VgrepT AppState m Redraw)-globalEventBindings = \case- EvResize w h -> const . Continue $ do- modifyEnvironment (set region (w, h))- pure Redraw- EvKey (KChar 'q') [] -> const (Interrupt Halt)- EvKey (KChar 'e') [] -> invokeEditor- _otherwise -> const Skip+executeCommand :: MonadIO m => Command -> AppState -> Next (VgrepT AppState m Redraw)+executeCommand = \case+ Unset -> skip+ DisplayPagerOnly -> continue (zoom widgetState rightOnly)+ DisplayResultsOnly -> continue (zoom widgetState leftOnly)+ SplitFocusPager -> continue splitViewPager+ SplitFocusResults -> continue splitViewResults+ PagerUp -> continue (zoom pager (scroll (-1)))+ PagerDown -> continue (zoom pager (scroll 1))+ PagerPageUp -> continue (zoom pager (scrollPage (-1)))+ PagerPageDown -> continue (zoom pager (scrollPage 1))+ PagerScrollLeft -> continue (zoom pager (hScroll (-1)))+ PagerScrollRight -> continue (zoom pager (hScroll 1))+ ResultsUp -> continue (zoom results prevLine >> pure Redraw)+ ResultsDown -> continue (zoom results nextLine >> pure Redraw)+ ResultsPageUp -> continue (zoom results pageUp >> pure Redraw)+ ResultsPageDown -> continue (zoom results pageDown >> pure Redraw)+ PrevResult -> continue (zoom results prevLine >> loadSelectedFileToPager)+ NextResult -> continue (zoom results nextLine >> loadSelectedFileToPager)+ PagerGotoResult -> continue (loadSelectedFileToPager >> splitViewPager)+ OpenFileInEditor -> invokeEditor+ Exit -> halt+ where+ continue = const . Continue+ skip = const Skip+ halt = const (Interrupt Halt) +splitViewPager, splitViewResults :: Monad m => VgrepT AppState m Redraw+splitViewPager = zoom widgetState (splitView FocusRight (1 % 3))+splitViewResults = zoom widgetState (splitView FocusLeft (2 % 3)) loadSelectedFileToPager :: MonadIO m => VgrepT AppState m Redraw loadSelectedFileToPager = do maybeFileName <- uses (results . currentFileName) (fmap T.unpack)- whenJust maybeFileName $ \fileName -> do- fileExists <- liftIO (doesFileExist fileName)+ whenJust maybeFileName $ \selectedFile -> do+ fileExists <- liftIO (doesFileExist selectedFile) fileContent <- if fileExists- then liftIO (fmap (S.fromList . T.lines) (T.readFile fileName))+ then readLinesFrom selectedFile else use inputLines displayContent <- expandForDisplay fileContent- highlightLineNumbers <- use (results . currentFileResultLineNumbers)- zoom pager (replaceBufferContents displayContent highlightLineNumbers)+ highlightedLines <- use (results . currentFileResults)+ zoom pager (replaceBufferContents displayContent highlightedLines) moveToSelectedLineNumber- zoom widgetState (splitView FocusRight (1 % 3))+ pure Redraw+ where+ readLinesFrom f = liftIO $ do+ content <- TL.readFile f+ pure (fileLines content)+ fileLines = S.fromList . map TL.toStrict . TL.lines + moveToSelectedLineNumber :: Monad m => VgrepT AppState m () moveToSelectedLineNumber = use (results . currentLineNumber)@@ -222,23 +246,18 @@ invokeEditor :: AppState -> Next (VgrepT AppState m Redraw) invokeEditor state = case views (results . currentFileName) (fmap T.unpack) state of- Just file -> Interrupt $ Suspend $ \environment -> do+ Just selectedFile -> Interrupt $ Suspend $ \environment -> do let configuredEditor = view (config . editor) environment- lineNumber = views (results . currentLineNumber) (fromMaybe 0) state- liftIO $ doesFileExist file >>= \case- True -> exec configuredEditor ['+' : show lineNumber, file]- False -> hPutStrLn stderr ("File not found: " ++ show file)+ selectedLineNumber = views (results . currentLineNumber) (fromMaybe 0) state+ liftIO $ doesFileExist selectedFile >>= \case+ True -> exec configuredEditor ['+' : show selectedLineNumber, selectedFile]+ False -> hPutStrLn stderr ("File not found: " ++ show selectedFile) Nothing -> Skip exec :: MonadIO io => FilePath -> [String] -> io () exec command args = liftIO $ do- inHandle <- fdToHandle =<< ttyIn- outHandle <- fdToHandle =<< ttyOut- (_,_,_,h) <- createProcess $ (proc command args)- { std_in = UseHandle inHandle- , std_out = UseHandle outHandle }- _ <- waitForProcess h- return ()+ (_,_,_,h) <- createProcess (proc command args)+ void (waitForProcess h) --------------------------------------------------------------------------- -- Lenses
+ config.yaml.example view
@@ -0,0 +1,145 @@+## Color configuration+##+## For each item, the following three attributes can be specified:+## * fore-color: The text color+## * back-color: The background color+## * Valid colors are the usual 16 terminal colors:+## black, red, green, blue, yellow, magenta, cyan, white,+## bright-black, bright-red, bright-green, bright-yellow,+## bright-blue, bright-magenta, bright-cyan, bright-white+## * style:+## * Valid styles are:+## standout, underline, reverse-video, blink, dim, bold+## Please note that not all styles are necessarily supported+## by your terminal.+##+## If a color/style is not given, it falls back to the terminal+## default. If no config is given for a color, the vgrep default+## config steps in (which may differ from your terminal's default).+##+colors:++ # Line numbers+ line-numbers:+ fore-color: blue+ # Highlighted line numbers+ line-numbers-hl:+ fore-color: blue+ style: bold++ # Normal text+ normal:++ # Highlighted text+ normal-hl:+ style: bold++ # The file names in the results list+ file-headers:+ back-color: green++ # The line currently selected by the cursor+ selected:+ style: standout+++## The tabstop witdth (a tab character moves the indentation to the+## next multiple of this value)+##+tabstop: 8+++## The editor to be used by the 'e' key (read from $EDITOR by+## default, but can be overridden here).+##+# editor: "vi"+++## Keybindings+##+## The following commands can be mapped:+## * display-pager-only -- Display the pager full-screen+## * display-results-only -- Display the results list full-screen+## * split-focus-pager -- Split screen, focus on pager+## * split-focus-results -- Split screen, focus on results list+## * pager-up -- Scroll one line up in pager+## * pager-down -- Scroll one line down in pager+## * pager-page-up -- Scroll one page up in pager+## * pager-page-down -- Scroll one page down in pager+## * pager-scroll-left -- Scroll eight characters left in pager+## * pager-scroll-right -- Scroll eight characters right in pager+## * results-up -- Move to previous result+## * results-down -- Move to next result+## * results-page-up -- Move one page up in results list+## * results-page-down -- Move one page down in results list+## * prev-result -- Move to previous result and update pager+## * next-result -- Move to next result and update pager+## * pager-goto-result -- Update pager with currently selected result+## * open-file-in-editor -- Open file in external editor and jump to+## currently selected result+## * exit -- Exit the application+## * unset -- Treat keybinding as if not present, fall back to+## -- alternative binding (used to override keybindings)+## A command can be mapped to multiple keys.+##+## Key notation examples+## * j -- the 'j' key+## * J -- the 'J' key (Shift-'j')+## * Up, Down, Left, Right -- the corresponding arrow keys+## * S-Up, C-Up, M-Up -- Modifiers Shift, Ctrl, Alt/Meta combined with the+## Up key+## * C-M-S-Up, C-S-M-Up -- Modifiers can be combined, the order is irrelevant+## (both correspond to Control-Alt-Shift-Up)+## * The Shift key can only be applied to non-character keys (like Up, Down,+## Space, Enter): Shift-'j' is represented by 'J', not by 'S-j'.+##+## Default keybindings:+keybindings:++ # These keybindings are always in effect, but can be overridden.+ global-keybindings:+ q : exit+ e : open-file-in-editor++ # These keybindings apply when navigating the results list. They override+ # any colliding global-keybinding.+ results-keybindings:+ Up : results-up+ Down : results-down+ PageUp : results-page-up+ PageDown : results-page-down+ Enter : pager-goto-result+ k : results-up+ j : results-down+ f : display-results-only+ Tab : split-focus-pager++ # These apply when navigating the pager. They override any colliding+ # global-keybinding.+ pager-keybindings:+ Up : pager-up+ Down : pager-down+ PageUp : pager-page-up+ PageDown : pager-page-down+ Left : pager-scroll-left+ Right : pager-scroll-right+ k : pager-up+ j : pager-down+ h : pager-scroll-left+ l : pager-scroll-right+ Tab : split-focus-results+ f : display-pager-only+ q : display-results-only++## Alternative keybindings: tig-style+## (jk to navigate the pager, Up/Down to navigate the results list)+##+# keybindings:+# results-keybindings:+# O : display-results-only+# f : unset+# pager-keybindings:+# O : display-pager-only+# Up : prev-result+# Down : next-result+# f : unset
+ help.txt view
@@ -0,0 +1,25 @@+vgrep, a pager for grep+++Usage:+ as a drop-in replacement for `grep -r`:+ vgrep [GREP_OPTION...] PATTERN [FILE]++ at the end of a pipeline:+ ... | vgrep [-nH] PATTERN++ as a pager for `grep -nH` output:+ grep -nH [GREP_OPTION...] PATTERN [FILE] | vgrep+++Additional options:+ --help, -V Prints this help.++ --version Prints version info and exits++ --dump-default-config+ Prints the default config file to stdout and exits.+ (Usage: `vgrep --dump-default-config > ~/.vgrep/config.yaml`)+++For documentation on grep options an patterns see `grep --help`.
+ screenshot.gif view
binary file changed (absent → 721956 bytes)
+ src/Control/Lens/Compat.hs view
@@ -0,0 +1,29 @@+module Control.Lens.Compat+ ( to+ , module Control.Lens+ ) where++import Control.Lens hiding (to)+import qualified Control.Lens as Lens+++-- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function.+-- See "Control.Lens".'Lens.to' for details.+--+-- In <https://hackage.haskell.org/package/lens-4.14 lens-4.14>, the constraint+-- @'Functor' f@ is missing from the definition of 'Lens.to'. When compiling+-- with GHC 8.0, this leads to warnings for definitions like+--+-- @+-- foo :: Getter Bar Foo+-- foo = to fooFromBar+-- @+--+-- because of the redundant @'Functor' f@ constraint. This definition is+-- identical to "Control.Lens".'Lens.to' except for the additional constraint+-- @'Functor' f@.+to :: (Profunctor p, Functor f, Contravariant f) => (s -> a) -> Optic' p f s a+to k = getter+ where+ getter = Lens.to k+ _fakeFunctorConstraint = rmap (fmap undefined) . getter
+ src/Vgrep/Ansi.hs view
@@ -0,0 +1,50 @@+-- | Utilities for printing ANSI formatted text.+module Vgrep.Ansi (+ -- * ANSI formatted text+ AnsiFormatted+ , Formatted ()+ -- ** Smart constructors+ , emptyFormatted+ , bare+ , format+ , cat+ -- ** Modifying text nodes+ , mapText+ , mapTextWithPos+ , takeFormatted+ , dropFormatted+ , padFormatted++ -- * Converting ANSI formatted text+ , renderAnsi+ , stripAnsi+ ) where++import Data.Text (Text)+import qualified Graphics.Vty as Vty++import Vgrep.Ansi.Type+import Vgrep.Ansi.Vty.Attributes+++-- | Converts ANSI formatted text to an 'Vty.Image'. Nested formattings are+-- combined with 'combineStyles'. The given 'Vty.Attr' is used as style for the+-- root of the 'Formatted' tree.+--+-- >>> renderAnsi Vty.defAttr (bare "Text")+-- HorizText "Text"@(Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default},4,4)+--+renderAnsi :: Attr -> AnsiFormatted -> Vty.Image+renderAnsi attr = \case+ Empty -> Vty.emptyImage+ Text _ t -> Vty.text' attr t+ Format _ attr' t -> renderAnsi (combineStyles attr attr') t+ Cat _ ts -> Vty.horizCat (map (renderAnsi attr) ts)++-- | Strips away all formattings to plain 'Text'.+stripAnsi :: Formatted a -> Text+stripAnsi = \case+ Empty -> mempty+ Text _ t -> t+ Format _ _ t -> stripAnsi t+ Cat _ ts -> foldMap stripAnsi ts
+ src/Vgrep/Ansi/Parser.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+module Vgrep.Ansi.Parser+ ( parseAnsi+ , ansiFormatted+ , attrChange+ ) where+++import Control.Applicative+import Data.Attoparsec.Text+import Data.Bits+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Graphics.Vty.Attributes (Attr)+import qualified Graphics.Vty.Attributes as Vty++import Vgrep.Ansi.Type+++{- |+Directly parses ANSI formatted text using 'ansiFormatted'.++Parsing ANSI color codes:++>>> parseAnsi "Hello \ESC[31mWorld\ESC[m!"+Cat 12 [Text 6 "Hello ",Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent}) (Text 5 "World"),Text 1 "!"]++More elaborate example with nested foreground and background colors:++>>> parseAnsi "\ESC[m\ESC[40mHello \ESC[31mWorld\ESC[39m!"+Cat 12 [Format 6 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0)}) (Text 6 "Hello "),Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = SetTo (ISOColor 0)}) (Text 5 "World"),Format 1 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0)}) (Text 1 "!")]++Some CSI sequences are ignored, since they are not supported by 'Vty':++>>> parseAnsi "\ESC[A\ESC[B\ESC[31mfoo\ESC[1K\ESC[mbar"+Cat 6 [Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent}) (Text 3 "foo"),Text 3 "bar"]++Non-CSI sequences are not parsed, but included in the output:++>>> parseAnsi "\ESC]710;font\007foo\ESC[31mbar"+Cat 17 [Text 14 "\ESC]710;font\afoo",Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent}) (Text 3 "bar")]++-}+parseAnsi :: Text -> AnsiFormatted+parseAnsi = either error id . parseOnly ansiFormatted+-- The use of 'error' ↑ is safe: 'ansiFormatted' does not fail.+++-- | Parser for ANSI formatted text. Recognized escape sequences are the SGR+-- (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'.+-- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are+-- ignored. Other (non-CSI) escape sequences are not parsed, and included in the+-- output.+--+-- This parser does not fail, it will rather consume and return the remaining+-- input as unformatted text.+ansiFormatted :: Parser AnsiFormatted+ansiFormatted = go mempty+ where+ go :: Attr -> Parser AnsiFormatted+ go attr = endOfInput *> pure mempty+ <|> formattedText attr++ formattedText :: Attr -> Parser AnsiFormatted+ formattedText attr = do+ acs <- many attrChange+ let attr' = foldr ($) attr (reverse acs)+ t <- rawText+ rest <- go attr'+ pure (format attr' (bare t) <> rest)++ rawText :: Parser Text+ rawText = atLeastOneTill (== '\ESC') <|> endOfInput *> pure ""++ atLeastOneTill :: (Char -> Bool) -> Parser Text+ atLeastOneTill = liftA2 T.cons anyChar . takeTill+++-- | Parser for ANSI CSI escape sequences. Recognized escape sequences are the+-- SGR (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'.+-- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are+-- ignored by returning 'id'.+--+-- This parser fails when encountering any other (non-CSI) escape sequence.+attrChange :: Parser (Attr -> Attr)+attrChange = fmap csiToAttrChange csi++csiEscape :: Parser Text+csiEscape = "\ESC["++csi :: Parser Csi+csi = csiEscape >> liftA2 Csi (decimal `sepBy` char ';') anyChar++data Csi = Csi [Int] Char++csiToAttrChange :: Csi -> Attr -> Attr+csiToAttrChange = \case+ Csi [] 'm' -> const mempty+ Csi is 'm' -> foldMap attrChangeFromCode is+ _otherwise -> id++attrChangeFromCode :: Int -> Attr -> Attr+attrChangeFromCode = \case+ 0 -> const mempty+ 1 -> withStyle Vty.bold+ 3 -> withStyle Vty.standout+ 4 -> withStyle Vty.underline+ 5 -> withStyle Vty.blink+ 6 -> withStyle Vty.blink+ 7 -> withStyle Vty.reverseVideo+ 21 -> withoutStyle Vty.bold+ 22 -> withoutStyle Vty.bold+ 23 -> withoutStyle Vty.standout+ 24 -> withoutStyle Vty.underline+ 25 -> withoutStyle Vty.blink+ 27 -> withoutStyle Vty.reverseVideo+ i | i >= 30 && i <= 37 -> withForeColor (rawColor (i - 30))+ | i >= 40 && i <= 47 -> withBackColor (rawColor (i - 40))+ | i >= 90 && i <= 97 -> withForeColor (rawBrightColor (i - 90))+ | i >= 100 && i <= 107 -> withBackColor (rawBrightColor (i - 100))+ 39 -> resetForeColor+ 49 -> resetBackColor+ _ -> id+ where+ rawColor = \case+ 0 -> Vty.black+ 1 -> Vty.red+ 2 -> Vty.green+ 3 -> Vty.yellow+ 4 -> Vty.blue+ 5 -> Vty.magenta+ 6 -> Vty.cyan+ _ -> Vty.white+ rawBrightColor = \case+ 0 -> Vty.brightBlack+ 1 -> Vty.brightRed+ 2 -> Vty.brightGreen+ 3 -> Vty.brightYellow+ 4 -> Vty.brightBlue+ 5 -> Vty.brightMagenta+ 6 -> Vty.brightCyan+ _ -> Vty.brightWhite+ withStyle = flip Vty.withStyle+ withForeColor = flip Vty.withForeColor+ withBackColor = flip Vty.withBackColor+ withoutStyle style attr = case Vty.attrStyle attr of+ Vty.SetTo oldStyle | oldStyle `Vty.hasStyle` style+ -> attr { Vty.attrStyle = Vty.SetTo (oldStyle .&. complement style) }+ _otherwise -> attr+ resetForeColor attr = attr { Vty.attrForeColor = Vty.KeepCurrent }+ resetBackColor attr = attr { Vty.attrBackColor = Vty.KeepCurrent }
+ src/Vgrep/Ansi/Type.hs view
@@ -0,0 +1,212 @@+module Vgrep.Ansi.Type+ ( Formatted (..)+ , AnsiFormatted+ -- * Smart constructors+ , emptyFormatted+ , bare+ , format+ , cat+ -- * Modifying the underlying text+ , mapText+ , mapTextWithPos+ , takeFormatted+ , dropFormatted+ , padFormatted+ -- * Internal helpers+ , fuse+ ) where++import Data.Foldable (foldl')+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Graphics.Vty (Attr)+import Prelude hiding (length)+++-- | A representattion of formatted 'Text'. The attribute is usually a 'Monoid'+-- so that different formattings can be combined by nesting them.+data Formatted attr+ = Empty+ -- ^ An empty block++ | Text !Int Text+ -- ^ A bare (unformatted) text node++ | Format !Int attr (Formatted attr)+ -- ^ Adds formatting to a block++ | Cat !Int [Formatted attr]+ -- ^ Concatenates several blocks of formatted text++ deriving (Eq, Show)++instance Functor Formatted where+ fmap f = \case+ Empty -> Empty+ Text l t -> Text l t+ Format l a t -> Format l (f a) (fmap f t)+ Cat l ts -> Cat l (map (fmap f) ts)++instance (Eq attr, Monoid attr) => Monoid (Formatted attr) where+ mempty = Empty+ mappend = fuse+++-- | Type alias for Text formatted with 'Attr' from "Graphics.Vty".+type AnsiFormatted = Formatted Attr+++-- | Smart constructor for an empty 'Formatted' text.+emptyFormatted :: Formatted attr+emptyFormatted = Empty++-- | Smart constructor for bare (unformatted) text.+--+-- >>> bare ""+-- Empty+--+-- >>> bare "Text"+-- Text 4 "Text"+--+bare :: Text -> Formatted attr+bare t+ | T.null t = emptyFormatted+ | otherwise = Text (T.length t) t++-- | Adds formatting to a 'Formatted' text. The 'Eq' and 'Monoid' instances for+-- @attr@ are used to flatten redundant formattings.+--+-- >>> format (Just ()) (format Nothing (bare "Text"))+-- Format 4 (Just ()) (Text 4 "Text")+--+-- >>> format (Just ()) (format (Just ()) (bare "Text"))+-- Format 4 (Just ()) (Text 4 "Text")+--+-- >>> format Nothing (bare "Text")+-- Text 4 "Text"+--+format :: (Eq attr, Monoid attr) => attr -> Formatted attr -> Formatted attr+format attr formatted+ | attr == mempty = formatted+ | Format l attr' formatted' <- formatted+ = Format l (attr <> attr') formatted'+ | otherwise = format' attr formatted++format' :: attr -> Formatted attr -> Formatted attr+format' attr formatted = Format (length formatted) attr formatted++-- | Concatenates pieces of 'Formatted' text. Redundant formattings and blocks+-- of equal formatting are 'fuse'd together.+cat :: (Eq attr, Monoid attr) => [Formatted attr] -> Formatted attr+cat = \case+ [] -> emptyFormatted+ [t] -> t+ ts -> foldl' fuse emptyFormatted ts++cat' :: [Formatted attr] -> Formatted attr+cat' = \case+ [] -> emptyFormatted+ [t] -> t+ ts -> Cat (sum (fmap length ts)) ts++-- | Simplifies 'Formatted' text by leaving out redundant empty bits, joining+-- pieces of text with the same formatting, and flattening redundant+-- applications of the same style.+--+-- >>> emptyFormatted `fuse` bare "Text"+-- Text 4 "Text"+--+-- >>> format (Just ()) (bare "Left") `fuse` format (Just ()) (bare "Right")+-- Format 9 (Just ()) (Text 9 "LeftRight")+--+fuse :: (Eq attr, Monoid attr) => Formatted attr -> Formatted attr -> Formatted attr+fuse left right = case (left, right) of+ (Empty, formatted) -> formatted+ (formatted, Empty) -> formatted+ (Text l t, Text l' t') -> Text (l + l') (t <> t')+ (Format l attr t, Format l' attr' t')+ | attr' == attr -> Format (l + l') attr (t <> t')++ (Cat l ts, Cat l' ts') -> Cat (l + l') (ts ++ ts')+ (Cat l ts, formatted) -> Cat (l + length formatted) (ts ++ [formatted])+ (formatted, Cat _ (t:ts)) -> case formatted `fuse` t of+ Cat _ ts' -> cat' (ts' ++ ts)+ t' -> cat' (t' : ts)+ (formatted, formatted') -> cat' [formatted, formatted']++length :: Formatted attr -> Int+length = \case+ Empty -> 0+ Text l _ -> l+ Format l _ _ -> l+ Cat l _ -> l++++-- | Apply a function to each piece of text in the 'Formatted' tree.+--+-- >>> mapText T.toUpper (Cat 11 [Text 6 "Hello ", Format 5 () (Text 5 "World")])+-- Cat 11 [Text 6 "HELLO ",Format 5 () (Text 5 "WORLD")]+--+mapText :: (Text -> Text) -> Formatted a -> Formatted a+mapText f = \case+ Empty -> emptyFormatted+ Text _ t -> bare (f t)+ Format _ attr t -> format' attr (mapText f t)+ Cat _ ts -> cat' (map (mapText f) ts)++-- | Like 'mapText', but passes the position of the text chunk to the function+-- as well. Can be used for formatting text position-dependently, e.g. for+-- expanding tabs to spaces.+mapTextWithPos :: (Int -> Text -> Text) -> Formatted a -> Formatted a+mapTextWithPos f = go 0+ where+ go pos = \case+ Empty -> emptyFormatted+ Text _ t -> bare (f pos t)+ Format _ attr t -> format' attr (go pos t)+ Cat _ ts -> cat' (go2 pos ts)+ go2 pos = \case+ [] -> []+ t : ts -> let t' = go pos t+ l' = length t'+ ts' = go2 (pos + l') ts+ in t' : ts'+++-- | Crops the text to a given length. If the text is already shorter than the+-- desired width, it is returned as-is.+takeFormatted :: Int -> Formatted a -> Formatted a+takeFormatted w txt+ | length txt > w = mapTextWithPos cropChunk txt+ | otherwise = txt+ where+ cropChunk pos+ | pos >= w = const T.empty+ | otherwise = T.take (w - pos)++-- | Drops a prefix of the given length. If the text is already shorter than the+-- number of characters to be dropped, 'emptyFormatted' is returned.+dropFormatted :: Int -> Formatted a -> Formatted a+dropFormatted amount txt+ | amount <= 0 = txt+ | length txt < amount = emptyFormatted+ | otherwise = case txt of+ Empty -> emptyFormatted+ Text _ t -> bare (T.drop amount t)+ Format _ attr t -> format' attr (dropFormatted amount t)+ Cat _ ts -> cat' (dropChunks amount ts)+ where+ dropChunks n = \case+ [] -> []+ t:ts -> dropFormatted n t : dropChunks (n - length t) ts++-- | Pads the text to a given width. If the text is already longer than the+-- desired width, it is returned as-is.+padFormatted :: Int -> Char -> Formatted a -> Formatted a+padFormatted w c txt+ | w > length txt = cat' [txt, padding (w - length txt)]+ | otherwise = txt+ where+ padding l = bare (T.replicate l (T.singleton c))
+ src/Vgrep/Ansi/Vty/Attributes.hs view
@@ -0,0 +1,20 @@+module Vgrep.Ansi.Vty.Attributes+ ( Attr ()+ , combineStyles+ ) where++import Data.Bits ((.|.))+import Data.Monoid ((<>))+import Graphics.Vty.Attributes (Attr (..), MaybeDefault (..))++-- | Combines two 'Attr's. This differs from 'mappend' from the 'Monoid'+-- instance of 'Attr' in that 'Vty.Style's are combined rather than+-- overwritten.+combineStyles :: Attr -> Attr -> Attr+combineStyles l r = Attr+ { attrStyle = case (attrStyle l, attrStyle r) of+ (SetTo l', SetTo r') -> SetTo (l' .|. r')+ (l', r') -> l' <> r'+ , attrForeColor = attrForeColor l <> attrForeColor r+ , attrBackColor = attrBackColor l <> attrBackColor r+ }
src/Vgrep/App.hs view
@@ -4,22 +4,16 @@ module Vgrep.App ( App(..) , runApp, runApp_-- -- * Auxiliary definitions- , ttyIn- , ttyOut ) where import Control.Concurrent.Async-import Control.Exception import Graphics.Vty (Vty) import qualified Graphics.Vty as Vty import Pipes hiding (next) import Pipes.Concurrent.PQueue import Pipes.Prelude as P-import System.Posix.IO-import System.Posix.Types (Fd) +import Vgrep.App.Internal import Vgrep.Environment import Vgrep.Event import Vgrep.Type@@ -34,7 +28,7 @@ , liftEvent :: Vty.Event -> e -- ^ How to convert an external 'Vty.Event' to the App's event - , handleEvent :: forall m. MonadIO m => e -> s -> Next (VgrepT s m Redraw)+ , handleEvent :: forall m. MonadIO m => e -> Environment -> s -> Next (VgrepT s m Redraw) -- ^ Handles an event, possibly modifying the App's state. -- -- @@@ -65,14 +59,14 @@ -- 'Vty.Vty' again. runApp :: App e s -> Config -> Producer e IO () -> IO s runApp app conf externalEvents = withSpawn $ \(evSink, evSource) -> do- displayRegion <- displayRegionHack+ initialViewport <- viewportHack let userEventSink = contramap (User,) evSink systemEventSink = contramap (System,) evSink externalEventThread <- (async . runEffect) (externalEvents >-> toOutput systemEventSink) initialState <- initialize app (_, finalState) <- runVgrepT (appEventLoop app evSource userEventSink) initialState- (Env conf displayRegion)+ (Env conf initialViewport) cancel externalEventThread pure finalState @@ -81,82 +75,41 @@ contramap :: (b -> a) -> Output a -> Output b contramap f (Output a) = Output (a . f) --- | We need the display region in order to initialize the app, which in--- turn will start 'Vty.Vty'. To resolve this circular dependency, we start--- once 'Vty.Vty' in order to determine the display region, and shut it--- down again immediately.-displayRegionHack :: IO DisplayRegion-displayRegionHack = bracket initVty Vty.shutdown $ \vty ->- Vty.displayBounds (Vty.outputIface vty) appEventLoop :: forall e s. App e s -> Input e -> Output e -> VgrepT s IO ()-appEventLoop app evSource evSink = startEventLoop >>= suspendAndResume+appEventLoop app evSource evSink = eventLoop where+ eventLoop :: VgrepT s IO ()+ eventLoop = startEventLoop >>= suspendAndResume+ startEventLoop :: VgrepT s IO Interrupt- startEventLoop = withVty vtyEventSink $ \vty -> do+ startEventLoop = withVgrepVty $ \vty -> withEvThread vtyEventSink vty $ do refresh vty- runEffect ((fromInput evSource >> pure Halt) >-> eventLoop vty)+ runEffect ((fromInput evSource >> pure Halt) >-> eventHandler vty) - continueEventLoop :: VgrepT s IO Interrupt- continueEventLoop = withVty vtyEventSink $ \vty -> do- refresh vty- runEffect ((fromInput evSource >> pure Halt) >-> eventLoop vty)+ suspendAndResume :: Interrupt -> VgrepT s IO ()+ suspendAndResume = \case+ Halt -> pure ()+ Suspend outsideAction -> do env <- ask+ outsideAction env+ eventLoop - eventLoop :: Vty -> Consumer e (VgrepT s IO) Interrupt- eventLoop vty = go+ eventHandler :: Vty -> Consumer e (VgrepT s IO) Interrupt+ eventHandler vty = go where go = do event <- await currentState <- get- case handleAppEvent event currentState of+ env <- ask+ case handleAppEvent event env currentState of Skip -> go Continue action -> lift action >>= \case Unchanged -> go Redraw -> lift (refresh vty) >> go Interrupt int -> pure int - suspendAndResume :: Interrupt -> VgrepT s IO ()- suspendAndResume = \case- Halt -> pure ()- Suspend outsideAction -> do env <- ask- outsideAction env- continueEventLoop >>= suspendAndResume- refresh :: Vty -> VgrepT s IO () refresh vty = render app >>= lift . Vty.update vty vtyEventSink = P.map (liftEvent app) >-> toOutput evSink handleAppEvent = handleEvent app----- | 'User' events do have higher priority than 'System' events, so that--- the application stays responsive even in case of event queue congestion.-data EventPriority = User | System deriving (Eq, Ord, Enum)--withVty :: Consumer Vty.Event IO () -> (Vty -> VgrepT s IO a) -> VgrepT s IO a-withVty sink action = vgrepBracket before after (\(vty, _) -> action vty)- where- before = do- vty <- initVty- evThread <- (async . runEffect) $- lift (Vty.nextEvent vty) >~ sink- pure (vty, evThread)- after (vty, evThread) = do- cancel evThread- Vty.shutdown vty---initVty :: IO Vty-initVty = do- cfg <- Vty.standardIOConfig- fdIn <- ttyIn- fdOut <- ttyOut- Vty.mkVty (cfg { Vty.inputFd = Just fdIn , Vty.outputFd = Just fdOut })--ttyIn, ttyOut :: IO Fd--- | Opens @/dev/tty@ read-only. Should be connected to the @stdin@ of--- a GUI process (e. g. 'Vty.Vty').-ttyIn = openFd "/dev/tty" ReadOnly Nothing defaultFileFlags--- | Opens @/dev/tty@ write-only. Should be connected to the @stdout@ of--- a GUI process (e. g. 'Vty.Vty').-ttyOut = openFd "/dev/tty" WriteOnly Nothing defaultFileFlags
+ src/Vgrep/App/Internal.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+module Vgrep.App.Internal where++import Control.Concurrent.Async+import Control.Exception+import Graphics.Vty (Vty)+import qualified Graphics.Vty as Vty+import Pipes hiding (next)+import System.Posix.IO+import System.Posix.Types (Fd)++import Vgrep.Type+++-- | 'User' events do have higher priority than 'System' events, so that+-- the application stays responsive even in case of event queue congestion.+data EventPriority = User | System deriving (Eq, Ord, Enum)+++-- | We need the viewport in order to initialize the app, which in turn will+-- start 'Vty.Vty'. To resolve this circular dependency, we start once 'Vty.Vty'+-- in order to determine the display viewport, and shut it down again+-- immediately.+viewportHack :: IO Viewport+viewportHack = withVty $ \vty -> do+ (width, height) <- Vty.displayBounds (Vty.outputIface vty)+ pure Viewport { _vpWidth = width , _vpHeight = height }++-- | Spawns a thread parallel to the action that listens to 'Vty' events and+-- redirects them to the 'Consumer'.+withEvThread :: Consumer Vty.Event IO () -> Vty -> VgrepT s IO a -> VgrepT s IO a+withEvThread sink vty =+ vgrepBracket createEvThread cancel . const+ where+ createEvThread = (async . runEffect) $ lift (Vty.nextEvent vty) >~ sink+++-- | Passes a 'Vty' instance to the action and shuts it down properly after the+-- action finishes. The 'Vty.inputFd' and 'Vty.outputFd' handles are connected+-- to @\/dev\/tty@ (see 'tty').+withVty :: (Vty -> IO a) -> IO a+-- | Like 'withVty', but lifted to @'VgrepT' s 'IO'@.+withVgrepVty :: (Vty -> VgrepT s IO a) -> VgrepT s IO a+(withVty, withVgrepVty) =+ let initVty fd = do+ cfg <- Vty.standardIOConfig+ Vty.mkVty cfg { Vty.inputFd = Just fd+ , Vty.outputFd = Just fd }+ in ( \action -> withTty $ \fd -> bracket (initVty fd) Vty.shutdown action+ , \action -> withVgrepTty $ \fd -> vgrepBracket (initVty fd) Vty.shutdown action)+++-- | Passes two file descriptors for read and write access to @\/dev\/tty@ to+-- the action, and closes them after the action has finished.+withTty :: (Fd -> IO a) -> IO a+-- | Like 'withTty', but lifted to @'VgrepT' s 'IO'@.+withVgrepTty :: (Fd -> VgrepT s IO a) -> VgrepT s IO a+(withTty, withVgrepTty) = (bracket before after, vgrepBracket before after)+ where+ before = tty+ after fd = closeFd fd `catch` ignoreIOException+ ignoreIOException :: IOException -> IO ()+ ignoreIOException _ = pure ()++-- | Opens @\/dev\/tty@ in Read/Write mode. Should be connected to the @stdin@ and+-- @stdout@ of a GUI process (e. g. 'Vty.Vty').+tty :: IO Fd+tty = openFd "/dev/tty" ReadWrite Nothing defaultFileFlags
+ src/Vgrep/Command.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+module Vgrep.Command where++import GHC.Generics++data Command+ = DisplayPagerOnly -- ^ Display the pager full-screen+ | DisplayResultsOnly -- ^ Display the results list full-screen+ | SplitFocusPager -- ^ Split screen, focus on pager+ | SplitFocusResults -- ^ Split screen, focus on results list++ | PagerUp -- ^ Scroll one line up in pager+ | PagerDown -- ^ Scroll one line down in pager+ | PagerPageUp -- ^ Scroll one page up in pager+ | PagerPageDown -- ^ Scroll one page down in pager+ | PagerScrollLeft -- ^ Scroll eight characters left in pager+ | PagerScrollRight -- ^ Scroll eight characters right in pager++ | ResultsUp -- ^ Move to previous result+ | ResultsDown -- ^ Move to next result+ | ResultsPageUp -- ^ Move one page up in results list+ | ResultsPageDown -- ^ Move one page down in results list++ | PrevResult -- ^ Move to previous result and update pager+ | NextResult -- ^ Move to next result and update pager+ | PagerGotoResult -- ^ Update pager with currently selected result++ | OpenFileInEditor -- ^ Open file in external editor and jump to+ -- currently selected result++ | Exit -- ^ Exit the application++ | Unset -- ^ Treat keybinding as if not present, fall back to+ -- alternative binding (used to override keybindings)++ deriving (Eq, Show, Generic)
src/Vgrep/Environment.hs view
@@ -1,30 +1,47 @@ {-# LANGUAGE TemplateHaskell #-} module Vgrep.Environment ( Environment (..)+ , Viewport (..) -- * Auto-generated Lenses , config- , region+ , viewport+ , vpHeight+ , vpWidth + -- * Convenience Lenses+ , viewportWidth+ , viewportHeight+ -- * Re-exports , module Vgrep.Environment.Config- , module Graphics.Vty.Prelude ) where -import Control.Lens-import Graphics.Vty.Prelude+import Control.Lens.Compat import Vgrep.Environment.Config +-- | The bounds (width and height) of a display viewport.+data Viewport = Viewport { _vpWidth :: Int, _vpHeight :: Int }+ deriving (Eq, Show)++makeLenses ''Viewport++ -- | 'Vgrep.Type.VgrepT' actions can read from the environment. data Environment = Env- { _config :: Config+ { _config :: Config -- ^ External configuration (colors, editor executable, …) - , _region :: DisplayRegion- -- ^ The bounds (width and height) of the display region where the+ , _viewport :: Viewport+ -- ^ The bounds (width and height) of the display viewport where the -- 'Vgrep.App.App' or the current 'Vgrep.Widget.Widget' is displayed } deriving (Eq, Show) makeLenses ''Environment+++viewportHeight, viewportWidth :: Lens' Environment Int+viewportHeight = viewport . vpHeight+viewportWidth = viewport . vpWidth
src/Vgrep/Environment/Config.hs view
@@ -1,27 +1,48 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Vgrep.Environment.Config where -import Control.Lens-import Data.Maybe-import Graphics.Vty.Image-import System.Environment+import Control.Lens.Compat+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Graphics.Vty.Image+ ( Attr+ , blue+ , bold+ , defAttr+ , green+ , standout+ , withBackColor+ , withForeColor+ , withStyle+ ) +import Vgrep.Command+import Vgrep.Environment.Config.Monoid+import Vgrep.Environment.Config.Sources+import qualified Vgrep.Key as Key + -------------------------------------------------------------------------- -- * Types -------------------------------------------------------------------------- data Config = Config- { _colors :: Colors+ { _colors :: Colors -- ^ Color configuration - , _tabstop :: Int+ , _tabstop :: Int -- ^ Tabstop width (default: 8) - , _editor :: String+ , _editor :: String -- ^ Executable for @e@ key (default: environment variable @$EDITOR@, -- or @vi@ if @$EDITOR@ is not set) + , _keybindings :: Keybindings+ } deriving (Eq, Show) data Colors = Colors@@ -46,34 +67,134 @@ } deriving (Eq, Show) +data Keybindings = Keybindings+ { _resultsKeybindings :: Map Key.Chord Command+ -- ^ Keybindings in effect when results list is focused. + , _pagerKeybindings :: Map Key.Chord Command+ -- ^ Keybindings in effect when pager is focused.++ , _globalKeybindings :: Map Key.Chord Command+ -- ^ Global keybindings are in effect both for pager and results list, but+ -- can be overridden by either one.++ } deriving (Eq, Show)++ -------------------------------------------------------------------------- -- * Auto-generated Lenses -------------------------------------------------------------------------- makeLenses ''Config makeLenses ''Colors+makeLenses ''Keybindings --------------------------------------------------------------------------+-- * Read Config from Monoid+--------------------------------------------------------------------------++-- | Convert a 'ConfigMonoid' to a 'Config'. Missing (@'mempty'@) values in the+-- 'ConfigMonoid' are supplied from the 'defaultConfig'.+fromConfigMonoid :: ConfigMonoid -> Config+fromConfigMonoid ConfigMonoid{..} = Config+ { _colors = fromColorsMonoid _mcolors+ , _tabstop = fromFirst (_tabstop defaultConfig) _mtabstop+ , _editor = fromFirst (_editor defaultConfig) _meditor+ , _keybindings = fromKeybindingsMonoid _mkeybindings }++-- | Convert a 'ColorsMonoid' to a 'Colors' config.+fromColorsMonoid :: ColorsMonoid -> Colors+fromColorsMonoid ColorsMonoid{..} = Colors+ { _lineNumbers = fromFirst (_lineNumbers defaultColors) _mlineNumbers+ , _lineNumbersHl = fromFirst (_lineNumbersHl defaultColors) _mlineNumbersHl+ , _normal = fromFirst (_normal defaultColors) _mnormal+ , _normalHl = fromFirst (_normalHl defaultColors) _mnormalHl+ , _fileHeaders = fromFirst (_fileHeaders defaultColors) _mfileHeaders+ , _selected = fromFirst (_selected defaultColors) _mselected }++fromFirst :: a -> First a -> a+fromFirst a = fromMaybe a . getFirst++fromKeybindingsMonoid :: KeybindingsMonoid -> Keybindings+fromKeybindingsMonoid KeybindingsMonoid{..} = Keybindings+ { _resultsKeybindings = fromMaybe mempty _mresultsKeybindings <> _resultsKeybindings defaultKeybindings+ , _pagerKeybindings = fromMaybe mempty _mpagerKeybindings <> _pagerKeybindings defaultKeybindings+ , _globalKeybindings = fromMaybe mempty _mglobalKeybindings <> _globalKeybindings defaultKeybindings }+++-------------------------------------------------------------------------- -- * Default Config -------------------------------------------------------------------------- defaultConfig :: Config defaultConfig = Config- { _colors = Colors- { _lineNumbers = defAttr `withForeColor` blue- , _lineNumbersHl = defAttr `withForeColor` blue- `withStyle` bold- , _normal = defAttr- , _normalHl = defAttr `withStyle` bold- , _fileHeaders = defAttr `withBackColor` green- , _selected = defAttr `withStyle` standout }+ { _colors = defaultColors , _tabstop = 8- , _editor = "vi" }+ , _editor = "vi"+ , _keybindings = defaultKeybindings } -withConfiguredEditor :: Config -> IO Config-withConfiguredEditor config = do- let defaultEditor = view editor config- configuredEditor <- lookupEnv "EDITOR"- pure config { _editor = fromMaybe defaultEditor configuredEditor }+defaultColors :: Colors+defaultColors = Colors+ { _lineNumbers = defAttr `withForeColor` blue+ , _lineNumbersHl = defAttr `withForeColor` blue+ `withStyle` bold+ , _normal = defAttr+ , _normalHl = defAttr `withStyle` bold+ , _fileHeaders = defAttr `withBackColor` green+ , _selected = defAttr `withStyle` standout }++defaultKeybindings :: Keybindings+defaultKeybindings = Keybindings+ { _resultsKeybindings = M.fromList+ [ (Key.key Key.Up, ResultsUp)+ , (Key.key Key.Down, ResultsDown)+ , (Key.key Key.PageUp, ResultsPageUp)+ , (Key.key Key.PageDown, ResultsPageDown)+ , (Key.key Key.Enter, PagerGotoResult)+ , (Key.key (Key.Char 'k'), ResultsUp)+ , (Key.key (Key.Char 'j'), ResultsDown)+ , (Key.key (Key.Char 'f'), DisplayResultsOnly)+ , (Key.key Key.Tab, SplitFocusPager) ]+ , _pagerKeybindings = M.fromList+ [ (Key.key Key.Up, PagerUp)+ , (Key.key Key.Down, PagerDown)+ , (Key.key Key.PageUp, PagerPageUp)+ , (Key.key Key.PageDown, PagerPageDown)+ , (Key.key Key.Left, PagerScrollLeft)+ , (Key.key Key.Right, PagerScrollRight)+ , (Key.key (Key.Char 'k'), PagerUp)+ , (Key.key (Key.Char 'j'), PagerDown)+ , (Key.key (Key.Char 'h'), PagerScrollLeft)+ , (Key.key (Key.Char 'l'), PagerScrollRight)+ , (Key.key (Key.Char 'f'), DisplayPagerOnly)+ , (Key.key Key.Tab, SplitFocusResults)+ , (Key.key (Key.Char 'q'), DisplayResultsOnly) ]+ , _globalKeybindings = M.fromList+ [ (Key.key (Key.Char 'e'), OpenFileInEditor)+ , (Key.key (Key.Char 'q'), Exit) ]+ }+++--------------------------------------------------------------------------+-- * Config Loader+--------------------------------------------------------------------------++-- | Gathers 'ConfigMonoid's from various sources and builds a 'Config'+-- based on the 'defaultConfig':+--+-- * Config from environment variables+-- * The configuration specified in the config file+-- * External config, e.g. from command line+--+-- where the latter ones override the earlier ones.+loadConfig+ :: MonadIO io+ => ConfigMonoid -- ^ External config from command line+ -> io Config+loadConfig configFromArgs = do+ configs <- sequence+ [ pure configFromArgs+ , configFromFile+ , editorConfigFromEnv ]+ pure (fromConfigMonoid (mconcat configs))
+ src/Vgrep/Environment/Config/Monoid.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}+module Vgrep.Environment.Config.Monoid+ ( ConfigMonoid (..)+ , ColorsMonoid (..)+ , KeybindingsMonoid (..)+ ) where++import Data.Map.Strict (Map)+import Data.Monoid+import Generics.Deriving.Monoid (mappenddefault, memptydefault)+import GHC.Generics+import Graphics.Vty.Attributes (Attr)++import Vgrep.Command+import qualified Vgrep.Key as Key++-- $setup+-- >>> import Data.Map.Strict++-- | A 'Monoid' for reading partial configs. The 'ConfigMonoid' can be converted+-- to an actual 'Vgrep.Environment.Config.Config' using+-- 'Vgrep.Environment.Config.fromConfigMonoid'.+--+-- The Monoid consists mostly of 'First a' values, so the most important config+-- (the one that overrides all the others) should be read first.+data ConfigMonoid = ConfigMonoid+ { _mcolors :: ColorsMonoid+ , _mtabstop :: First Int+ , _meditor :: First String+ , _mkeybindings :: KeybindingsMonoid+ } deriving (Eq, Show, Generic)++instance Monoid ConfigMonoid where+ mempty = memptydefault+ mappend = mappenddefault+++-- | A 'Monoid' for reading partial 'Vgrep.Environment.Config.Colors'+-- configurations.+--+-- Note that the attributes are not merged, but overridden:+--+-- >>> import Graphics.Vty.Attributes+-- >>> let leftStyle = defAttr `withStyle` standout+-- >>> let rightStyle = defAttr `withForeColor` black+-- >>> let l = mempty { _mnormal = First (Just leftStyle)}+-- >>> let r = mempty { _mnormal = First (Just rightStyle)}+-- >>> _mnormal (l <> r) == First (Just (leftStyle <> rightStyle))+-- False+-- >>> _mnormal (l <> r) == First (Just leftStyle)+-- True+data ColorsMonoid = ColorsMonoid+ { _mlineNumbers :: First Attr+ , _mlineNumbersHl :: First Attr+ , _mnormal :: First Attr+ , _mnormalHl :: First Attr+ , _mfileHeaders :: First Attr+ , _mselected :: First Attr+ } deriving (Eq, Show, Generic)++instance Monoid ColorsMonoid where+ mempty = memptydefault+ mappend = mappenddefault+++-- | A 'Monoid' for reading a partial 'Vgrep.Environment.Config.Keybindings'+-- configuration.+--+-- Mappings are combined using left-biased 'Data.Map.Strict.union':+--+-- >>> let l = Just (fromList [(Key.Chord mempty Key.Down, ResultsDown), (Key.Chord mempty Key.Up, ResultsUp)])+-- >>> let r = Just (fromList [(Key.Chord mempty Key.Down, PagerDown)])+-- >>> l <> r+-- Just (fromList [(Chord (fromList []) Up,ResultsUp),(Chord (fromList []) Down,ResultsDown)])+-- >>> r <> l+-- Just (fromList [(Chord (fromList []) Up,ResultsUp),(Chord (fromList []) Down,PagerDown)])+--+-- In particular, @'Just' ('Data.Map.Strict.fromList' [])@ (declaring an empty+-- list of mappings) and @'Nothing'@ (not declaring anything) are equivalent,+-- given that there are already default mappings:+--+-- >>> l <> Just (fromList []) == l <> Nothing+-- True+--+-- This means that new keybindings override the previous ones if they collide,+-- otherwise they are simply added. To remove a keybinding, it has to be mapped+-- to 'Unset' explicitly.+data KeybindingsMonoid = KeybindingsMonoid+ { _mresultsKeybindings :: Maybe (Map Key.Chord Command)+ , _mpagerKeybindings :: Maybe (Map Key.Chord Command)+ , _mglobalKeybindings :: Maybe (Map Key.Chord Command)+ } deriving (Eq, Show, Generic)++instance Monoid KeybindingsMonoid where+ mempty = memptydefault+ mappend = mappenddefault
+ src/Vgrep/Environment/Config/Sources.hs view
@@ -0,0 +1,8 @@+module Vgrep.Environment.Config.Sources+ ( module Vgrep.Environment.Config.Sources.Env+ , module Vgrep.Environment.Config.Sources.File+ ) where++import Vgrep.Environment.Config.Sources.Env (editorConfigFromEnv)+import Vgrep.Environment.Config.Sources.File (configFromFile)+
+ src/Vgrep/Environment/Config/Sources/Env.hs view
@@ -0,0 +1,15 @@+module Vgrep.Environment.Config.Sources.Env where++import Control.Monad.IO.Class+import Data.Monoid+import System.Environment++import Vgrep.Environment.Config.Monoid+++-- | Determines the 'ConfigMonoid' value for 'Vgrep.Environment.Config._editor'+-- ('_meditor') from the environment variable @$EDITOR@.+editorConfigFromEnv :: MonadIO io => io ConfigMonoid+editorConfigFromEnv = do+ configuredEditor <- liftIO (lookupEnv "EDITOR")+ pure (mempty { _meditor = First configuredEditor })
+ src/Vgrep/Environment/Config/Sources/File.hs view
@@ -0,0 +1,346 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of camelTo+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Vgrep.Environment.Config.Sources.File+ ( configFromFile+ , Attr+ , Color+ , Style+ ) where++import Control.Monad ((>=>))+import Control.Monad.IO.Class+import Data.Aeson.Types+ ( Options (..)+ , camelTo+ , defaultOptions+ , genericParseJSON+ , withObject+ )+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Yaml.Aeson+import GHC.Generics+import qualified Graphics.Vty.Attributes as Vty+import System.Directory+import System.IO+import Text.Read (readMaybe)++import Vgrep.Command+import Vgrep.Environment.Config.Monoid+import qualified Vgrep.Key as Key++-- $setup+-- >>> import Data.List (isInfixOf)+++{- |+Reads the configuration from a JSON or YAML file. The file should be+located in one of the following places:++* @~\/.vgrep\/config.yaml@,+* @~\/.vgrep\/config.yml@,+* @~\/.vgrep\/config.json@ or+* @~\/.vgrep\/config@.++When none of these files exist, no error is raised. When a file exists, but+cannot be parsed, a warning is written to stderr.++Supported formats are JSON and YAML. The example YAML config given in the+project directory (@config.yaml.example@) is equivalent to the default+config:++>>> import qualified Vgrep.Environment.Config as C+>>> Right config <- decodeFileEither "config.yaml.example" :: IO (Either ParseException ConfigMonoid)+>>> C.fromConfigMonoid config == C.defaultConfig+True++Example YAML config file for 'Vgrep.Environment.Config.defaultConfig':++> colors:+> line-numbers:+> fore-color: blue+> line-numbers-hl:+> fore-color: blue+> style: bold+> normal:+> normal-hl:+> style: bold+> file-headers:+> back-color: green+> selected:+> style: standout+> tabstop: 8+> editor: "vi"++Example JSON file for the same config:++> {+> "colors": {+> "line-numbers" : {+> "fore-color": "blue"+> },+> "line-numbers-hl": {+> "fore-color": "blue",+> "style": "bold"+> },+> "normal": {},+> "normal-hl": {+> "style": "bold"+> },+> "file-headers": {+> "back-color": "green"+> },+> "selected": {+> "style": "standout"+> }+> },+> "tabstop": 8,+> "editor": "vi"+> }++The JSON/YAML keys correspond to the lenses in "Vgrep.Environment.Config",+the values for 'Vty.Color' and 'Vty.Style' can be obtained from the+corresponding predefined constants in "Graphics.Vty.Attributes".+-}+configFromFile :: MonadIO io => io ConfigMonoid+configFromFile = liftIO $ do+ configDir <- getAppUserDataDirectory "vgrep"+ let configFiles = map (configDir </>)+ [ "config.yaml"+ , "config.yml"+ , "config.json"+ , "config" ]+ findExistingFile configFiles >>= \case+ Nothing -> pure mempty+ Just configFile -> decodeFileEither configFile >>= \case+ Right config -> pure config+ Left err -> do+ hPutStrLn stderr $+ "Could not parse config file " ++ configFile ++ ":"+ ++ "\n" ++ prettyPrintParseException err+ ++ "\nFalling back to default config."+ pure mempty+ where+ findExistingFile :: [FilePath] -> IO (Maybe FilePath)+ findExistingFile = \case+ [] -> pure Nothing+ f : fs -> do+ exists <- doesFileExist f+ if exists then pure (Just f) else findExistingFile fs++ (</>) :: FilePath -> FilePath -> FilePath+ dir </> file = dir <> "/" <> file+++instance FromJSON ConfigMonoid where+ parseJSON = withObject "ConfigMonoid" $ \o -> do+ _mcolors <- o .:? "colors" .!= mempty+ _mtabstop <- fmap First (o .:? "tabstop")+ _meditor <- fmap First (o .:? "editor")+ _mkeybindings <- o .:? "keybindings" .!= mempty+ pure ConfigMonoid{..}++instance FromJSON ColorsMonoid where+ parseJSON = genericParseJSON jsonOptions++instance FromJSON Vty.Attr where+ parseJSON = fmap attrToVty . parseJSON+++{- |+A JSON-parsable data type for 'Vty.Attr'.++JSON example:++>>> decodeEither "{\"fore-color\": \"black\", \"style\": \"standout\"}" :: Either String Attr+Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout})++JSON example without quotes:+>>> decodeEither "{fore-color: black, style: standout}" :: Either String Attr+Right (Attr {foreColor = Just Black, backColor = Nothing, style = Just Standout})++YAML example:++>>> :{+>>> decodeEither+>>> $ "fore-color: \"blue\"\n"+>>> <> "back-color: \"bright-blue\"\n"+>>> <> "style: \"reverse-video\"\n"+>>> :: Either String Attr+>>> :}+Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo})++YAML example without quotes:++>>> :{+>>> decodeEither+>>> $ "fore-color: blue\n"+>>> <> "back-color: bright-blue\n"+>>> <> "style: reverse-video\n"+>>> :: Either String Attr+>>> :}+Right (Attr {foreColor = Just Blue, backColor = Just BrightBlue, style = Just ReverseVideo})+-}+data Attr = Attr+ { foreColor :: Maybe Color+ , backColor :: Maybe Color+ , style :: Maybe Style+ }+ deriving (Eq, Show, Generic)++instance FromJSON Attr where+ parseJSON = genericParseJSON jsonOptions++attrToVty :: Attr -> Vty.Attr+attrToVty Attr{..} = foldAttrs+ [ fmap (flip Vty.withForeColor . colorToVty) foreColor+ , fmap (flip Vty.withBackColor . colorToVty) backColor+ , fmap (flip Vty.withStyle . styleToVty) style ]+ where+ foldAttrs = foldr ($) Vty.defAttr . catMaybes+++{- |+A JSON-parsable data type for 'Vty.Color'.++>>> decodeEither "[\"black\",\"red\",\"bright-black\"]" :: Either String [Color]+Right [Black,Red,BrightBlack]++Also works without quotes:++>>> decodeEither "[black,red,bright-black]" :: Either String [Color]+Right [Black,Red,BrightBlack]++Fails with error message if the 'Color' cannot be parsed:++>>> let Left err = decodeEither "foo" :: Either String Color+>>> "The key \"foo\" was not found" `isInfixOf` err+True+-}+data Color+ = Black+ | Red+ | Green+ | Yellow+ | Blue+ | Magenta+ | Cyan+ | White+ | BrightBlack+ | BrightRed+ | BrightGreen+ | BrightYellow+ | BrightBlue+ | BrightMagenta+ | BrightCyan+ | BrightWhite+ deriving (Eq, Show, Generic)++instance FromJSON Color where+ parseJSON = genericParseJSON jsonOptions++colorToVty :: Color -> Vty.Color+colorToVty = \case+ Black -> Vty.black+ Red -> Vty.red+ Green -> Vty.green+ Yellow -> Vty.yellow+ Blue -> Vty.blue+ Magenta -> Vty.magenta+ Cyan -> Vty.cyan+ White -> Vty.white+ BrightBlack -> Vty.brightBlack+ BrightRed -> Vty.brightRed+ BrightGreen -> Vty.brightGreen+ BrightYellow -> Vty.brightYellow+ BrightBlue -> Vty.brightBlue+ BrightMagenta -> Vty.brightMagenta+ BrightCyan -> Vty.brightCyan+ BrightWhite -> Vty.brightWhite+++{- |+A JSON-parsable data type for 'Vty.Style'.++>>> decodeEither "[\"standout\", \"underline\", \"bold\"]" :: Either String [Style]+Right [Standout,Underline,Bold]++Also works without quotes:++>>> decodeEither "[standout, underline, bold]" :: Either String [Style]+Right [Standout,Underline,Bold]++Fails with error message if the 'Style' cannot be parsed:++>>> let Left err = decodeEither "foo" :: Either String Style+>>> "The key \"foo\" was not found" `isInfixOf` err+True+-}+data Style+ = Standout+ | Underline+ | ReverseVideo+ | Blink+ | Dim+ | Bold+ deriving (Eq, Show, Generic)++instance FromJSON Style where+ parseJSON = genericParseJSON jsonOptions++styleToVty :: Style -> Vty.Style+styleToVty = \case+ Standout -> Vty.standout+ Underline -> Vty.underline+ ReverseVideo -> Vty.reverseVideo+ Blink -> Vty.blink+ Dim -> Vty.dim+ Bold -> Vty.bold+++instance FromJSON KeybindingsMonoid where+ parseJSON = genericParseJSON jsonOptions++instance FromJSON Command where+ parseJSON = genericParseJSON jsonOptions++instance FromJSON (Map Key.Chord Command) where+ parseJSON = parseJSON >=> mapMKeys parseChord++mapMKeys :: (Monad m, Ord k') => (k -> m k') -> Map k v -> m (Map k' v)+mapMKeys f = fmap M.fromList . M.foldrWithKey go (pure [])+ where+ go k x mxs = do+ k' <- f k+ xs <- mxs+ pure ((k', x) : xs)++parseChord :: Monad m => String -> m Key.Chord+parseChord = \case+ 'C' : '-' : t -> fmap (`Key.withModifier` Key.Ctrl) (parseChord t)+ 'S' : '-' : t -> fmap (`Key.withModifier` Key.Shift) (parseChord t)+ 'M' : '-' : t -> fmap (`Key.withModifier` Key.Meta) (parseChord t)+ [c] -> pure (Key.key (Key.Char c))+ "PgUp" -> pure (Key.key Key.PageUp)+ "PgDown" -> pure (Key.key Key.PageDown)+ "PgDn" -> pure (Key.key Key.PageDown)+ s | Just k <- readMaybe s+ -> pure (Key.key k)+ | otherwise -> fail ("Unknown key '" <> s <> "'")++jsonOptions :: Options+jsonOptions = defaultOptions+ { constructorTagModifier = camelTo '-'+ , fieldLabelModifier = camelTo '-' . stripPrefix }+ where+ stripPrefix = \case+ '_' : 'm' : name -> name+ '_' : name -> name+ name -> name
+ src/Vgrep/Key.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Basic definitions for 'Key's, 'Mod'ifiers, and 'Chord's of 'Key's and+-- 'Mod'ifiers. We can read key 'Chord's from "Graphics.Vty" 'Vty.EvKey' events+-- using 'fromVty'.+--+-- This module is intended for qualified import:+--+-- > import qualified Vgrep.Key as Key+--+-- We define our own 'Key' and 'Mod' types rather than using "Graphics.Vty"'s+-- 'Vty.Key' and 'Vty.Modifier', because it simplifies parsing (of keys like+-- 'Space' and 'Tab', which are represented as @' '@ and @'\t'@ in+-- "Graphics.Vty"), and because a 'Set' of 'Mod's is simpler to check for+-- equality than a list of 'Vty.Modifier's.+module Vgrep.Key+ ( Chord (..)+ , Key (..)+ , Mod (..)+ , fromVty+ , key+ , withModifier+ )where++import Prelude hiding (Left, Right)+import Control.Applicative+import Data.Set (Set)+import qualified Data.Set as S+import GHC.Generics+import qualified Graphics.Vty.Input.Events as Vty+++-- | A chord of keys and modifiers pressed simultaneously.+data Chord = Chord (Set Mod) Key+ deriving (Eq, Ord, Show, Generic)++data Key+ = Char Char | Space+ | Esc | Backspace | Enter | Del | Tab+ | Left | Right | Up | Down+ | Home | End | PageUp | PageDown+ deriving (Eq, Ord, Show, Read, Generic)++data Mod+ = Ctrl+ | Meta+ | Shift+ deriving (Eq, Ord, Show, Generic)+++-- | Reads the key and modifiers from an 'Vty.Event'. Non-key events and events+-- with unknown keys are mapped to 'Nothing'.+fromVty :: Vty.Event -> Maybe Chord+fromVty = \case+ Vty.EvKey k ms -> liftA2 Chord (mapModifiers ms) (mapKey k)+ _otherwise -> Nothing++mapModifiers :: [Vty.Modifier] -> Maybe (Set Mod)+mapModifiers = Just . S.fromList . map go+ where+ go = \case+ Vty.MCtrl -> Ctrl+ Vty.MShift -> Shift+ Vty.MMeta -> Meta+ Vty.MAlt -> Meta++mapKey :: Vty.Key -> Maybe Key+mapKey = \case+ Vty.KChar ' ' -> Just Space+ Vty.KEsc -> Just Esc+ Vty.KBS -> Just Backspace+ Vty.KEnter -> Just Enter+ Vty.KDel -> Just Del+ Vty.KChar '\t' -> Just Tab+ Vty.KLeft -> Just Left+ Vty.KRight -> Just Right+ Vty.KUp -> Just Up+ Vty.KDown -> Just Down+ Vty.KHome -> Just Home+ Vty.KEnd -> Just End+ Vty.KPageUp -> Just PageUp+ Vty.KPageDown -> Just PageDown+ Vty.KChar c -> Just (Char c)+ _otherwise -> Nothing+++-- | Build a 'Chord' from a single 'Key'+key :: Key -> Chord+key = Chord S.empty++-- | Add a 'Mod'ifier to a 'Chord'+withModifier :: Chord -> Mod -> Chord+withModifier (Chord ms k) m = Chord (S.insert m ms) k
src/Vgrep/Parser.hs view
@@ -13,7 +13,9 @@ import Data.Text hiding (takeWhile) import Prelude hiding (takeWhile) -import Vgrep.Results+import Vgrep.Ansi (stripAnsi)+import Vgrep.Ansi.Parser (attrChange, parseAnsi)+import Vgrep.Results (File (..), FileLineReference (..), LineReference (..)) -- | Parses lines of 'Text', skipping lines that are not valid @grep@@@ -28,17 +30,23 @@ -- separated by colons: -- -- >>> parseLine "path/to/file:123:foobar"--- Just (FileLineReference {getFile = File {getFileName = "path/to/file"}, getLineReference = LineReference {getLineNumber = Just 123, getLineText = "foobar"}})+-- Just (FileLineReference {_file = File {_fileName = "path/to/file"}, _lineReference = LineReference {_lineNumber = Just 123, _lineText = Text 6 "foobar"}}) -- -- Omitting the line number still produces valid output: -- -- >>> parseLine "path/to/file:foobar"--- Just (FileLineReference {getFile = File {getFileName = "path/to/file"}, getLineReference = LineReference {getLineNumber = Nothing, getLineText = "foobar"}})+-- Just (FileLineReference {_file = File {_fileName = "path/to/file"}, _lineReference = LineReference {_lineNumber = Nothing, _lineText = Text 6 "foobar"}}) -- -- However, an file name must be present: -- -- >>> parseLine "foobar" -- Nothing+--+-- ANSI escape codes in the line text are parsed correctly:+--+-- >>> parseLine "path/to/file:foo\ESC[31mbar\ESC[mbaz"+-- 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}) (Text 3 "bar"),Text 3 "baz"]}})+-- parseLine :: Text -> Maybe FileLineReference parseLine line = case parseOnly lineParser line of Left _ -> Nothing@@ -47,11 +55,11 @@ lineParser :: Parser FileLineReference lineParser = do file <- takeWhile (/= ':') <* char ':'- lineNumber <- optional (decimal <* char ':')+ lineNumber <- optional (skipMany attrChange *> decimal <* skipMany attrChange <* char ':') result <- takeText pure FileLineReference- { getFile = File- { getFileName = file }- , getLineReference = LineReference- { getLineNumber = lineNumber- , getLineText = result } }+ { _file = File+ { _fileName = stripAnsi (parseAnsi file) }+ , _lineReference = LineReference+ { _lineNumber = lineNumber+ , _lineText = parseAnsi result } }
src/Vgrep/Results.hs view
@@ -1,22 +1,39 @@+{-# LANGUAGE TemplateHaskell #-} module Vgrep.Results ( File (..)+ , fileName+ , LineReference (..)+ , lineNumber+ , lineText+ , FileLineReference (..)+ , file+ , lineReference ) where -import Data.Text (Text)+import Control.Lens.TH+import Data.Text (Text) +import Vgrep.Ansi (AnsiFormatted) + newtype File = File- { getFileName :: Text+ { _fileName :: Text } deriving (Eq, Show) +makeLenses ''File+ data LineReference = LineReference- { getLineNumber :: Maybe Int- , getLineText :: Text+ { _lineNumber :: Maybe Int+ , _lineText :: AnsiFormatted } deriving (Eq, Show) +makeLenses ''LineReference+ data FileLineReference = FileLineReference- { getFile :: File- , getLineReference :: LineReference+ { _file :: File+ , _lineReference :: LineReference } deriving (Eq, Show)++makeLenses ''FileLineReference
src/Vgrep/System/Grep.hs view
@@ -11,8 +11,8 @@ import Control.Monad import Control.Monad.IO.Class import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T import Pipes as P import qualified Pipes.Prelude as P import System.Environment (getArgs)@@ -50,7 +50,7 @@ grepPipe :: [String] -> Producer Text IO () -> Producer Text IO () grepPipe args input = do- (hIn, hOut) <- createGrepProcess (lineBuffered : args)+ (hIn, hOut) <- createGrepProcess (lineBuffered : colorized : args) _threadId <- liftIO . forkIO . runEffect $ input >-> textToHandle hIn streamResultsFrom hOut @@ -66,6 +66,7 @@ : withLineNumber : skipBinaryFiles : lineBuffered+ : colorized : args (_hIn, hOut) <- createGrepProcess grepArgs streamResultsFrom hOut@@ -75,12 +76,13 @@ (_, hOut) <- createGrepProcess [version] streamResultsFrom hOut -recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered, version :: String+recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered, colorized, version :: String recursive = "-r" withFileName = "-H" withLineNumber = "-n" skipBinaryFiles = "-I" lineBuffered = "--line-buffered"+colorized = "--color=always" version = "--version"
src/Vgrep/Text.hs view
@@ -2,18 +2,20 @@ module Vgrep.Text ( -- * Utilities for rendering 'Text' -- | Tabs and other characters below ASCII 32 cause problems in- -- "Graphics.Vty", so we expand them to readable characters, e.g. @\\r@- -- to @^13@. Tabs are expanded toh the configured 'tabWidth'.+ -- "Graphics.Vty", so we expand them to readable characters, e.g. @\\r@ to+ -- @^13@. Tabs are expanded to the configured 'Vgrep.Environment._tabstop'. expandForDisplay , expandLineForDisplay+ , expandFormattedLine ) where -import Control.Lens+import Control.Lens.Compat import Control.Monad.Reader.Class import Data.Char-import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T +import Vgrep.Ansi import Vgrep.Environment @@ -22,29 +24,45 @@ :: (Functor f, MonadReader Environment m) => f Text -> m (f Text) expandForDisplay inputLines = do- tabWidth <- view (config . tabstop)- pure (fmap (expandText tabWidth) inputLines)+ tw <- tabWidth+ pure (fmap (expandText tw) inputLines) -- | Expand a single line expandLineForDisplay :: MonadReader Environment m => Text -> m Text expandLineForDisplay inputLine = do- tabWidth <- view (config . tabstop)- pure (expandText tabWidth inputLine)+ tw <- tabWidth+ pure (expandText tw inputLine) -expandText :: Int -> Text -> Text-expandText tabWidth =- T.pack . expandSpecialChars . expandTabs tabWidth . T.unpack+-- | Expand an ANSI formatted line+expandFormattedLine :: MonadReader Environment m => Formatted a -> m (Formatted a)+expandFormattedLine inputLine = do+ tw <- tabWidth+ pure (mapTextWithPos (expandTextAt tw . Position) inputLine) -expandTabs :: Int -> String -> String-expandTabs tabWidth = go 0++newtype TabWidth = TabWidth Int+newtype Position = Position Int++tabWidth :: MonadReader Environment m => m TabWidth+tabWidth = view (config . tabstop . to TabWidth)++expandText :: TabWidth -> Text -> Text+expandText tw = expandTextAt tw (Position 0)++expandTextAt :: TabWidth -> Position -> Text -> Text+expandTextAt tw pos =+ T.pack . expandSpecialChars . expandTabs tw pos . T.unpack++expandTabs :: TabWidth -> Position -> String -> String+expandTabs (TabWidth tw) (Position p) = go p where go pos (c:cs)- | c == '\t' = let shift = tabWidth - (pos `mod` tabWidth)+ | c == '\t' = let shift = tw - (pos `mod` tw) in replicate shift ' ' ++ go (pos + shift) cs | otherwise = c : go (pos + 1) cs go _ [] = [] expandSpecialChars :: String -> String expandSpecialChars = \case- c:cs | ord c < 32 -> ['^', chr (ord c + 64)] ++ expandSpecialChars cs- | otherwise -> c : expandSpecialChars cs- [] -> []+ c:cs | ord c < 32 -> ['^', chr (ord c + 64)] ++ expandSpecialChars cs+ | otherwise -> c : expandSpecialChars cs+ [] -> []
src/Vgrep/Widget/HorizontalSplit.hs view
@@ -22,10 +22,9 @@ , rightWidgetFocused ) where -import Control.Lens-import Data.Monoid-import Graphics.Vty.Image hiding (resize)-import Graphics.Vty.Input+import Control.Applicative (liftA2)+import Control.Lens.Compat+import Graphics.Vty.Image hiding (resize) import Vgrep.Environment import Vgrep.Event@@ -45,26 +44,14 @@ -- * __Drawing the Widgets__ -- -- Drawing is delegated to the child widgets in a local environment--- reduced to thir respective 'DisplayRegion'.------ * __Default keybindings__------ Events are routed to the focused widget. Additionally, the--- following keybindings are defined:------ @--- Tab 'switchFocus'--- f full screen ('leftOnly' / 'rightOnly')--- q close right widget ('leftOnly' if right widget is focused)--- @+-- reduced to thir respective 'Viewport'. hSplitWidget :: Widget s -> Widget t -> HSplitWidget s t hSplitWidget left right = Widget { initialize = initHSplit left right- , draw = drawWidgets left right- , handle = handleEvents left right }+ , draw = drawWidgets left right } initHSplit :: Widget s -> Widget t -> HSplit s t initHSplit left right = HSplit@@ -121,7 +108,7 @@ -> VgrepT s m Image -> VgrepT (HSplit s t) m Image runInLeftWidget ratio action =- let leftRegion = over (region . _1) $ \w ->+ let leftRegion = over viewportWidth $ \w -> ceiling (ratio * fromIntegral w) in zoom leftWidget (local leftRegion action) @@ -132,40 +119,6 @@ -> VgrepT t m Image -> VgrepT (HSplit s t) m Image runInRightWidget ratio action =- let rightRegion = over (region . _1) $ \w ->+ let rightRegion = over viewportWidth $ \w -> floor ((1-ratio) * fromIntegral w) in zoom rightWidget (local rightRegion action)---- --------------------------------------------------------------------------- Events & Keybindings--- ---------------------------------------------------------------------------- FIXME: local region!-handleEvents- :: Monad m- => Widget s- -> Widget t- -> Event- -> HSplit s t- -> Next (VgrepT (HSplit s t) m Redraw)-handleEvents left right e s = case view currentWidget s of- Left ls -> hSplitKeyBindingsLeft e <> fmap (zoom leftWidget) (handle left e ls)- Right rs -> hSplitKeyBindingsRight e <> fmap (zoom rightWidget) (handle right e rs)--hSplitKeyBindingsLeft- :: Monad m- => Event- -> Next (VgrepT (HSplit s t) m Redraw)-hSplitKeyBindingsLeft = dispatchMap $ fromList- [ (EvKey (KChar '\t') [], switchFocus)- , (EvKey (KChar 'f') [], leftOnly) ]--hSplitKeyBindingsRight- :: Monad m- => Event- -> Next (VgrepT (HSplit s t) m Redraw)-hSplitKeyBindingsRight = dispatchMap $ fromList- [ (EvKey (KChar '\t') [], switchFocus)- , (EvKey (KChar 'q') [], leftOnly)- , (EvKey (KChar 'f') [], rightOnly) ]-
src/Vgrep/Widget/HorizontalSplit/Internal.hs view
@@ -19,8 +19,8 @@ , (%) ) where -import Control.Lens-import Data.Ratio ((%))+import Control.Lens.Compat+import Data.Ratio ((%)) -- $setup
src/Vgrep/Widget/Pager.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Vgrep.Widget.Pager ( -- * Pager widget pagerWidget@@ -15,17 +16,18 @@ , replaceBufferContents ) where -import Control.Lens hiding ((:<), (:>))+import Control.Applicative (liftA2)+import Control.Lens.Compat hiding ((:<), (:>)) import Data.Foldable-import Data.Sequence (Seq, (><))-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Graphics.Vty.Image hiding (resize)-import Graphics.Vty.Input-import Graphics.Vty.Prelude+import qualified Data.IntMap.Strict as Map+import Data.Monoid ((<>))+import Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Text as T+import Graphics.Vty.Image hiding (resize) +import Vgrep.Ansi import Vgrep.Environment import Vgrep.Event import Vgrep.Type@@ -48,57 +50,32 @@ -- adjusted until either the screen is filled, or the first line is -- reached. Highlighted lines are displayed according to the config -- values 'normalHl' and 'lineNumbersHl' (default: bold).------ * __Default keybindings__------ @--- ←↓↑→, hjkl 'hScroll' (-1), 'scroll' 1, 'scroll' (-1), 'hScroll' 1--- PgUp, PgDn 'scrollPage' (-1), 'scrollPage' 1--- @ pagerWidget :: PagerWidget pagerWidget = Widget { initialize = initPager- , draw = renderPager- , handle = fmap const pagerKeyBindings }+ , draw = renderPager } initPager :: Pager initPager = Pager { _column = 0- , _highlighted = Set.empty+ , _highlighted = Map.empty , _above = Seq.empty , _visible = Seq.empty } -pagerKeyBindings- :: Monad m- => Event- -> Next (VgrepT Pager m Redraw)-pagerKeyBindings = dispatchMap $ fromList- [ (EvKey KUp [], scroll up )- , (EvKey KDown [], scroll down )- , (EvKey (KChar 'k') [], scroll up )- , (EvKey (KChar 'j') [], scroll down )- , (EvKey KLeft [], hScroll left )- , (EvKey KRight [], hScroll right )- , (EvKey (KChar 'h') [], hScroll left )- , (EvKey (KChar 'l') [], hScroll right )- , (EvKey KPageUp [], scrollPage up )- , (EvKey KPageDown [], scrollPage down) ]- where up = -1; down = 1; left = -1; right = 1- -- | Replace the currently displayed text. replaceBufferContents :: Monad m => Seq Text -- ^ Lines of text to display in the pager (starting with line 1)- -> [Int] -- ^ List of line numbers that should be highlighted+ -> Map.IntMap AnsiFormatted -- ^ Line numbers and formatted text for highlighted lines -> VgrepT Pager m () replaceBufferContents newContent newHighlightedLines = put initPager { _visible = newContent- , _highlighted = Set.fromList newHighlightedLines }+ , _highlighted = newHighlightedLines } -- | Scroll to the given line number. moveToLine :: Monad m => Int -> VgrepT Pager m Redraw-moveToLine n = views region regionHeight >>= \height -> do+moveToLine n = view viewportHeight >>= \height -> do setPosition (n - height `div` 2) pure Redraw @@ -113,7 +90,7 @@ pure Redraw setPosition :: Monad m => Int -> VgrepT Pager m ()-setPosition n = views region regionHeight >>= \height -> do+setPosition n = view viewportHeight >>= \height -> do allLines <- liftA2 (+) (uses visible length) (uses above length) let newPosition = if | n < 0 || allLines < height -> 0@@ -131,10 +108,9 @@ -- > scrollPage (-1) -- scroll one page up -- > scrollPage 1 -- scroll one page down scrollPage :: Monad m => Int -> VgrepT Pager m Redraw-scrollPage n = view region >>= \displayRegion ->- let height = regionHeight displayRegion- in scroll (n * (height - 1))- -- gracefully leave one ^ line on the screen+scrollPage n = view viewportHeight >>= \height ->+ scroll (n * (height - 1))+ -- gracefully leave one ^ line on the screen -- | Horizontal scrolling. Increment is one 'tabstop'. --@@ -155,25 +131,49 @@ textColorHl <- view (config . colors . normalHl) lineNumberColor <- view (config . colors . lineNumbers) lineNumberColorHl <- view (config . colors . lineNumbersHl)- (width, height) <- view region+ width <- view viewportWidth+ height <- view viewportHeight startPosition <- use position startColumn <- use (column . to fromIntegral) visibleLines <- use (visible . to (Seq.take height) . to toList) highlightedLines <- use highlighted - let renderLine (num, txt) =- let (numColor, txtColor) = if num `Set.member` highlightedLines- then (lineNumberColorHl, textColorHl)- else (lineNumberColor, textColor)- visibleCharacters = T.unpack (T.drop startColumn txt)- in ( string numColor (padWithSpace (show num))- , string txtColor (padWithSpace visibleCharacters) )-- (renderedLineNumbers, renderedTextLines)- = over both fold . unzip+ let (renderedLineNumbers, renderedTextLines)+ = over both fold+ . unzip . map renderLine $ zip [startPosition+1..] visibleLines+ where+ renderLine :: (Int, Text) -> (Image, Image)+ renderLine (num, txt) = case Map.lookup num highlightedLines of+ Just formatted -> ( renderLineNumber lineNumberColorHl num+ , renderFormatted textColorHl formatted )+ Nothing -> ( renderLineNumber lineNumberColor num+ , renderLineText textColor txt ) - pure (resizeWidth width (renderedLineNumbers <|> renderedTextLines))+ renderLineNumber :: Attr -> Int -> Image+ renderLineNumber attr+ = text' attr+ . (`snoc` ' ')+ . cons ' '+ . T.pack+ . show - where padWithSpace s = ' ' : s ++ " "+ renderLineText :: Attr -> Text -> Image+ renderLineText attr+ = text' attr+ . T.justifyLeft width ' '+ . T.take width+ . cons ' '+ . T.drop startColumn++ renderFormatted :: Attr -> AnsiFormatted -> Image+ renderFormatted attr+ = renderAnsi attr+ . padFormatted width ' '+ . takeFormatted width+ . (bare " " <>)+ . dropFormatted startColumn+++ pure (resizeWidth width (renderedLineNumbers <|> renderedTextLines))
src/Vgrep/Widget/Pager/Internal.hs view
@@ -12,25 +12,27 @@ , highlighted ) where -import Control.Lens-import Data.Sequence (Seq)-import Data.Set (Set)-import Data.Text (Text)+import Control.Lens.Compat+import Data.IntMap.Strict (IntMap)+import Data.Sequence (Seq)+import Data.Text (Text) +import Vgrep.Ansi + -- | Keeps track of the lines of text to display, the current scroll -- positions, and the set of highlighted line numbers. data Pager = Pager- { _column :: Int+ { _column :: Int -- ^ The current column offset for horizontal scrolling - , _highlighted :: Set Int+ , _highlighted :: IntMap AnsiFormatted -- ^ Set of line numbers that are highlighted (i.e. they contain matches) - , _above :: Seq Text+ , _above :: Seq Text -- ^ Zipper: Lines above the screen - , _visible :: Seq Text+ , _visible :: Seq Text -- ^ Zipper: Lines on screen and below } deriving (Eq, Show)
src/Vgrep/Widget/Results.hs view
@@ -20,25 +20,23 @@ -- ** Lenses , currentFileName , currentLineNumber- , currentFileResultLineNumbers+ , currentFileResults -- * Re-exports , module Vgrep.Results ) where import Control.Applicative-import Control.Lens+import Control.Lens.Compat import Control.Monad.State.Extended import Data.Foldable import Data.Maybe import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T import Graphics.Vty.Image hiding ((<|>))-import Graphics.Vty.Input-import Graphics.Vty.Prelude-import Prelude +import Vgrep.Ansi import Vgrep.Environment import Vgrep.Event import Vgrep.Results@@ -64,37 +62,15 @@ -- be selected with the cursor, the file group headers are skipped. -- When only part of a file group is shown at the top of the screen, -- the header is shown nevertheless.------ * __Default keybindings__------ @--- jk, ↓↑ 'nextLine', 'prevLine'--- PgDn, PgUp 'pageDown', 'pageUp'--- @ resultsWidget :: ResultsWidget resultsWidget = Widget { initialize = initResults- , draw = renderResultList- , handle = fmap const resultsKeyBindings }+ , draw = renderResultList } initResults :: Results initResults = EmptyResults -resultsKeyBindings- :: Monad m- => Event- -> Next (VgrepT Results m Redraw)-resultsKeyBindings = dispatchMap $ fromList- [ (EvKey KPageUp [], pageUp >> pure Redraw)- , (EvKey KPageDown [], pageDown >> pure Redraw)- , (EvKey KPageUp [], pageUp >> pure Redraw)- , (EvKey KPageDown [], pageDown >> pure Redraw)- , (EvKey KUp [], prevLine >> pure Redraw)- , (EvKey KDown [], nextLine >> pure Redraw)- , (EvKey (KChar 'k') [], prevLine >> pure Redraw)- , (EvKey (KChar 'j') [], nextLine >> pure Redraw) ] - -- | Add a line to the results list. If the result is found in the same -- file as the current last result, it will be added to the same results -- group, otherwise a new group will be opened.@@ -143,15 +119,16 @@ renderResultList = do void resizeToWindow visibleLines <- use (to toLines)- width <- views region regionWidth+ width <- view viewportWidth let render = renderLine width (lineNumberWidth visibleLines) renderedLines <- traverse render visibleLines pure (vertCat renderedLines) where lineNumberWidth = foldl' max 0 . map (twoExtraSpaces . length . show)- . mapMaybe lineNumber- twoExtraSpaces = (+ 2)+ . mapMaybe displayLineNumber+ twoExtraSpaces = (+ 2) -- because line numbers are padded,+ -- see `justifyRight` below renderLine :: Monad m@@ -165,9 +142,9 @@ resultLineStyle <- view (config . colors . normal) selectedStyle <- view (config . colors . selected) pure $ case displayLine of- FileHeader (File file)- -> renderFileHeader fileHeaderStyle file- Line (LineReference n t)+ FileHeader (File f)+ -> renderFileHeader fileHeaderStyle f+ Line (LineReference n t) -> horizCat [ renderLineNumber lineNumberStyle n , renderLineText resultLineStyle t ] SelectedLine (LineReference n t)@@ -187,14 +164,16 @@ . justifyRight lineNumberWidth . maybe "" (T.pack . show) - renderLineText :: Attr -> Text -> Image- renderLineText attr = text' attr- . padWithSpace (width - lineNumberWidth)-+ renderLineText :: Attr -> AnsiFormatted -> Image+ renderLineText attr txt+ = renderAnsi attr+ . takeFormatted (width - lineNumberWidth)+ . padFormatted (width - lineNumberWidth) ' '+ $ cat [ bare " ", txt, bare (T.replicate width " ") ] resizeToWindow :: Monad m => VgrepT Results m Redraw resizeToWindow = do- height <- views region regionHeight+ height <- view viewportHeight currentBuffer <- get case Internal.resize height currentBuffer of Just resizedBuffer -> put resizedBuffer >> pure Redraw
src/Vgrep/Widget/Results/Internal.hs view
@@ -5,7 +5,7 @@ -- * Lenses , currentFileName , currentLineNumber- , currentFileResultLineNumbers+ , currentFileResults -- * Actions -- | In general, actions return @'Just' newResults@ if the buffer has@@ -20,13 +20,15 @@ -- * Utilities for displaying , DisplayLine(..) , toLines- , lineNumber+ , displayLineNumber ) where import Control.Applicative-import Control.Lens (Getter, pre, to, _Just)+import Control.Lens.Compat (Getter, pre, to, view, _Just) import Data.Foldable import Data.Function+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as Map import Data.List (groupBy) import Data.Maybe import Data.Monoid@@ -40,9 +42,10 @@ , (|>) ) import qualified Data.Sequence as S-import Data.Text (Text)+import Data.Text (Text) import Prelude hiding (reverse) +import Vgrep.Ansi (AnsiFormatted) import Vgrep.Results @@ -170,24 +173,24 @@ where linesBefore = case viewl bs of- b :< _ | b `pointsToSameFile` c -> go (S.reverse bs)- _otherwise -> go (S.reverse bs) <> header c+ b :< _ | b `pointsToSameFile` c -> go (S.reverse bs)+ _otherwise -> go (S.reverse bs) <> header c linesAfter = case viewl ds of- d :< _ | c `pointsToSameFile` d -> drop 1 (go ds)- _otherwise -> go ds+ d :< _ | c `pointsToSameFile` d -> drop 1 (go ds)+ _otherwise -> go ds go refs = do fileResults <- groupBy pointsToSameFile (toList refs)- header (head fileResults) <> fmap (Line . getLineReference) fileResults+ header (head fileResults) <> fmap (Line . view lineReference) fileResults - header = pure . FileHeader . getFile- selected = pure . SelectedLine . getLineReference- pointsToSameFile = (==) `on` getFile+ header = pure . FileHeader . view file+ selected = pure . SelectedLine . view lineReference+ pointsToSameFile = (==) `on` view file -- | The line number of a 'DisplayLine'. 'Nothing' for 'FileHeader's.-lineNumber :: DisplayLine -> Maybe Int-lineNumber = \case+displayLineNumber :: DisplayLine -> Maybe Int+displayLineNumber = \case FileHeader _ -> Nothing Line (LineReference n _) -> n SelectedLine (LineReference n _) -> n@@ -196,12 +199,12 @@ -- | The file name of the currently selected item currentFileName :: Getter Results (Maybe Text) currentFileName =- pre (to current . _Just . to getFile . to getFileName)+ pre (to current . _Just . file . fileName) -- | The line number of the currently selected item currentLineNumber :: Getter Results (Maybe Int) currentLineNumber =- pre (to current . _Just . to getLineReference . to getLineNumber . _Just)+ pre (to current . _Just . lineReference . lineNumber . _Just) current :: Results -> Maybe FileLineReference current = \case@@ -210,14 +213,15 @@ -- | The line numbers with matches in the file of the currentliy selected -- item-currentFileResultLineNumbers :: Getter Results [Int]-currentFileResultLineNumbers =- to (mapMaybe getLineNumber . currentFile)+currentFileResults :: Getter Results (IntMap AnsiFormatted)+currentFileResults =+ to (Map.fromList . lineReferencesInCurrentFile) where- currentFile = do- let sameFileAs = (==) `on` getFile+ lineReferencesInCurrentFile = do+ let sameFileAs = (==) `on` view file inCurrentFile <- sameFileAs . fromJust . current- map getLineReference . filter inCurrentFile . bufferToList+ results <- map (view lineReference) . filter inCurrentFile . bufferToList+ pure [ (ln, txt) | LineReference (Just ln) txt <- results ] bufferToList :: Results -> [FileLineReference] bufferToList = \case
src/Vgrep/Widget/Type.hs view
@@ -8,7 +8,6 @@ ) where import Graphics.Vty.Image (Image)-import Graphics.Vty.Input import Vgrep.Event (Next (..), Redraw (..)) import Vgrep.Type@@ -30,8 +29,4 @@ , draw :: forall m. Monad m => VgrepT s m Image -- ^ Generate a renderable 'Image' from the widget state. The state can -- be modified (e. g. for resizing).-- , handle :: forall m. Monad m => Event -> s -> Next (VgrepT s m Redraw)- -- ^ The default event handler for this 'Widget'. May provide e.g.- -- default keybindings. }
+ stack.yaml view
@@ -0,0 +1,36 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-5.0++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps:+ # We want a recent version of stylish-haskell.+ # This is olny for tooling, so does not affect+ # dependency management.+ - stylish-haskell-0.6.1.0++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 1.0.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]
test/Test/Case.hs view
@@ -19,7 +19,8 @@ , TestTree () ) where -import Control.Lens+import Control.Lens.Compat+import Control.Monad import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck
test/Test/Vgrep/Widget/Pager.hs view
@@ -2,10 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Vgrep.Widget.Pager (test) where -import Control.Lens+import Control.Applicative+import Control.Lens.Compat+import Control.Monad import qualified Data.Sequence as S-import Data.Text.Testable ()-import qualified Data.Text.Testable as T+import Data.Text.Testable ()+import qualified Data.Text.Testable as T import Test.Case import Test.QuickCheck as Q import Test.QuickCheck.Monadic as Q@@ -40,7 +42,7 @@ , assertion = \line -> do pos <- use position let posOnScreen = line - pos- height <- view (region . to regionHeight)+ height <- view viewportHeight pure $ counterexample ("Failed: 0 <= " ++ show posOnScreen ++ " <= " ++ show height) (posOnScreen >= 0 .&&. posOnScreen <= height)@@ -54,7 +56,7 @@ , assertion = const $ do pos <- use position linesVisible <- uses visible length- height <- view (region . to regionHeight)+ height <- view viewportHeight pure (pos >= 0 .&&. linesVisible >= height) } , TestProperty@@ -62,7 +64,7 @@ , testData = arbitrary , testCase = do newContent <- pick (fmap (S.fromList . map T.pack) arbitrary)- run (replaceBufferContents newContent [])+ run (replaceBufferContents newContent mempty) pure newContent , assertion = \expectedContent -> do actualContent <- use visible@@ -76,7 +78,7 @@ && views above length pager == 0 coversScreen :: (Pager, Environment) -> Bool-coversScreen (pager, env) = length (view visible pager) >= view (region . _2) env+coversScreen (pager, env) = length (view visible pager) >= view viewportHeight env atTop :: (Pager, Environment) -> Bool atTop (pager, _env) = view position pager == 0
test/Test/Vgrep/Widget/Results.hs view
@@ -2,7 +2,8 @@ {-# LANGUAGE LambdaCase #-} module Test.Vgrep.Widget.Results (test) where -import Control.Lens (Getter, _1, over, to, view, views)+import Control.Lens.Compat (Getter, over, to, view, _1)+import Control.Monad (void) import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import Data.Monoid ((<>))@@ -79,7 +80,7 @@ Results _ _ _ ds es -> p (length ds + length es) screenHeight :: Environment -> Int-screenHeight = view (region . to regionHeight)+screenHeight = view viewportHeight moveToLastLineOnScreen :: (Results, Environment) -> (Results, Environment) moveToLastLineOnScreen = over _1 $ \case@@ -113,7 +114,7 @@ :: (MonadState Results m, MonadReader Environment m) => m Property assertWidgetFitsOnScreen = do- height <- views region regionHeight+ height <- view viewportHeight linesOnScreen <- numberOfLinesOnScreen pure $ counterexample (show linesOnScreen ++ " > " ++ show height)
test/Vgrep/Environment/Testable.hs view
@@ -7,10 +7,11 @@ import Vgrep.Environment + instance Arbitrary Environment where arbitrary = do width <- arbitrary `suchThat` (> 0) -- FIXME tweak numbers height <- arbitrary `suchThat` (> 0) -- FIXME tweak numbers pure Env- { _region = (width, height)+ { _viewport = Viewport width height , _config = defaultConfig }
test/Vgrep/Widget/Pager/Testable.hs view
@@ -4,7 +4,7 @@ , module Vgrep.Widget.Pager.Internal ) where -import Data.Sequence as Seq (fromList)+import Data.Sequence as Seq (fromList) import Data.Text.Testable () import Test.QuickCheck
test/Vgrep/Widget/Results/Testable.hs view
@@ -8,11 +8,16 @@ import Control.Monad import qualified Data.List as List import qualified Data.Sequence as Seq-import Data.Text (Text)-import qualified Data.Text as Text+import Data.Text (Text)+import qualified Data.Text as Text import Test.QuickCheck -import Vgrep.Widget.Results+import Vgrep.Ansi+import Vgrep.Widget.Results hiding+ ( fileName+ , lineNumber+ , lineReference+ ) import Vgrep.Widget.Results.Internal instance Arbitrary Results where@@ -42,12 +47,15 @@ arbitraryGrepResults = fmap concat . infiniteListOf $ do fileName <- arbitraryText lineReferences <- do- matches <- listOf arbitraryText+ matches <- listOf arbitraryFormattedText lineNumbers <- maybeLineNumbers (length matches) pure (zipWith LineReference lineNumbers matches) pure [ FileLineReference (File fileName) lineReference | lineReference <- lineReferences ] ++arbitraryFormattedText :: Gen (Formatted attr)+arbitraryFormattedText = fmap bare arbitraryText arbitraryText :: Gen Text arbitraryText = fmap Text.pack arbitrary
vgrep.cabal view
@@ -1,5 +1,5 @@ name: vgrep-version: 0.1.4.1+version: 0.2.0.0 synopsis: A pager for grep description: @vgrep@ is a pager for navigating through @grep@ output.@@ -10,7 +10,9 @@ > vgrep foo /some/path > vgrep foo /some/path | vgrep bar .- <<https://raw.githubusercontent.com/fmthoma/vgrep/master/vgrep.png>>+ Use @hjkl@ or arrow keys to navigate, @Enter@ to view file, @q@ to quit.+ .+ <<https://raw.githubusercontent.com/fmthoma/vgrep/master/screenshot.gif>> homepage: http://github.com/fmthoma/vgrep#readme license: BSD3 license-file: LICENSE@@ -19,7 +21,14 @@ copyright: 2016 Franz Thoma category: Web build-type: Simple--- extra-source-files:+extra-source-files: .stylish-haskell.yaml+ , .travis.yml+ , CHANGELOG.md+ , README.md+ , config.yaml.example+ , help.txt+ , screenshot.gif+ , stack.yaml cabal-version: >=1.10 library@@ -28,12 +37,24 @@ default-extensions: LambdaCase , MultiWayIf exposed-Modules: Control.Concurrent.STM.TPQueue+ , Control.Lens.Compat , Control.Monad.State.Extended , Pipes.Concurrent.PQueue+ , Vgrep.Ansi+ , Vgrep.Ansi.Parser+ , Vgrep.Ansi.Type+ , Vgrep.Ansi.Vty.Attributes , Vgrep.App+ , Vgrep.App.Internal+ , Vgrep.Command , Vgrep.Environment , Vgrep.Environment.Config+ , Vgrep.Environment.Config.Monoid+ , Vgrep.Environment.Config.Sources+ , Vgrep.Environment.Config.Sources.Env+ , Vgrep.Environment.Config.Sources.File , Vgrep.Event+ , Vgrep.Key , Vgrep.Parser , Vgrep.Results , Vgrep.System.Grep@@ -48,10 +69,13 @@ , Vgrep.Widget.Results.Internal , Vgrep.Widget.Type build-depends: base >= 4.7 && < 5+ , aeson >= 0.11 || (>= 0.9 && < 0.10) , async >= 2.0.2 , attoparsec >= 0.12.1.6 , containers >= 0.5.6.2+ , directory >= 1.2.2 , fingertree >= 0.1.1+ , generic-deriving >= 1.5.0 , lens >= 4.13 , lifted-base >= 0.2.3.6 , mmorph >= 1.0.4@@ -61,9 +85,10 @@ , process >= 1.2.3 , stm >= 2.4.4 , text >= 1.2.1.3- , transformers >= 0.4.2+ , transformers , unix >= 2.7.1 , vty >= 5.4.0+ , yaml >= 0.8.12 default-language: Haskell2010 executable vgrep@@ -72,7 +97,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-extensions: LambdaCase , MultiWayIf- build-depends: base >= 4.8 && < 5+ build-depends: base >= 4.7 && < 5 , async >= 2.0.2 , cabal-file-th >= 0.2.3 , containers >= 0.5.6.2@@ -82,8 +107,8 @@ , pipes >= 4.1.6 , pipes-concurrency >= 2.0.3 , process >= 1.2.3+ , template-haskell >= 2.10 , text >= 1.2.1.3- , unix >= 2.7.1 , vgrep , vty >= 5.4.0 default-language: Haskell2010