diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -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 diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,78 @@ +`vgrep` -- A pager for `grep` +============================= + +![Screenshot](./screenshot.gif) + +## 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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/config.yaml.example b/config.yaml.example new file mode 100644 --- /dev/null +++ b/config.yaml.example @@ -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 diff --git a/help.txt b/help.txt new file mode 100644 --- /dev/null +++ b/help.txt @@ -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`. diff --git a/screenshot.gif b/screenshot.gif new file mode 100644 Binary files /dev/null and b/screenshot.gif differ diff --git a/src/Control/Lens/Compat.hs b/src/Control/Lens/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Compat.hs @@ -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 , 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 diff --git a/src/Vgrep/Ansi.hs b/src/Vgrep/Ansi.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Ansi.hs @@ -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 diff --git a/src/Vgrep/Ansi/Parser.hs b/src/Vgrep/Ansi/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Ansi/Parser.hs @@ -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 } diff --git a/src/Vgrep/Ansi/Type.hs b/src/Vgrep/Ansi/Type.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Ansi/Type.hs @@ -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)) diff --git a/src/Vgrep/Ansi/Vty/Attributes.hs b/src/Vgrep/Ansi/Vty/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Ansi/Vty/Attributes.hs @@ -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 + } diff --git a/src/Vgrep/App.hs b/src/Vgrep/App.hs --- a/src/Vgrep/App.hs +++ b/src/Vgrep/App.hs @@ -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 diff --git a/src/Vgrep/App/Internal.hs b/src/Vgrep/App/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/App/Internal.hs @@ -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 diff --git a/src/Vgrep/Command.hs b/src/Vgrep/Command.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Command.hs @@ -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) diff --git a/src/Vgrep/Environment.hs b/src/Vgrep/Environment.hs --- a/src/Vgrep/Environment.hs +++ b/src/Vgrep/Environment.hs @@ -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 diff --git a/src/Vgrep/Environment/Config.hs b/src/Vgrep/Environment/Config.hs --- a/src/Vgrep/Environment/Config.hs +++ b/src/Vgrep/Environment/Config.hs @@ -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)) diff --git a/src/Vgrep/Environment/Config/Monoid.hs b/src/Vgrep/Environment/Config/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment/Config/Monoid.hs @@ -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 diff --git a/src/Vgrep/Environment/Config/Sources.hs b/src/Vgrep/Environment/Config/Sources.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment/Config/Sources.hs @@ -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) + diff --git a/src/Vgrep/Environment/Config/Sources/Env.hs b/src/Vgrep/Environment/Config/Sources/Env.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment/Config/Sources/Env.hs @@ -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 }) diff --git a/src/Vgrep/Environment/Config/Sources/File.hs b/src/Vgrep/Environment/Config/Sources/File.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment/Config/Sources/File.hs @@ -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 diff --git a/src/Vgrep/Key.hs b/src/Vgrep/Key.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Key.hs @@ -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 diff --git a/src/Vgrep/Parser.hs b/src/Vgrep/Parser.hs --- a/src/Vgrep/Parser.hs +++ b/src/Vgrep/Parser.hs @@ -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 } } diff --git a/src/Vgrep/Results.hs b/src/Vgrep/Results.hs --- a/src/Vgrep/Results.hs +++ b/src/Vgrep/Results.hs @@ -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 diff --git a/src/Vgrep/System/Grep.hs b/src/Vgrep/System/Grep.hs --- a/src/Vgrep/System/Grep.hs +++ b/src/Vgrep/System/Grep.hs @@ -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" diff --git a/src/Vgrep/Text.hs b/src/Vgrep/Text.hs --- a/src/Vgrep/Text.hs +++ b/src/Vgrep/Text.hs @@ -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 + [] -> [] diff --git a/src/Vgrep/Widget/HorizontalSplit.hs b/src/Vgrep/Widget/HorizontalSplit.hs --- a/src/Vgrep/Widget/HorizontalSplit.hs +++ b/src/Vgrep/Widget/HorizontalSplit.hs @@ -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) ] - diff --git a/src/Vgrep/Widget/HorizontalSplit/Internal.hs b/src/Vgrep/Widget/HorizontalSplit/Internal.hs --- a/src/Vgrep/Widget/HorizontalSplit/Internal.hs +++ b/src/Vgrep/Widget/HorizontalSplit/Internal.hs @@ -19,8 +19,8 @@ , (%) ) where -import Control.Lens -import Data.Ratio ((%)) +import Control.Lens.Compat +import Data.Ratio ((%)) -- $setup diff --git a/src/Vgrep/Widget/Pager.hs b/src/Vgrep/Widget/Pager.hs --- a/src/Vgrep/Widget/Pager.hs +++ b/src/Vgrep/Widget/Pager.hs @@ -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)) diff --git a/src/Vgrep/Widget/Pager/Internal.hs b/src/Vgrep/Widget/Pager/Internal.hs --- a/src/Vgrep/Widget/Pager/Internal.hs +++ b/src/Vgrep/Widget/Pager/Internal.hs @@ -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) diff --git a/src/Vgrep/Widget/Results.hs b/src/Vgrep/Widget/Results.hs --- a/src/Vgrep/Widget/Results.hs +++ b/src/Vgrep/Widget/Results.hs @@ -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 diff --git a/src/Vgrep/Widget/Results/Internal.hs b/src/Vgrep/Widget/Results/Internal.hs --- a/src/Vgrep/Widget/Results/Internal.hs +++ b/src/Vgrep/Widget/Results/Internal.hs @@ -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 diff --git a/src/Vgrep/Widget/Type.hs b/src/Vgrep/Widget/Type.hs --- a/src/Vgrep/Widget/Type.hs +++ b/src/Vgrep/Widget/Type.hs @@ -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. } diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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] diff --git a/test/Test/Case.hs b/test/Test/Case.hs --- a/test/Test/Case.hs +++ b/test/Test/Case.hs @@ -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 diff --git a/test/Test/Vgrep/Widget/Pager.hs b/test/Test/Vgrep/Widget/Pager.hs --- a/test/Test/Vgrep/Widget/Pager.hs +++ b/test/Test/Vgrep/Widget/Pager.hs @@ -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 diff --git a/test/Test/Vgrep/Widget/Results.hs b/test/Test/Vgrep/Widget/Results.hs --- a/test/Test/Vgrep/Widget/Results.hs +++ b/test/Test/Vgrep/Widget/Results.hs @@ -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) diff --git a/test/Vgrep/Environment/Testable.hs b/test/Vgrep/Environment/Testable.hs --- a/test/Vgrep/Environment/Testable.hs +++ b/test/Vgrep/Environment/Testable.hs @@ -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 } diff --git a/test/Vgrep/Widget/Pager/Testable.hs b/test/Vgrep/Widget/Pager/Testable.hs --- a/test/Vgrep/Widget/Pager/Testable.hs +++ b/test/Vgrep/Widget/Pager/Testable.hs @@ -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 diff --git a/test/Vgrep/Widget/Results/Testable.hs b/test/Vgrep/Widget/Results/Testable.hs --- a/test/Vgrep/Widget/Results/Testable.hs +++ b/test/Vgrep/Widget/Results/Testable.hs @@ -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 diff --git a/vgrep.cabal b/vgrep.cabal --- a/vgrep.cabal +++ b/vgrep.cabal @@ -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 . - <> + Use @hjkl@ or arrow keys to navigate, @Enter@ to view file, @q@ to quit. + . + <> 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