vgrep (empty) → 0.1.3.0
raw patch · 32 files changed
+2500/−0 lines, 32 filesdep +QuickCheckdep +asyncdep +attoparsecsetup-changed
Dependencies added: QuickCheck, async, attoparsec, base, containers, directory, doctest, lens, lifted-base, mmorph, mtl, pipes, pipes-concurrency, process, tasty, tasty-quickcheck, text, transformers, unix, vgrep, vty
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +224/−0
- src/Control/Monad/State/Extended.hs +19/−0
- src/Vgrep/App.hs +148/−0
- src/Vgrep/Environment.hs +30/−0
- src/Vgrep/Environment/Config.hs +79/−0
- src/Vgrep/Event.hs +103/−0
- src/Vgrep/Parser.hs +54/−0
- src/Vgrep/Results.hs +22/−0
- src/Vgrep/System/Grep.hs +106/−0
- src/Vgrep/Text.hs +50/−0
- src/Vgrep/Type.hs +119/−0
- src/Vgrep/Widget.hs +5/−0
- src/Vgrep/Widget/HorizontalSplit.hs +171/−0
- src/Vgrep/Widget/HorizontalSplit/Internal.hs +92/−0
- src/Vgrep/Widget/Pager.hs +179/−0
- src/Vgrep/Widget/Pager/Internal.hs +34/−0
- src/Vgrep/Widget/Results.hs +201/−0
- src/Vgrep/Widget/Results/Internal.hs +225/−0
- src/Vgrep/Widget/Type.hs +37/−0
- test/Data/Text/Lazy/Testable.hs +9/−0
- test/Doctest.hs +12/−0
- test/Spec.hs +7/−0
- test/Test/Case.hs +109/−0
- test/Test/Vgrep/Widget.hs +11/−0
- test/Test/Vgrep/Widget/Pager.hs +82/−0
- test/Test/Vgrep/Widget/Results.hs +123/−0
- test/Vgrep/Environment/Testable.hs +16/−0
- test/Vgrep/Widget/Pager/Testable.hs +24/−0
- test/Vgrep/Widget/Results/Testable.hs +67/−0
- vgrep.cabal +110/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Franz Thoma (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Franz Thoma nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE FlexibleContexts #-}+module Main (main) where++import Control.Concurrent.Async+import Control.Lens+import Control.Monad.Reader+import Data.Maybe+import Data.Monoid+import Data.Ratio+import Data.Sequence (Seq)+import qualified Data.Sequence as S+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import qualified Graphics.Vty as Vty+import Graphics.Vty.Input.Events hiding (Event)+import Graphics.Vty.Picture+import Pipes as P+import Pipes.Concurrent+import qualified Pipes.Prelude as P+import System.Directory+import System.Environment (getArgs)+import System.IO+import System.Posix.IO+import System.Process++import Vgrep.App as App+import Vgrep.Environment+import Vgrep.Event+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+import Vgrep.Widget.Results+++main :: IO ()+main = do+ hSetBuffering stdin LineBuffering+ hSetBuffering stdout LineBuffering+ cfg <- withConfiguredEditor defaultConfig+ inputFromTerminal <- hIsTerminalDevice stdin+ outputToTerminal <- hIsTerminalDevice stdout+ args <- getArgs+ case (inputFromTerminal, outputToTerminal) of+ (True, False) -> runHeadless (const recursiveGrep)+ (False, False) -> runHeadless grep+ (False, True)+ | null args -> runGui cfg id+ | otherwise -> runGui cfg grepForApp+ (True, True) -> runGui cfg (const recursiveGrep)+ where+ stdinText = P.stdinLn >-> P.map T.pack+ stdoutText = P.stdoutLn <-< P.map T.unpack+ runHeadless grepCommand = runEffect (grepCommand stdinText >-> stdoutText)+ runGui cfg grepCommand = withSpawn unbounded $+ \(evSink, evSource) -> do+ let stdinText' = stdinText >-> P.tee (P.map ReceiveInputEvent >-> toOutput evSink)+ grepThread <- async . runEffect $+ grepCommand stdinText' >-> P.map ReceiveResultEvent+ >-> toOutput evSink+ runApp_ app cfg (fromInput evSource)+ cancel grepThread+++type MainWidget = HSplitWidget Results Pager+type WidgetState = HSplit Results Pager++data AppState = AppState { _widgetState :: WidgetState+ , _inputLines :: Seq Text }++data Event = VtyEvent Vty.Event+ | ReceiveInputEvent Text+ | ReceiveResultEvent Text+++app :: App Event AppState+app = App+ { App.initialize = initSplitView+ , App.liftEvent = VtyEvent+ , App.handleEvent = eventHandler+ , App.render = renderMainWidget }+ where+ initSplitView :: MonadIO m => m AppState+ initSplitView = pure AppState+ { _widgetState = Widget.initialize mainWidget+ , _inputLines = S.empty }+ renderMainWidget :: Monad m => VgrepT AppState m Vty.Picture+ renderMainWidget = fmap picForImage (zoom widgetState (draw mainWidget))++mainWidget :: MainWidget+mainWidget = hSplitWidget resultsWidget pagerWidget+++---------------------------------------------------------------------------+-- Events++eventHandler+ :: MonadIO m+ => Event+ -> AppState+ -> Next (VgrepT AppState m Redraw)+eventHandler = \case+ ReceiveInputEvent line -> const (handleFeedInput line)+ ReceiveResultEvent line -> const (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+ handleFeedInput line = Continue $ do+ expandedLine <- expandLineForDisplay line+ modifying inputLines (|> expandedLine)+ pure Unchanged++handleVty+ :: MonadIO m+ => Vty.Event+ -> 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++delegateToWidget+ :: MonadIO m+ => Vty.Event+ -> AppState+ -> Next (VgrepT AppState m Redraw)+delegateToWidget event = fmap (zoom widgetState)+ . Widget.handle mainWidget event+ . view widgetState++resultsKeyBindings :: MonadIO m => Vty.Event -> Next (VgrepT AppState m Redraw)+resultsKeyBindings = dispatchMap $ fromList+ [ (EvKey KEnter [], loadSelectedFileToPager) ]++pagerKeyBindings :: MonadIO m => 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+++loadSelectedFileToPager :: MonadIO m => VgrepT AppState m Redraw+loadSelectedFileToPager = do+ maybeFileName <- uses (results . currentFileName)+ (fmap T.unpack)+ whenJust maybeFileName $ \fileName -> do+ fileExists <- liftIO (doesFileExist fileName)+ fileContent <- if fileExists+ then liftIO (fmap (S.fromList . T.lines) (T.readFile fileName))+ else use inputLines+ displayContent <- expandForDisplay fileContent+ highlightLineNumbers <- use (results . currentFileResultLineNumbers)+ zoom pager (replaceBufferContents displayContent highlightLineNumbers)+ moveToSelectedLineNumber+ zoom widgetState (splitView FocusRight (1 % 3))++moveToSelectedLineNumber :: Monad m => VgrepT AppState m ()+moveToSelectedLineNumber =+ use (results . currentLineNumber)+ >>= (`whenJust` (void . zoom pager . moveToLine))++whenJust :: (Monoid r, Monad m) => Maybe a -> (a -> m r) -> m r+whenJust item action = maybe (pure mempty) action item++invokeEditor :: MonadIO m => AppState -> Next (VgrepT AppState m Redraw)+invokeEditor state = case views (results . currentFileName) (fmap T.unpack) state of+ Just file -> 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)+ 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 ()++---------------------------------------------------------------------------+-- Lenses++widgetState :: Lens' AppState WidgetState+widgetState = lens _widgetState (\s ws -> s { _widgetState = ws })++inputLines :: Lens' AppState (Seq Text)+inputLines = lens _inputLines (\s l -> s { _inputLines = l })++results :: Lens' AppState Results+results = widgetState . leftWidget++pager :: Lens' AppState Pager+pager = widgetState . rightWidget
+ src/Control/Monad/State/Extended.hs view
@@ -0,0 +1,19 @@+module Control.Monad.State.Extended+ ( module Control.Monad.State+ , liftState+ , whenS+ , unlessS+ ) where++import Control.Monad.State++liftState :: MonadState s m => State s a -> m a+liftState = state . runState++whenS :: MonadState s m => (s -> Bool) -> m () -> m ()+whenS predicate action = do+ condition <- fmap predicate get+ when condition action++unlessS :: MonadState s m => (s -> Bool) -> m () -> m ()+unlessS predicate = whenS (not . predicate)
+ src/Vgrep/App.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+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+import Pipes.Prelude as P+import System.Posix.IO+import System.Posix.Types (Fd)++import Vgrep.Environment+import Vgrep.Event+import Vgrep.Type+++-- | The 'App' type is parameterized over the type 'e' of events it handles+-- and the type 's' of its state.+data App e s = App+ { initialize :: forall m. MonadIO m => m s+ -- ^ Creates the initial state for the app.++ , 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)+ -- ^ Handles an event, possibly modifying the App's state.+ --+ -- @+ -- handleEvent e s = case e of+ -- 'Vty.EvKey' 'Vty.KEnter' [] -> 'Continue' ('pure' 'Unchanged')+ -- -- Handles the @Enter@ key, but does nothing.+ --+ -- 'Vty.EvKey' 'Vty.KUp' [] -> 'Continue' ('pure' 'Redraw')+ -- -- Handles the @Up@ key and triggers a redraw.+ --+ -- _otherwise -> 'Skip'+ -- -- Does not handle the event, so other handlers may be invoked.+ -- @++ , render :: forall m. Monad m => VgrepT s m Vty.Picture+ -- ^ Creates a 'Vty.Picture' to be displayed. May modify the App's+ -- state (e. g. for resizing).+ }+++-- | Like 'runApp', but does not return the final state.+runApp_ :: App e s -> Config -> Producer e IO () -> IO ()+runApp_ app conf externalEvents = void (runApp app conf externalEvents)++-- | Runs runs the event loop until an @'Interrupt' 'Halt'@ is encountered.+-- Events handled with @'Interrupt' ('Suspend' action)@ will shut down+-- 'Vty.Vty', run the action (e. g. invoking an external editor), and start+-- 'Vty.Vty' again.+runApp :: App e s -> Config -> Producer e IO () -> IO s+runApp app conf externalEvents = withSpawn unbounded $ \(evSink, evSource) -> do+ displayRegion <- displayRegionHack+ externalEventThread <- (async . runEffect) (externalEvents >-> toOutput evSink)+ initialState <- initialize app+ (_, finalState) <- runVgrepT (appEventLoop app evSource evSink)+ initialState+ (Env conf displayRegion)+ cancel externalEventThread+ pure finalState++-- | 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++ where+ startEventLoop :: VgrepT s IO Interrupt+ startEventLoop = withVty vtyEventSink $ \vty -> do+ refresh vty+ runEffect ((fromInput evSource >> pure Halt) >-> eventLoop vty)++ continueEventLoop :: VgrepT s IO Interrupt+ continueEventLoop = withVty vtyEventSink $ \vty -> do+ refresh vty+ runEffect ((fromInput evSource >> pure Halt) >-> eventLoop vty)++ eventLoop :: Vty -> Consumer e (VgrepT s IO) Interrupt+ eventLoop vty = do+ event <- await+ currentState <- get+ case handleAppEvent event currentState of+ Skip -> eventLoop vty+ Continue action -> lift action >>= \case+ Unchanged -> eventLoop vty+ Redraw -> lift (refresh vty) >> eventLoop vty+ 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+++withVty :: Consumer Vty.Event IO () -> (Vty -> VgrepT s IO a) -> VgrepT s IO a+withVty sink action = vgrepBracket before after (\(vty, _) -> action vty)+ where+ before = do+ vty <- initVty+ evThread <- (async . runEffect) $+ lift (Vty.nextEvent vty) >~ sink+ pure (vty, evThread)+ after (vty, evThread) = do+ cancel evThread+ Vty.shutdown vty+++initVty :: IO Vty+initVty = do+ cfg <- Vty.standardIOConfig+ fdIn <- ttyIn+ fdOut <- ttyOut+ Vty.mkVty (cfg { Vty.inputFd = Just fdIn , Vty.outputFd = Just fdOut })++ttyIn, ttyOut :: IO Fd+-- | Opens @/dev/tty@ read-only. Should be connected to the @stdin@ of+-- a GUI process (e. g. 'Vty.Vty').+ttyIn = openFd "/dev/tty" ReadOnly Nothing defaultFileFlags+-- | Opens @/dev/tty@ write-only. Should be connected to the @stdout@ of+-- a GUI process (e. g. 'Vty.Vty').+ttyOut = openFd "/dev/tty" WriteOnly Nothing defaultFileFlags
+ src/Vgrep/Environment.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+module Vgrep.Environment+ ( Environment (..)++ -- * Auto-generated Lenses+ , config+ , region++ -- * Re-exports+ , module Vgrep.Environment.Config+ , module Graphics.Vty.Prelude+ ) where++import Control.Lens+import Graphics.Vty.Prelude++import Vgrep.Environment.Config+++-- | 'Vgrep.Type.VgrepT' actions can read from the environment.+data Environment = Env+ { _config :: Config+ -- ^ External configuration (colors, editor executable, …)++ , _region :: DisplayRegion+ -- ^ The bounds (width and height) of the display region where the+ -- 'Vgrep.App.App' or the current 'Vgrep.Widget.Widget' is displayed+ } deriving (Eq, Show)++makeLenses ''Environment
+ src/Vgrep/Environment/Config.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell #-}+module Vgrep.Environment.Config where++import Control.Lens+import Data.Maybe+import Graphics.Vty.Image+import System.Environment+++--------------------------------------------------------------------------+-- * Types+--------------------------------------------------------------------------++data Config = Config+ { _colors :: Colors+ -- ^ Color configuration++ , _tabstop :: Int+ -- ^ Tabstop width (default: 8)++ , _editor :: String+ -- ^ Executable for @e@ key (default: environment variable @$EDITOR@,+ -- or @vi@ if @$EDITOR@ is not set)++ } deriving (Eq, Show)++data Colors = Colors+ { _lineNumbers :: Attr+ -- ^ Line numbers (default: blue)++ , _lineNumbersHl :: Attr+ -- ^ Highlighted line numbers (default: bold blue)++ , _normal :: Attr+ -- ^ Normal text (default: terminal default)++ , _normalHl :: Attr+ -- ^ Highlighted text (default: bold)++ , _fileHeaders :: Attr+ -- ^ File names in results view (default: terminal default color on+ -- green background)++ , _selected :: Attr+ -- ^ Selected entry (default: terminal default, inverted)++ } deriving (Eq, Show)+++--------------------------------------------------------------------------+-- * Auto-generated Lenses+--------------------------------------------------------------------------++makeLenses ''Config+makeLenses ''Colors+++--------------------------------------------------------------------------+-- * 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 }+ , _tabstop = 8+ , _editor = "vi" }++withConfiguredEditor :: Config -> IO Config+withConfiguredEditor config = do+ let defaultEditor = view editor config+ configuredEditor <- lookupEnv "EDITOR"+ pure config { _editor = fromMaybe defaultEditor configuredEditor }
+ src/Vgrep/Event.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE Rank2Types #-}+module Vgrep.Event (+ -- * Event handling+ -- | An event handler is a function+ --+ -- @+ -- handleEvent :: 'Control.Monad.State.MonadState' s m => e -> s -> 'Next' (m 'Redraw')+ -- @+ --+ -- where @e@ is the event type and @s@ is the state of the handler. The+ -- 'Next' type determines the type of action to be performed. The state+ -- @s@ is passed as a parameter so the handler can decide which type of+ -- action to perform, while not being able to modify the state.+ --+ -- Event handlers form a 'Monoid' where the first handler that triggers+ -- will perform the action:+ --+ -- @+ -- (handleSome <> handleOther) event state+ -- @+ --+ -- is identical to+ --+ -- @+ -- case handleSome event state of+ -- Skip -> handleOther event state+ -- action -> action+ -- @+ Next (..)+ , Redraw (..)+ , Interrupt (..)++ -- * Dispatching Events+ , dispatch+ , dispatchMap++ -- ** Re-exports+ , module Data.Map+ ) where++import Control.Monad.IO.Class+import Data.Map (Map, fromList)+import qualified Data.Map as M++import Vgrep.Environment+++-- | The type of action to be performed on an event.+data Next a+ = Skip+ -- ^ Do not handle the event (fall-through to other event handlers)++ | Continue a+ -- ^ Handle the event by performing an action++ | Interrupt Interrupt+ -- ^ Interrupt the application++-- | The first event handler that triggers (i. e. does not return 'Skip')+-- handles the event.+instance Monoid (Next a) where+ mempty = Skip+ Skip `mappend` next = next+ next `mappend` _other = next++instance Functor Next where+ fmap f = \case Skip -> Skip+ Continue a -> Continue (f a)+ Interrupt i -> Interrupt i++data Redraw+ = Redraw+ -- ^ Indicates that the state has been changed visibly, so the screen+ -- should be refreshed.++ | Unchanged+ -- ^ The state has not changed or the change would not be visible, so+ -- refreshing the screen is not required.++instance Monoid Redraw where+ mempty = Unchanged+ Unchanged `mappend` Unchanged = Unchanged+ _ `mappend` _ = Redraw+++data Interrupt+ = Suspend (forall m. MonadIO m => Environment -> m ())+ -- ^ Suspend the application and run the action, e. g. invoking an+ -- external process, then resume the application.++ | Halt+ -- ^ Shut down.++++-- | If the lookup returns @'Just' action@, then handle it with+-- @'Continue' action'@, otherwise 'Skip' this event handler.+dispatch :: (e -> Maybe a) -> e -> Next a+dispatch f = maybe Skip Continue . f++-- | Special case of 'dispatch' where actions are looked up from a map.+dispatchMap :: Ord e => Map e a -> e -> Next a+dispatchMap m = dispatch (`M.lookup` m)
+ src/Vgrep/Parser.hs view
@@ -0,0 +1,54 @@+module Vgrep.Parser (+ -- * Parsing @grep@ output+ parseGrepOutput+ , parseLine++ -- ** Re-export+ , FileLineReference+ ) where++import Control.Applicative+import Data.Attoparsec.Text.Lazy+import Data.Maybe+import Data.Text.Lazy++import Vgrep.Results+++-- | Parses lines of 'Text', skipping lines that are not valid @grep@+-- output.+parseGrepOutput :: [Text] -> [FileLineReference]+parseGrepOutput = catMaybes . fmap parseLine++-- | Parses a line of @grep@ output. Returns 'Nothing' if the line cannot+-- be parsed.+--+-- The output should consist of a file name, line number and the content,+-- separated by colons:+--+-- >>> parseLine "path/to/file:123:foobar"+-- Just (FileLineReference {getFile = File {getFileName = "path/to/file"}, getLineReference = LineReference {getLineNumber = Just 123, getLineText = "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"}})+--+-- However, an file name must be present:+--+-- >>> parseLine "foobar"+-- Nothing+parseLine :: Text -> Maybe FileLineReference+parseLine line = maybeResult (parse lineParser line)++lineParser :: Parser FileLineReference+lineParser = do+ file <- manyTill anyChar (char ':')+ lineNumber <- optional (decimal <* char ':')+ result <- takeLazyText+ pure FileLineReference+ { getFile = File+ { getFileName = pack file }+ , getLineReference = LineReference+ { getLineNumber = lineNumber+ , getLineText = result } }
+ src/Vgrep/Results.hs view
@@ -0,0 +1,22 @@+module Vgrep.Results+ ( File (..)+ , LineReference (..)+ , FileLineReference (..)+ ) where++import Data.Text.Lazy (Text)+++newtype File = File+ { getFileName :: Text+ } deriving (Eq, Show)++data LineReference = LineReference+ { getLineNumber :: Maybe Int+ , getLineText :: Text+ } deriving (Eq, Show)++data FileLineReference = FileLineReference+ { getFile :: File+ , getLineReference :: LineReference+ } deriving (Eq, Show)
+ src/Vgrep/System/Grep.hs view
@@ -0,0 +1,106 @@+-- | Utilities for invoking @grep@+{-# LANGUAGE Rank2Types #-}+module Vgrep.System.Grep+ ( grep+ , grepForApp+ , recursiveGrep+ ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Pipes as P+import qualified Pipes.Prelude as P+import System.Environment (getArgs)+import System.Exit+import System.Process++import Vgrep.Parser++import System.IO++-- | Like 'grep', but if the input is not prefixed with a file and line+-- number, i. e. is not valid @grep -nH@ output, then adds @-nH@ (@-n@:+-- with line number, @-H@: with file name) to the @grep@ command line+-- arguments.+grepForApp :: Producer Text IO () -> Producer Text IO ()+grepForApp input = do+ (firstInputLine, input') <- peek input+ when (isNothing firstInputLine) (lift exitFailure)+ case firstInputLine >>= parseLine of+ Just _line -> grep input'+ Nothing -> grepWithFileAndLineNumber input'++grepWithFileAndLineNumber :: Producer Text IO () -> Producer Text IO ()+grepWithFileAndLineNumber input = do+ args <- liftIO getArgs+ grepPipe (withFileName : withLineNumber : args) input++-- | Takes a 'Text' stream and runs it through a @grep@ process, returning+-- a stream of results. The original command line arguments are passed to+-- the process.+grep :: Producer Text IO () -> Producer Text IO ()+grep input = do+ args <- liftIO getArgs+ grepPipe args input++grepPipe :: [String] -> Producer Text IO () -> Producer Text IO ()+grepPipe args input = do+ (hIn, hOut) <- createGrepProcess (lineBuffered : args)+ _threadId <- liftIO . forkIO . runEffect $ input >-> textToHandle hIn+ streamResultsFrom hOut++-- | Invokes @grep -nH -rI@ (@-n@: with line number, @-H@: with file name,+-- @-r@: recursive, @-I@: ignore binary files) and returns the results as a+-- stream. More arguments (e. g. pattern and directory) are taken from the+-- command line.+recursiveGrep :: Producer Text IO ()+recursiveGrep = do+ args <- lift getArgs+ let grepArgs = recursive+ : withFileName+ : withLineNumber+ : skipBinaryFiles+ : lineBuffered+ : args+ (_hIn, hOut) <- createGrepProcess grepArgs+ streamResultsFrom hOut++recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered :: String+recursive = "-r"+withFileName = "-H"+withLineNumber = "-n"+skipBinaryFiles = "-I"+lineBuffered = "--line-buffered"+++createGrepProcess :: MonadIO io => [String] -> io (Handle, Handle)+createGrepProcess args = liftIO $ do+ (Just hIn, Just hOut, _hErr, _processHandle) <- createProcess+ (proc "grep" args) { std_in = CreatePipe, std_out = CreatePipe }+ hSetBuffering hIn LineBuffering+ hSetBuffering hOut LineBuffering+ pure (hIn, hOut)++streamResultsFrom :: Handle -> Producer Text IO ()+streamResultsFrom handle = do+ (maybeFirstLine, grepOutput) <- peek (textFromHandle handle)+ when (isNothing maybeFirstLine) (lift exitFailure)+ grepOutput+++textFromHandle :: MonadIO m => Handle -> Producer' Text m ()+textFromHandle h = P.fromHandle h >-> P.map T.pack++textToHandle :: MonadIO m => Handle -> Consumer' Text m ()+textToHandle h = P.map T.unpack >-> P.toHandle h++peek :: Monad m => Producer a m r -> Producer a m (Maybe a, Producer a m r)+peek producer = do+ eitherNext <- lift (next producer)+ pure $ case eitherNext of+ Left r -> (Nothing, pure r)+ Right (a, producer') -> (Just a, P.yield a >> producer')
+ src/Vgrep/Text.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+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'.+ expandForDisplay+ , expandLineForDisplay+ ) where++import Control.Lens+import Control.Monad.Reader.Class+import Data.Char+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T++import Vgrep.Environment+++-- | Expand a list of lines+expandForDisplay+ :: (Functor f, MonadReader Environment m)+ => f Text -> m (f Text)+expandForDisplay inputLines = do+ tabWidth <- view (config . tabstop)+ pure (fmap (expandText tabWidth) inputLines)++-- | Expand a single line+expandLineForDisplay :: MonadReader Environment m => Text -> m Text+expandLineForDisplay inputLine = do+ tabWidth <- view (config . tabstop)+ pure (expandText tabWidth inputLine)++expandText :: Int -> Text -> Text+expandText tabWidth =+ T.pack . expandSpecialChars . expandTabs tabWidth . T.unpack++expandTabs :: Int -> String -> String+expandTabs tabWidth = go 0+ where go pos (c:cs)+ | c == '\t' = let shift = tabWidth - (pos `mod` tabWidth)+ 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+ [] -> []
+ src/Vgrep/Type.hs view
@@ -0,0 +1,119 @@+-- | The 'VgrepT' monad transformer allows reading from the 'Environment'+-- and changing the state of the 'Vgrep.App.App' or a 'Vgrep.Widget.Widget'.+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Vgrep.Type+ ( -- * The 'VgrepT' monad transformer+ VgrepT ()+ , Vgrep++ , mkVgrepT+ , runVgrepT++ -- ** Modifying the environment+ , modifyEnvironment++ -- ** Utilities+ , vgrepBracket++ -- * Re-exports+ , lift+ , hoist+ , module Vgrep.Environment+ , module Export+) where++import qualified Control.Exception as E+import Control.Lens.Internal.Zoom+import Control.Lens.Zoom+import Control.Monad.Identity+import Control.Monad.Morph+import Control.Monad.Reader+import qualified Control.Monad.Reader as Export+ ( MonadReader+ , ask+ , local+ )+import Control.Monad.State.Extended+import qualified Control.Monad.State.Extended as Export+ ( MonadState+ , get+ , modify+ , put+ )++import Vgrep.Environment++-- | The 'VgrepT' monad transformer is parameterized over the state @s@ of+-- a 'Vgrep.Widget.Widget' or an 'Vgepr.App.App'.+newtype VgrepT s m a = VgrepT (StateT s (StateT Environment m) a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadIO )++-- | 'VgrepT' can read from the 'Environment'. Modifications to the+-- enviromnent are only possible globally (see 'modifyEnvironment'), the+-- 'local' environment is pure.+instance Monad m => MonadReader Environment (VgrepT s m) where+ ask = VgrepT (lift get)+ local f action = mkVgrepT $ \s env -> runVgrepT action s (f env)++instance Monad m => MonadState s (VgrepT s m) where+ get = VgrepT get+ put = VgrepT . put++instance MonadTrans (VgrepT s) where+ lift = VgrepT . lift . lift++instance MFunctor (VgrepT s) where+ hoist f (VgrepT action) = VgrepT (hoist (hoist f) action)++type instance Zoomed (VgrepT s m) = Focusing (StateT Environment m)++instance Monad m => Zoom (VgrepT s m) (VgrepT t m) s t where+ zoom l (VgrepT m) = VgrepT (zoom l m)++-- | Lift a monadic action to 'VgrepT'.+mkVgrepT+ :: Monad m+ => (s -> Environment -> m (a, s))+ -> VgrepT s m a+mkVgrepT action =+ let action' s env = fmap (, env) (action s env)+ in VgrepT (StateT (StateT . action'))++-- | Pass an initial state and an 'Environment' and reduce a 'VgrepT'+-- action to an action in the base monad.+runVgrepT+ :: Monad m+ => VgrepT s m a+ -> s+ -> Environment+ -> m (a, s)+runVgrepT (VgrepT action) s env = do+ ((a, s'), _env') <- runStateT (runStateT action s) env+ pure (a, s')++type Vgrep s = VgrepT s Identity+++-- | A version of 'E.bracket' where the action is lifted to 'VgrepT'.+vgrepBracket+ :: IO a+ -> (a -> IO c)+ -> (a -> VgrepT s IO b)+ -> VgrepT s IO b+vgrepBracket before after action = mkVgrepT $ \s env ->+ let baseAction a = runVgrepT (action a) s env+ in E.bracket before after baseAction+++-- | The 'Environment' of 'VgrepT' is not stateful, however it can be+-- modified globally. An example is resizing the application by changing+-- the display bounds.+modifyEnvironment :: Monad m => (Environment -> Environment) -> VgrepT s m ()+modifyEnvironment = VgrepT . lift . modify
+ src/Vgrep/Widget.hs view
@@ -0,0 +1,5 @@+module Vgrep.Widget+ ( module Vgrep.Widget.Type+ ) where++import Vgrep.Widget.Type
+ src/Vgrep/Widget/HorizontalSplit.hs view
@@ -0,0 +1,171 @@+-- | A split-view widget that displays two widgets side-by-side.+module Vgrep.Widget.HorizontalSplit (+ -- * Horizontal split view widget+ hSplitWidget+ , HSplitWidget++ -- ** Widget state+ , HSplit ()+ , Focus (..)++ -- ** Widget actions+ , leftOnly+ , rightOnly+ , splitView+ , switchFocus++ -- ** Lenses+ , leftWidget+ , rightWidget+ , currentWidget+ , leftWidgetFocused+ , rightWidgetFocused+ ) where++import Control.Lens+import Data.Monoid+import Graphics.Vty.Image hiding (resize)+import Graphics.Vty.Input++import Vgrep.Environment+import Vgrep.Event+import Vgrep.Type+import Vgrep.Widget.HorizontalSplit.Internal+import Vgrep.Widget.Type+++type HSplitWidget s t = Widget (HSplit s t)++-- | Compose two 'Widget's side-by-side+--+-- * __Initial state__+--+-- Initially, the left widget is rendered full-screen.+--+-- * __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)+-- @+hSplitWidget+ :: Widget s+ -> Widget t+ -> HSplitWidget s t+hSplitWidget left right = Widget+ { initialize = initHSplit left right+ , draw = drawWidgets left right+ , handle = handleEvents left right }++initHSplit :: Widget s -> Widget t -> HSplit s t+initHSplit left right = HSplit+ { _leftWidget = initialize left+ , _rightWidget = initialize right+ , _layout = LeftOnly }+++-- | Display the left widget full-screen+leftOnly :: Monad m => VgrepT (HSplit s t) m Redraw+leftOnly = use layout >>= \case+ LeftOnly -> pure Unchanged+ _other -> assign layout LeftOnly >> pure Redraw++-- | Display the right widget full-screen+rightOnly :: Monad m => VgrepT (HSplit s t) m Redraw+rightOnly = use layout >>= \case+ RightOnly -> pure Unchanged+ _other -> assign layout RightOnly >> pure Redraw++-- | Display both widgets in a split view.+splitView+ :: Monad m+ => Focus -- ^ Focus left or right area+ -> Rational -- ^ Left area width as fraction of overall width+ -> VgrepT (HSplit s t) m Redraw+splitView focus ratio = assign layout (Split focus ratio) >> pure Redraw++-- | Switch focus from left to right child widget and vice versa (only if+-- the '_layout' is 'Split')+switchFocus :: Monad m => VgrepT (HSplit s t) m Redraw+switchFocus = use layout >>= \case+ Split focus ratio -> assign layout (switch focus ratio) >> pure Redraw+ _otherwise -> pure Unchanged+ where+ switch FocusLeft ratio = Split FocusRight (1 - ratio)+ switch FocusRight ratio = Split FocusLeft (1 - ratio)++drawWidgets+ :: Monad m+ => Widget s+ -> Widget t+ -> VgrepT (HSplit s t) m Image+drawWidgets left right = use layout >>= \case+ LeftOnly -> zoom leftWidget (draw left)+ RightOnly -> zoom rightWidget (draw right)+ Split _ ratio -> liftA2 (<|>)+ (runInLeftWidget ratio (draw left))+ (runInRightWidget ratio (draw right))++runInLeftWidget+ :: Monad m+ => Rational+ -> VgrepT s m Image+ -> VgrepT (HSplit s t) m Image+runInLeftWidget ratio action =+ let leftRegion = over (region . _1) $ \w ->+ ceiling (ratio * fromIntegral w)+ in zoom leftWidget (local leftRegion action)+++runInRightWidget+ :: Monad m+ => Rational+ -> VgrepT t m Image+ -> VgrepT (HSplit s t) m Image+runInRightWidget ratio action =+ let rightRegion = over (region . _1) $ \w ->+ floor ((1-ratio) * fromIntegral w)+ in zoom rightWidget (local rightRegion action)++-- ------------------------------------------------------------------------+-- Events & Keybindings+-- ------------------------------------------------------------------------++-- FIXME: local region!+handleEvents+ :: Monad m+ => Widget s+ -> Widget t+ -> Event+ -> HSplit s t+ -> Next (VgrepT (HSplit s t) m Redraw)+handleEvents left right e s = case view currentWidget s of+ Left ls -> hSplitKeyBindingsLeft e <> fmap (zoom leftWidget) (handle left e ls)+ Right rs -> hSplitKeyBindingsRight e <> fmap (zoom rightWidget) (handle right e rs)++hSplitKeyBindingsLeft+ :: Monad m+ => Event+ -> Next (VgrepT (HSplit s t) m Redraw)+hSplitKeyBindingsLeft = dispatchMap $ fromList+ [ (EvKey (KChar '\t') [], switchFocus)+ , (EvKey (KChar 'f') [], leftOnly) ]++hSplitKeyBindingsRight+ :: Monad m+ => Event+ -> Next (VgrepT (HSplit s t) m Redraw)+hSplitKeyBindingsRight = dispatchMap $ fromList+ [ (EvKey (KChar '\t') [], switchFocus)+ , (EvKey (KChar 'q') [], leftOnly)+ , (EvKey (KChar 'f') [], rightOnly) ]+
+ src/Vgrep/Widget/HorizontalSplit/Internal.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+module Vgrep.Widget.HorizontalSplit.Internal (+ -- * Split-view widget state+ HSplit (..)+ , Layout (..)+ , Focus (..)++ -- ** Auto-generated lenses+ , leftWidget+ , rightWidget+ , layout++ -- ** Additional lenses+ , currentWidget+ , leftWidgetFocused+ , rightWidgetFocused++ -- ** Re-exports+ , (%)+ ) where++import Control.Lens+import Data.Ratio ((%))+++-- $setup+-- >>> :set -fno-warn-missing-fields++-- | The internal state of the split-view widget. Tracks the state of both+-- child widgets and the current layout.+data HSplit s t = HSplit+ { _leftWidget :: s+ -- ^ State of the left widget++ , _rightWidget :: t+ -- ^ State of the right widget++ , _layout :: Layout+ -- ^ Current layout+ }++data Focus = FocusLeft | FocusRight deriving (Eq)+data Layout = LeftOnly | RightOnly | Split Focus Rational deriving (Eq)++makeLenses ''HSplit+++-- | The currently focused child widget+--+-- >>> view currentWidget $ HSplit { _leftWidget = "foo", _layout = LeftOnly }+-- Left "foo"+currentWidget :: Lens' (HSplit s t) (Either s t)+currentWidget = lens getCurrentWidget setCurrentWidget+ where+ getCurrentWidget state = case view layout state of+ LeftOnly -> Left (view leftWidget state)+ Split FocusLeft _ -> Left (view leftWidget state)+ RightOnly -> Right (view rightWidget state)+ Split FocusRight _ -> Right (view rightWidget state)++ setCurrentWidget state newWidget = case (view layout state, newWidget) of+ (RightOnly, Left widgetL) -> set leftWidget widgetL state+ (Split FocusLeft _, Left widgetL) -> set leftWidget widgetL state+ (LeftOnly, Right widgetR) -> set rightWidget widgetR state+ (Split FocusRight _, Right widgetR) -> set rightWidget widgetR state+ (_, _ ) -> state++-- | Traverses the left widget if focused+--+-- >>> has leftWidgetFocused $ HSplit { _layout = LeftOnly }+-- True+--+-- >>> has leftWidgetFocused $ HSplit { _layout = RightOnly }+-- False+--+-- >>> has leftWidgetFocused $ HSplit { _layout = Split FocusLeft (1 % 2) }+-- True+leftWidgetFocused :: Traversal' (HSplit s t) s+leftWidgetFocused = currentWidget . _Left++-- | Traverses the right widget if focused+--+-- >>> has rightWidgetFocused $ HSplit { _layout = RightOnly }+-- True+--+-- >>> has rightWidgetFocused $ HSplit { _layout = LeftOnly }+-- False+--+-- >>> has rightWidgetFocused $ HSplit { _layout = Split FocusRight (1 % 2) }+-- True+rightWidgetFocused :: Traversal' (HSplit s t) t+rightWidgetFocused = currentWidget . _Right
+ src/Vgrep/Widget/Pager.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE RecordWildCards #-}+module Vgrep.Widget.Pager (+ -- * Pager widget+ pagerWidget+ , PagerWidget++ -- ** Internal state+ , Pager ()++ -- ** Widget actions+ , moveToLine+ , scroll+ , scrollPage+ , hScroll+ , replaceBufferContents+ ) where++import Control.Lens hiding ((:<), (:>))+import Data.Foldable+import Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Graphics.Vty.Image hiding (resize)+import Graphics.Vty.Input+import Graphics.Vty.Prelude++import Vgrep.Environment+import Vgrep.Event+import Vgrep.Type+import Vgrep.Widget.Pager.Internal+import Vgrep.Widget.Type+++type PagerWidget = Widget Pager++-- | Display lines of text with line numbers+--+-- * __Initial state__+--+-- The pager is empty, i. e. no lines of text to display.+--+-- * __Drawing the pager__+--+-- The lines of text are printed, starting at the current scroll+-- position. If not enough lines are available, the scroll position is+-- 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 }++initPager :: Pager+initPager = Pager+ { _column = 0+ , _highlighted = Set.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+ -> VgrepT Pager m ()+replaceBufferContents newContent newHighlightedLines = put initPager+ { _visible = newContent+ , _highlighted = Set.fromList newHighlightedLines }++-- | Scroll to the given line number.+moveToLine :: Monad m => Int -> VgrepT Pager m Redraw+moveToLine n = views region regionHeight >>= \height -> do+ setPosition (n - height `div` 2)+ pure Redraw++-- | Scroll up or down one line.+--+-- > scroll (-1) -- scroll one line up+-- > scroll 1 -- scroll one line down+scroll :: Monad m => Int -> VgrepT Pager m Redraw+scroll n = do+ pos <- use position+ setPosition (pos + n)+ pure Redraw++setPosition :: Monad m => Int -> VgrepT Pager m ()+setPosition n = views region regionHeight >>= \height -> do+ allLines <- liftA2 (+) (uses visible length) (uses above length)+ let newPosition = if+ | n < 0 || allLines < height -> 0+ | n > allLines - height -> allLines - height+ | otherwise -> n+ modify $ \pager@Pager{..} ->+ let (newAbove, newVisible) = Seq.splitAt newPosition (_above >< _visible)+ in pager+ { _above = newAbove+ , _visible = newVisible }++-- | Scroll up or down one page. The first line on the current screen will+-- be the last line on the scrolled screen and vice versa.+--+-- > 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++-- | Horizontal scrolling. Increment is one 'tabstop'.+--+-- > hScroll (-1) -- scroll one tabstop left+-- > hScroll 1 -- scroll one tabstop right+hScroll :: Monad m => Int -> VgrepT Pager m Redraw+hScroll n = do+ tabWidth <- view (config . tabstop)+ modifying column $ \currentColumn ->+ let newColumn = currentColumn + n * tabWidth+ in if newColumn > 0 then newColumn else 0+ pure Redraw+++renderPager :: Monad m => VgrepT Pager m Image+renderPager = do+ textColor <- view (config . colors . normal)+ textColorHl <- view (config . colors . normalHl)+ lineNumberColor <- view (config . colors . lineNumbers)+ lineNumberColorHl <- view (config . colors . lineNumbersHl)+ (width, height) <- view region+ 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+ . map renderLine+ $ zip [startPosition+1..] visibleLines++ pure (resizeWidth width (renderedLineNumbers <|> renderedTextLines))++ where padWithSpace s = ' ' : s ++ " "
+ src/Vgrep/Widget/Pager/Internal.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}+module Vgrep.Widget.Pager.Internal (+ -- * Pager widget state+ Pager (..)++ -- * Lenses+ , position+ -- ** Auto-generated lenses+ , column+ , above+ , visible+ , highlighted+ ) where++import Control.Lens+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.Text.Lazy (Text)+++-- | 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+ , _highlighted :: Set Int+ , _above :: Seq Text+ , _visible :: Seq Text }+ deriving (Eq, Show)++makeLenses ''Pager++-- | The number of invisible lines above the screen+position :: Getter Pager Int+position = above . to length
+ src/Vgrep/Widget/Results.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}++module Vgrep.Widget.Results (+ -- * Results list widget+ resultsWidget+ , ResultsWidget++ -- ** Internal widget state+ , Results ()++ -- ** Widget actions+ , feedResult+ , resizeToWindow+ , prevLine+ , nextLine+ , pageUp+ , pageDown++ -- ** Lenses+ , currentFileName+ , currentLineNumber+ , currentFileResultLineNumbers++ -- * Re-exports+ , module Vgrep.Results+ ) where++import Control.Applicative+import Control.Lens+import Control.Monad.State.Extended+import Data.Foldable+import Data.Maybe+import Data.Monoid+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Graphics.Vty.Image hiding ((<|>))+import Graphics.Vty.Input+import Graphics.Vty.Prelude+import Prelude++import Vgrep.Environment+import Vgrep.Event+import Vgrep.Results+import Vgrep.Type+import Vgrep.Widget.Results.Internal as Internal+import Vgrep.Widget.Type+++type ResultsWidget = Widget Results++-- | The results widget displays a list of lines with line numbers, grouped+-- by files.+--+-- * __Initial state__+--+-- The initial buffer is empty and can be filled line by line using+-- 'feedResult'.+--+-- * __Drawing the results list__+--+-- Found matches are grouped by file name. Each file group has a header+-- and a list of result lines with line numbers. The result lines can+-- 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 }++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.+feedResult :: Monad m => FileLineReference -> VgrepT Results m Redraw+feedResult line = do+ modify (feed line)+ resizeToWindow++-- | Move up/down one results page. File group headers will be skipped.+pageUp, pageDown :: Monad m => VgrepT Results m ()+pageUp = do+ unlessS (isJust . moveUp) $ do+ modify (repeatedly (hideNext >=> showPrev))+ void resizeToWindow+ modify (repeatedly moveUp)+pageDown = do+ unlessS (isJust . moveDown) $ do+ modify (repeatedly hidePrev)+ void resizeToWindow+ modify (repeatedly moveDown)++repeatedly :: (a -> Maybe a) -> a -> a+repeatedly f = go+ where+ go x | Just x' <- f x = go x'+ | otherwise = x++-- | Move up/down one results line. File group headers will be skipped.+prevLine, nextLine :: Monad m => VgrepT Results m ()+prevLine = maybeModify tryPrevLine >> void resizeToWindow+nextLine = maybeModify tryNextLine >> void resizeToWindow++tryPrevLine, tryNextLine :: Results -> Maybe Results+tryPrevLine buf = moveUp buf <|> (showPrev buf >>= tryPrevLine)+tryNextLine buf = moveDown buf <|> (showNext buf >>= tryNextLine)++maybeModify :: Monad m => (s -> Maybe s) -> VgrepT s m ()+maybeModify f = do+ s <- get+ case f s of+ Just s' -> put s'+ Nothing -> pure ()+++renderResultList :: Monad m => VgrepT Results m Image+renderResultList = do+ void resizeToWindow+ visibleLines <- use (to toLines)+ width <- views region regionWidth+ 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)++renderLine+ :: Monad m+ => Int+ -> Int+ -> DisplayLine+ -> VgrepT Results m Image+renderLine width lineNumberWidth displayLine = do+ fileHeaderStyle <- view (config . colors . fileHeaders)+ lineNumberStyle <- view (config . colors . lineNumbers)+ resultLineStyle <- view (config . colors . normal)+ selectedStyle <- view (config . colors . selected)+ pure $ case displayLine of+ FileHeader (File file)+ -> renderFileHeader fileHeaderStyle file+ Line (LineReference n t)+ -> horizCat [ renderLineNumber lineNumberStyle n+ , renderLineText resultLineStyle t ]+ SelectedLine (LineReference n t)+ -> horizCat [ renderLineNumber lineNumberStyle n+ , renderLineText selectedStyle t ]+ where+ padWithSpace w = T.take (fromIntegral w)+ . T.justifyLeft (fromIntegral w) ' '+ . T.cons ' '+ justifyRight w s = T.justifyRight (fromIntegral w) ' ' (s <> " ")++ renderFileHeader :: Attr -> Text -> Image+ renderFileHeader attr = text attr . padWithSpace width++ renderLineNumber :: Attr -> Maybe Int -> Image+ renderLineNumber attr = text attr+ . justifyRight lineNumberWidth+ . maybe "" (T.pack . show)++ renderLineText :: Attr -> Text -> Image+ renderLineText attr = text attr+ . padWithSpace (width - lineNumberWidth)+++resizeToWindow :: Monad m => VgrepT Results m Redraw+resizeToWindow = do+ height <- views region regionHeight+ currentBuffer <- get+ case Internal.resize height currentBuffer of+ Just resizedBuffer -> put resizedBuffer >> pure Redraw+ Nothing -> pure Unchanged
+ src/Vgrep/Widget/Results/Internal.hs view
@@ -0,0 +1,225 @@+module Vgrep.Widget.Results.Internal (+ -- * Results widget state+ Results (..)++ -- * Lenses+ , currentFileName+ , currentLineNumber+ , currentFileResultLineNumbers++ -- * Actions+ -- | In general, actions return @'Just' newResults@ if the buffer has+ -- changed, and @'Nothing'@ otherwise. This way it is easy to recognize+ -- whether or not a 'Vgrep.Event.Redraw' is necessary.+ , feed+ , showPrev, showNext+ , hidePrev, hideNext+ , moveUp, moveDown+ , resize++ -- * Utilities for displaying+ , DisplayLine(..)+ , toLines+ , lineNumber+ ) where++import Control.Applicative+import Control.Lens (Getter, pre, to, _Just)+import Data.Foldable+import Data.Function+import Data.List (groupBy)+import Data.Maybe+import Data.Monoid+import Data.Sequence+ ( Seq+ , ViewL (..)+ , ViewR (..)+ , viewl+ , viewr+ , (<|)+ , (|>)+ )+import qualified Data.Sequence as S+import Data.Text.Lazy (Text)+import Prelude hiding (reverse)++import Vgrep.Results+++-- | Results widget state+data Results+ = EmptyResults+ -- ^ The results list is empty++ | Results+ (Seq FileLineReference) -- above screen (reversed)+ (Seq FileLineReference) -- top of screen (reversed)+ FileLineReference -- currently selected+ (Seq FileLineReference) -- bottom of screen+ (Seq FileLineReference) -- below screen+ -- ^ The structure of the Results buffer is a double Zipper:+ --+ -- * lines above the current screen+ -- * lines on screen above the current item+ -- * the current item+ -- * lines on screen below the current item+ -- * lines below the current screen++ deriving (Eq, Show)+++-- | Append a line to the 'Results'. The line is appended below the visible+-- screen, so use 'showNext' to make it visible.+feed :: FileLineReference -> Results -> Results+feed l = \case+ EmptyResults -> Results empty empty l empty empty+ Results as bs c ds es -> Results as bs c ds (es |> l)+++-- | Reverse the 'Results'+reverse :: Results -> Results+reverse = \case+ Results as bs c ds es -> Results es ds c bs as+ EmptyResults -> EmptyResults++-- | Show one more item at the bottom of the screen if available.+showNext :: Results -> Maybe Results+showNext = \case+ Results as bs c ds es -> do e :< es' <- Just (viewl es)+ Just (Results as bs c (ds |> e) es')+ EmptyResults -> Nothing++-- | Show one more item at the top of the screen if available.+showPrev :: Results -> Maybe Results+showPrev = fmap reverse . showNext . reverse++-- | Remove the last item from the bottom of the screen and prepend it to+-- the invisible items below.+hideNext :: Results -> Maybe Results+hideNext = \case+ Results as bs c ds es -> do ds' :> d <- Just (viewr ds)+ Just (Results as bs c ds' (d <| es))+ EmptyResults -> Nothing++-- | Remove the first item from the top of the screen and append it to the+-- invisible items above.+hidePrev :: Results -> Maybe Results+hidePrev = fmap reverse . hideNext . reverse++-- | Move the cursor one item down.+moveDown :: Results -> Maybe Results+moveDown = \case+ Results as bs c ds es -> do d :< ds' <- Just (viewl ds)+ Just (Results as (c <| bs) d ds' es)+ EmptyResults -> Nothing++-- | Move the cursor one item up.+moveUp :: Results -> Maybe Results+moveUp = fmap reverse . moveDown . reverse++-- | Adjust the number of on-screen items to the given height:+--+-- * If the current list is too long for the new height, take items from+-- the top until the current item is topmost, then from the bottom.+-- * If the current list is too short for the new height, add items below+-- until the buffer is empty, then above.+resize+ :: Int -- ^ the new height+ -> Results+ -> Maybe Results -- ^ @'Nothing'@ if the height has not changed,+ -- @'Just' newResults@ otherwise+resize height buffer+ | visibleHeight buffer < height - 1 = Just (doResize buffer)+ | visibleHeight buffer > height = Just (doResize buffer)+ | otherwise = Nothing+ where+ doResize buf+ -- FIXME we need some kind of bias+ -- to avoid running into an infinite+ -- loop, but this leaves some nasty+ -- artifacts when scrolling over the+ -- last line. -----------------v+ | visibleHeight buf < height - 1+ = maybe buf doResize (showNext buf <|> showPrev buf)++ | visibleHeight buf > height+ = maybe buf doResize (hidePrev buf <|> hideNext buf)++ | otherwise+ = buf++visibleHeight :: Results -> Int+visibleHeight = length . toLines+++-- | Ad-hoc data structure to render the (visible) 'Results' as list of+-- lines.+data DisplayLine = FileHeader File+ | Line LineReference+ | SelectedLine LineReference+ deriving (Eq)++-- | Converts the visible 'Results' to a list of 'DisplayLine's. Each item+-- in the returned list corresponds to a line on the screen.+--+-- Each group of 'Line's that points to the same file is prepended with+-- a 'FileHeader'. The item below the cursor becomes a 'SelectedLine'.+toLines :: Results -> [DisplayLine]+toLines EmptyResults = []+toLines (Results _ bs c ds _) = linesBefore <> selected c <> linesAfter++ where+ linesBefore = case viewl bs of+ 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++ go refs = do+ fileResults <- groupBy pointsToSameFile (toList refs)+ header (head fileResults) <> fmap (Line . getLineReference) fileResults++ header = pure . FileHeader . getFile+ selected = pure . SelectedLine . getLineReference+ pointsToSameFile = (==) `on` getFile++-- | The line number of a 'DisplayLine'. 'Nothing' for 'FileHeader's.+lineNumber :: DisplayLine -> Maybe Int+lineNumber = \case+ FileHeader _ -> Nothing+ Line (LineReference n _) -> n+ SelectedLine (LineReference n _) -> n+++-- | The file name of the currently selected item+currentFileName :: Getter Results (Maybe Text)+currentFileName =+ pre (to current . _Just . to getFile . to getFileName)++-- | The line number of the currently selected item+currentLineNumber :: Getter Results (Maybe Int)+currentLineNumber =+ pre (to current . _Just . to getLineReference . to getLineNumber . _Just)++current :: Results -> Maybe FileLineReference+current = \case+ Results _ _ c _ _ -> Just c+ EmptyResults -> Nothing++-- | The line numbers with matches in the file of the currentliy selected+-- item+currentFileResultLineNumbers :: Getter Results [Int]+currentFileResultLineNumbers =+ to (mapMaybe getLineNumber . currentFile)+ where+ currentFile = do+ let sameFileAs = (==) `on` getFile+ inCurrentFile <- sameFileAs . fromJust . current+ map getLineReference . filter inCurrentFile . bufferToList++bufferToList :: Results -> [FileLineReference]+bufferToList = \case+ EmptyResults -> []+ Results as bs c ds es -> toList (as <> bs <> pure c <> ds <> es)
+ src/Vgrep/Widget/Type.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE Rank2Types #-}+module Vgrep.Widget.Type+ ( Widget (..)++ -- ** Re-exports from "Vgrep.Event"+ , Redraw (..)+ , Next (..)+ ) where++import Graphics.Vty.Image (Image)+import Graphics.Vty.Input++import Vgrep.Event (Next (..), Redraw (..))+import Vgrep.Type++-- | A 'Widget' is a unit that is displayed on the screen. It is associated+-- with a mutable state @s@. It provides an event handler with default+-- keybindings and can generate a renderable 'Image'.+--+-- Widget modules should provide a 'Widget' instance and additionally a+-- collection of actions that can be invoked by external event handlers:+--+-- @+-- widgetAction :: 'VgrepT' s m 'Redraw'+-- @+data Widget s = Widget+ { initialize :: s+ -- ^ The initial state of the widget++ , 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.+ }
+ test/Data/Text/Lazy/Testable.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Text.Lazy.Testable ( module Data.Text.Lazy ) where++import Data.Text.Lazy+import Test.Tasty.QuickCheck++instance Arbitrary Text where+ arbitrary = fmap pack arbitrary+ shrink = fmap pack . shrink . unpack
+ test/Doctest.hs view
@@ -0,0 +1,12 @@+import Test.DocTest++main :: IO ()+main =+ let extensions =+ [ "-XLambdaCase"+ , "-XMultiWayIf"+ , "-XOverloadedStrings" ]+ sourceFolders =+ [ "src"+ , "app" ]+ in doctest (extensions ++ sourceFolders)
+ test/Spec.hs view
@@ -0,0 +1,7 @@+import Test.Tasty++import qualified Test.Vgrep.Widget as Widget++main :: IO ()+main = defaultMain $+ testGroup "Unit tests" [ Widget.test ]
+ test/Test/Case.hs view
@@ -0,0 +1,109 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Case (+ TestCase (..)+ , runTestCase+ , runTestCases++ , (~~)++ , testPropertyVgrep+ , monadicVgrep++ , module Vgrep.Type+ , TestTree ()+ ) where++import Control.Lens+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++import Vgrep.Environment.Testable+import Vgrep.Type++data TestCase+ = forall s a prop. (Arbitrary s, Show s, Testable prop)+ => TestProperty+ { description :: TestName+ , testData :: Gen (s, Environment)+ , testCase :: PropertyM (Vgrep s) a+ , assertion :: a -> PropertyM (Vgrep s) prop }+ | forall s a r. (Arbitrary s, Show s, Eq r, Show r)+ => TestInvariant+ { description :: TestName+ , testData :: Gen (s, Environment)+ , testCase :: PropertyM (Vgrep s) a+ , invariant :: Getter s r }+++runTestCase :: TestCase -> TestTree+runTestCase = \case+ TestProperty {..} -> testProperty description $ do+ (initialState, initialEnv) <- testData+ pure . monadic (`runVgrepForTest` (initialState, initialEnv)) $ do+ monitor (counterexample (show initialState))+ monitor (counterexample (show initialEnv))+ params <- testCase+ stop =<< assertion params+ TestInvariant {..} -> testProperty description $ do+ (initialState, initialEnv) <- testData+ pure . monadic (`runVgrepForTest` (initialState, initialEnv)) $ do+ monitor (counterexample (show initialState))+ monitor (counterexample (show initialEnv))+ before <- use invariant+ void testCase+ after <- use invariant+ stop (after === before)+++runTestCases :: TestName -> [TestCase] -> TestTree+runTestCases name cases = testGroup name (map runTestCase cases)+++instance Monad m => MonadState s (PropertyM (VgrepT s m)) where+ get = run get+ put = run . put++instance Monad m => MonadReader Environment (PropertyM (VgrepT s m)) where+ ask = run ask+ local f action = MkPropertyM $ \k -> fmap (local f) (unPropertyM action k)+++runVgrepForTest+ :: Vgrep s a+ -> (s, Environment)+ -> a+runVgrepForTest action (s, env) = fst (runIdentity (runVgrepT action s env))++monadicVgrep+ :: Arbitrary s+ => PropertyM (Vgrep s) a+ -> Gen Property+monadicVgrep testcase = do+ initialState <- arbitrary+ initialEnv <- arbitrary+ pure (monadic (`runVgrepForTest` (initialState, initialEnv)) testcase)++testPropertyVgrep+ :: Arbitrary s+ => TestName+ -> PropertyM (Vgrep s) a+ -> TestTree+testPropertyVgrep name prop = testProperty name (monadicVgrep prop)++infix 4 ~~+(~~)+ :: (Eq a, Show a)+ => Getter s a+ -> Getter s a+ -> PropertyM (Vgrep s) Property+prop1 ~~ prop2 = do+ p1 <- use prop1+ p2 <- use prop2+ pure (p1 === p2)
+ test/Test/Vgrep/Widget.hs view
@@ -0,0 +1,11 @@+module Test.Vgrep.Widget (test) where++import Test.Tasty++import qualified Test.Vgrep.Widget.Pager as Pager+import qualified Test.Vgrep.Widget.Results as Results++test :: TestTree+test = testGroup "Widgets"+ [ Pager.test+ , Results.test ]
+ test/Test/Vgrep/Widget/Pager.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Vgrep.Widget.Pager (test) where++import Control.Lens+import qualified Data.Sequence as S+import Data.Text.Lazy.Testable ()+import qualified Data.Text.Lazy.Testable as T+import Test.Case+import Test.QuickCheck as Q+import Test.QuickCheck.Monadic as Q++import Vgrep.Widget.Pager.Testable+++test :: TestTree+test = runTestCases "Pager widget"+ [ TestInvariant+ { description = "Scrolling up and down leaves pager invariant"+ , testData = arbitrary `suchThat` (not . atTop)+ `suchThat` coversScreen+ , testCase = run (void (scroll (-1) >> scroll 1))+ , invariant = id+ }+ , TestInvariant+ { description = "Scrolling right and left leaves pager invariant"+ , testData = arbitrary+ , testCase = run (void (hScroll 1 >> hScroll (-1)))+ , invariant = id+ }+ , TestProperty+ { description = "MoveToLine displays the line on screen"+ , testData = arbitrary `suchThat` (not . emptyPager)+ , testCase = do+ numLines <- liftA2 (+) (uses above length) (uses visible length)+ line <- pick ( arbitrary `suchThat` (> 0)+ `suchThat` (<= numLines) )+ run (void (moveToLine line))+ pure line+ , assertion = \line -> do+ pos <- use position+ let posOnScreen = line - pos+ height <- view (region . to regionHeight)+ pure $ counterexample+ ("Failed: 0 <= " ++ show posOnScreen ++ " <= " ++ show height)+ (posOnScreen >= 0 .&&. posOnScreen <= height)+ }+ , TestProperty+ { description = "Scrolling stays within bounds"+ , testData = arbitrary `suchThat` coversScreen+ , testCase = do+ amount <- pick (scale (*10) arbitrary)+ run (void (scroll amount))+ , assertion = const $ do+ pos <- use position+ linesVisible <- uses visible length+ height <- view (region . to regionHeight)+ pure (pos >= 0 .&&. linesVisible >= height)+ }+ , TestProperty+ { description = "After replaceBufferContents the new content is visible"+ , testData = arbitrary+ , testCase = do+ newContent <- pick (fmap (S.fromList . map T.pack) arbitrary)+ run (replaceBufferContents newContent [])+ pure newContent+ , assertion = \expectedContent -> do+ actualContent <- use visible+ pure (actualContent === expectedContent)+ }+ ]+++emptyPager :: (Pager, Environment) -> Bool+emptyPager (pager, _env) = views visible length pager == 0+ && views above length pager == 0++coversScreen :: (Pager, Environment) -> Bool+coversScreen (pager, env) = length (view visible pager) >= view (region . _2) env++atTop :: (Pager, Environment) -> Bool+atTop (pager, _env) = view position pager == 0
+ test/Test/Vgrep/Widget/Results.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+module Test.Vgrep.Widget.Results (test) where++import Control.Lens (Getter, to, view, views)+import Data.Map.Strict ((!))+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Test.Case+import Test.QuickCheck+import Test.QuickCheck.Monadic++import Vgrep.Widget.Results.Testable++test :: TestTree+test = runTestCases "Results widget"+ [ TestInvariant+ { description = "Scrolling one line down and up keeps selected line"+ , testData = arbitrary `suchThat` (not . lastLine)+ , testCase = run (nextLine >> prevLine)+ , invariant = selectedLine+ }+ , TestInvariant+ { description = "Scrolling one page down and up keeps selected line"+ , testData = arbitrary+ `suchThat` lastLineOnScreen+ `suchThat` \(results, env) -> linesBelowCurrent (> screenHeight env) results+ , testCase = run (pageDown >> pageUp)+ , invariant = selectedLine+ }+ , TestProperty+ { description = "Scrolling one page down jumps to end of screen"+ , testData = arbitrary+ , testCase = run pageDown+ , assertion = const $ get >>= pure . \case+ EmptyResults -> True+ Results _ _ _ ds _ -> null ds+ }+ , TestProperty+ { description = "Scrolling one page up jumps to start of screen"+ , testData = arbitrary+ , testCase = run pageUp+ , assertion = const $ get >>= pure . \case+ EmptyResults -> True+ Results _ bs _ _ _ -> null bs+ }+ , TestProperty+ { description = "Number of lines on screen is bounded by screen height after resizing"+ , testData = arbitrary+ , testCase = run resizeToWindow+ , assertion = const assertWidgetFitsOnScreen+ }+ , TestProperty+ { description = "Number of lines on screen is bounded by screen height after each action"+ , testData = arbitrary+ , testCase = do+ run (void resizeToWindow)+ -- ^ Precondition: widget is resized to display height+ run =<< arbitraryAction+ , assertion = const assertWidgetFitsOnScreen+ }+ , TestInvariant+ { description = "Results do not change order"+ , testData = arbitrary+ , testCase = run =<< arbitraryAction+ , invariant = resultsAsList+ }+ ]++selectedLine :: Getter Results (Maybe FileLineReference)+selectedLine = to $ \case+ EmptyResults -> Nothing+ Results _ _ c _ _ -> Just c++linesBelowCurrent :: (Int -> Bool) -> Results -> Bool+linesBelowCurrent p = \case+ EmptyResults -> p 0+ Results _ _ _ ds es -> p (length ds + length es)++screenHeight :: Environment -> Int+screenHeight = view (region . to regionHeight)++lastLineOnScreen :: (Results, Environment) -> Bool+lastLineOnScreen (results, _env) = case results of+ EmptyResults -> True+ Results _ _ _ ds _ -> null ds++lastLine :: (Results, Environment) -> Bool+lastLine (results, _env) = case results of+ EmptyResults -> True+ Results _ _ _ ds es -> null ds && null es++resultsAsList :: Getter Results (Seq FileLineReference)+resultsAsList = to $ \case+ EmptyResults -> mempty+ Results as bs c ds es -> mconcat+ [ Seq.reverse as, Seq.reverse bs, pure c, ds, es ]++arbitraryAction :: Monad m => PropertyM m (Vgrep Results ())+arbitraryAction = do+ let actions = Map.fromList+ [ ("pageUp", pageUp)+ , ("pageDown", pageDown)+ , ("prevLine", prevLine)+ , ("nextLine", nextLine) ]+ actionName <- pick (elements ["pageUp", "pageDown", "prevLine", "nextLine"])+ pure (actions ! actionName)++assertWidgetFitsOnScreen+ :: (MonadState Results m, MonadReader Environment m)+ => m Property+assertWidgetFitsOnScreen = do+ height <- views region regionHeight+ linesOnScreen <- numberOfLinesOnScreen+ pure $ counterexample+ (show linesOnScreen ++ " > " ++ show height)+ (linesOnScreen <= height)++numberOfLinesOnScreen :: MonadState Results m => m Int+numberOfLinesOnScreen = get >>= pure . \case+ EmptyResults -> 0+ Results _ bs c ds _ -> length (mconcat [bs, pure c, ds])
+ test/Vgrep/Environment/Testable.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Vgrep.Environment.Testable+ ( module Vgrep.Environment+ ) where++import Test.QuickCheck++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)+ , _config = defaultConfig }
+ test/Vgrep/Widget/Pager/Testable.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Vgrep.Widget.Pager.Testable+ ( module Vgrep.Widget.Pager+ , module Vgrep.Widget.Pager.Internal+ ) where++import Data.Sequence as Seq (fromList)+import Data.Text.Lazy.Testable ()+import Test.QuickCheck++import Vgrep.Widget.Pager+import Vgrep.Widget.Pager.Internal++instance Arbitrary Pager where+ arbitrary = do+ linesOfText <- arbitrary+ pos <- case linesOfText of+ [] -> pure 0+ _ -> choose (0, length linesOfText - 1)+ pure Pager+ { _column = 0+ , _highlighted = mempty+ , _above = Seq.fromList (take pos linesOfText)+ , _visible = Seq.fromList (drop pos linesOfText) }
+ test/Vgrep/Widget/Results/Testable.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE LambdaCase #-}+module Vgrep.Widget.Results.Testable+ ( module Vgrep.Widget.Results+ , module Vgrep.Widget.Results.Internal+ ) where++import Control.Monad+import qualified Data.List as List+import qualified Data.Sequence as Seq+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as Text+import Test.QuickCheck++import Vgrep.Widget.Results+import Vgrep.Widget.Results.Internal++instance Arbitrary Results where+ arbitrary = sized $ \n -> frequency+ [ (1, pure EmptyResults)+ , (n, generateResults) ]+++generateResults :: Gen Results+generateResults = sized $ \n -> do+ streamOfResults <- arbitraryGrepResults+ [numAs, numBs, numDs, numEs] <- replicateM 4 (choose (0, n))+ let (as, as') = splitAt numAs streamOfResults+ (bs, bs') = splitAt numBs as'+ ([c], cs') = splitAt 1 bs'+ (ds, ds') = splitAt numDs cs'+ (es, _) = splitAt numEs ds'+ pure $ Results+ (Seq.fromList as)+ (Seq.fromList bs)+ c+ (Seq.fromList ds)+ (Seq.fromList es)+++arbitraryGrepResults :: Gen [FileLineReference]+arbitraryGrepResults = fmap concat . infiniteListOf $ do+ fileName <- arbitraryText+ lineReferences <- do+ matches <- listOf arbitraryText+ lineNumbers <- maybeLineNumbers (length matches)+ pure (zipWith LineReference lineNumbers matches)+ pure [ FileLineReference (File fileName) lineReference+ | lineReference <- lineReferences ]+++arbitraryText :: Gen Text+arbitraryText = fmap Text.pack arbitrary++ascendingListOf :: Ord a => Int -> Gen a -> Gen [a]+ascendingListOf len things = sorted (vectorOf len things)++maybeLineNumbers :: Int -> Gen [Maybe Int]+maybeLineNumbers len = arbitrary >>= \case+ Just () -> ascendingListOf len (fmap Just positiveNumber)+ Nothing -> vectorOf len (pure Nothing)++sorted :: (Functor f, Ord a) => f [a] -> f [a]+sorted = fmap List.sort++positiveNumber :: Gen Int+positiveNumber = arbitrary `suchThat` (> 0)
+ vgrep.cabal view
@@ -0,0 +1,110 @@+name: vgrep+version: 0.1.3.0+synopsis: A pager for grep+description: Please see README.md+homepage: http://github.com/fmthoma/vgrep#readme+license: BSD3+license-file: LICENSE+author: Franz Thoma+maintainer: franz.thoma@tngtech.com+copyright: 2016 Franz Thoma+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ default-extensions: LambdaCase+ , MultiWayIf+ exposed-Modules: Control.Monad.State.Extended+ , Vgrep.App+ , Vgrep.Event+ , Vgrep.Environment+ , Vgrep.Environment.Config+ , Vgrep.Parser+ , Vgrep.Results+ , Vgrep.System.Grep+ , Vgrep.Text+ , Vgrep.Type+ , Vgrep.Widget+ , Vgrep.Widget.HorizontalSplit+ , Vgrep.Widget.HorizontalSplit.Internal+ , Vgrep.Widget.Pager+ , Vgrep.Widget.Pager.Internal+ , Vgrep.Widget.Results+ , Vgrep.Widget.Results.Internal+ , Vgrep.Widget.Type+ build-depends: base >= 4.7 && < 5+ , async+ , attoparsec+ , containers+ , lens+ , lifted-base+ , mtl+ , mmorph+ , pipes+ , pipes-concurrency+ , process+ , text+ , transformers+ , unix+ , vty >= 5.4.0+ default-language: Haskell2010++executable vgrep+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ default-extensions: LambdaCase+ , MultiWayIf+ build-depends: base+ , async+ , containers+ , directory+ , lens+ , mtl+ , pipes+ , pipes-concurrency+ , process+ , text+ , unix+ , vgrep+ , vty >= 5.4.0+ default-language: Haskell2010++test-suite vgrep-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Data.Text.Lazy.Testable+ , Test.Case+ , Test.Vgrep.Widget+ , Test.Vgrep.Widget.Pager+ , Test.Vgrep.Widget.Results+ , Vgrep.Environment.Testable+ , Vgrep.Widget.Pager.Testable+ , Vgrep.Widget.Results.Testable+ build-depends: base+ , containers+ , lens+ , QuickCheck+ , tasty+ , tasty-quickcheck+ , text+ , vgrep+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++test-suite doctest+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Doctest.hs+ build-depends: base, doctest+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/fmthoma/vgrep