vgrep 0.1.3.0 → 0.1.4.0
raw patch · 10 files changed
+286/−75 lines, 10 filesdep +cabal-file-thdep +fingertreedep +stmdep ~asyncdep ~attoparsecdep ~base
Dependencies added: cabal-file-th, fingertree, stm, template-haskell
Dependency ranges changed: async, attoparsec, base, containers, directory, lens, lifted-base, mmorph, mtl, pipes, pipes-concurrency, process, text, transformers, unix
Files
- app/Main.hs +31/−14
- src/Control/Concurrent/STM/TPQueue.hs +75/−0
- src/Control/Monad/State/Extended.hs +2/−2
- src/Pipes/Concurrent/PQueue.hs +73/−0
- src/Vgrep/App.hs +27/−13
- src/Vgrep/System/Grep.hs +8/−1
- src/Vgrep/Widget/Pager/Internal.hs +10/−2
- src/Vgrep/Widget/Results/Internal.hs +5/−5
- test/Test/Vgrep/Widget/Results.hs +10/−8
- vgrep.cabal +45/−30
app/Main.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Main (main) where import Control.Concurrent.Async@@ -7,19 +9,22 @@ 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 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 Distribution.PackageDescription.TH+import qualified Graphics.Vty as Vty+import Graphics.Vty.Input.Events hiding (Event) import Graphics.Vty.Picture-import Pipes as P+import Language.Haskell.TH+import Pipes as P import Pipes.Concurrent-import qualified Pipes.Prelude as P+import qualified Pipes.Prelude as P import System.Directory-import System.Environment (getArgs)+import System.Environment (getArgs)+import System.Exit import System.IO import System.Posix.IO import System.Process@@ -40,12 +45,15 @@ main :: IO () main = do+ args <- getArgs+ when ("-V" `elem` args || "--version" `elem` args) (printVersion >> exitSuccess)+ when ("--help" `elem` args) (printHelp >> exitSuccess)+ 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@@ -65,6 +73,15 @@ >-> toOutput evSink runApp_ app cfg (fromInput evSource) cancel grepThread+ printVersion = do+ let version = $(packageVariable (pkgVersion . package))+ name = $(packageVariable (pkgName . package))+ putStrLn (name <> " " <> version)+ putStrLn ""+ putStrLn "grep version: "+ runEffect (grepVersion >-> P.take 1 >-> P.map (" " <>) >-> stdoutText)+ printHelp = putStrLn helpText+ where helpText = $(fmap (LitE . StringL) (runIO (readFile "help.txt"))) type MainWidget = HSplitWidget Results Pager@@ -147,7 +164,7 @@ resultsKeyBindings = dispatchMap $ fromList [ (EvKey KEnter [], loadSelectedFileToPager) ] -pagerKeyBindings :: MonadIO m => Vty.Event -> Next (VgrepT AppState m Redraw)+pagerKeyBindings :: Vty.Event -> Next (VgrepT AppState m Redraw) pagerKeyBindings = dispatchMap $ fromList [] @@ -188,7 +205,7 @@ 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 :: 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
+ src/Control/Concurrent/STM/TPQueue.hs view
@@ -0,0 +1,75 @@+-- | A transactional priority queue, based on a Finger Tree.+module Control.Concurrent.STM.TPQueue+ ( TPQueue ()+ , newTPQueue+ , newTPQueueIO+ , writeTPQueue+ , readTPQueue+ , tryReadTPQueue+ , peekTPQueue+ , tryPeekTPQueue+ , isEmptyTPQueue+ ) where++import Control.Concurrent.STM.TVar+import Control.Monad.STM+import Data.PriorityQueue.FingerTree (PQueue)+import qualified Data.PriorityQueue.FingerTree as PQueue++-- | 'TPQueue' is an unbounded priority queue based on a Finger Tree.+newtype TPQueue k v = TPQueue (TVar (PQueue k v))++mkTPQueue :: Functor f => f (TVar (PQueue k v)) -> f (TPQueue k v)+mkTPQueue = fmap TPQueue++-- | Build a new 'TPQueue'.+newTPQueue :: Ord k => STM (TPQueue k v)+newTPQueue = mkTPQueue (newTVar PQueue.empty)++-- | IO version of 'newTPQueue'. This is useful for creating top-level+-- 'TPQueues' using 'unsafePerformIO', because using 'atomically' inside+-- 'unsafePerformIO' isn't possible.+newTPQueueIO :: Ord k => IO (TPQueue k v)+newTPQueueIO = mkTPQueue (newTVarIO PQueue.empty)++-- | Write a value to a 'TPQueue'.+writeTPQueue :: Ord k => TPQueue k v -> k -> v -> STM ()+writeTPQueue (TPQueue h) k v = modifyTVar' h (PQueue.add k v)++-- | Read the next minimal value from a 'TPQueue'.+readTPQueue :: Ord k => TPQueue k v -> STM v+readTPQueue (TPQueue h) = do+ xs <- readTVar h+ case PQueue.minView xs of+ Just (x, xs') -> writeTVar h xs' >> pure x+ Nothing -> retry++-- | A version of 'readTPQueue' that does not retry, but returns 'Nothing'+-- instead if no value is available.+tryReadTPQueue :: Ord k => TPQueue k v -> STM (Maybe v)+tryReadTPQueue (TPQueue h) = do+ xs <- readTVar h+ case PQueue.minView xs of+ Just (x, xs') -> writeTVar h xs' >> pure (Just x)+ Nothing -> pure Nothing++-- | Get the next minimal value from a 'TPQueue' without removing it.+peekTPQueue :: Ord k => TPQueue k v -> STM v+peekTPQueue (TPQueue h) = do+ xs <- readTVar h+ case PQueue.minView xs of+ Just (x, _) -> pure x+ Nothing -> retry++-- | A version of 'peekTPQueue' that does not retry, but returns 'Nothing'+-- instead if no value is available.+tryPeekTPQueue :: Ord k => TPQueue k v -> STM (Maybe v)+tryPeekTPQueue (TPQueue h) = do+ xs <- readTVar h+ case PQueue.minView xs of+ Just (x, _) -> pure (Just x)+ Nothing -> pure Nothing++-- | Returns 'True' if the 'TPQueue' is empty.+isEmptyTPQueue :: Ord k => TPQueue k v -> STM Bool+isEmptyTPQueue (TPQueue h) = fmap PQueue.null (readTVar h)
src/Control/Monad/State/Extended.hs view
@@ -1,11 +1,11 @@ module Control.Monad.State.Extended- ( module Control.Monad.State+ ( module Control.Monad.State.Strict , liftState , whenS , unlessS ) where -import Control.Monad.State+import Control.Monad.State.Strict liftState :: MonadState s m => State s a -> m a liftState = state . runState
+ src/Pipes/Concurrent/PQueue.hs view
@@ -0,0 +1,73 @@+-- | A variant of "Pipes.Concurrent" that uses a Finger Tree-based Priority+-- Queue ('TPQueue.TPQueue') instead of a normal 'TQueue'.+module Pipes.Concurrent.PQueue+ ( spawn+ , withSpawn+ -- * Re-exports from "Pipes.Concurrent"+ , Input (..)+ , Output (..)+ , fromInput+ , toOutput+ ) where++import Control.Applicative+import Control.Concurrent.STM as STM+import qualified Control.Concurrent.STM.TPQueue as TPQueue+import Control.Exception (bracket)+import Control.Monad+import Pipes.Concurrent+ ( Input (..)+ , Output (..)+ , fromInput+ , toOutput+ )+++-- | Spawn a mailbox to store prioritized messages in a Mailbox. Using 'recv' on+-- the 'Input' will return 'Just' the minimal element, or 'Nothing' if the+-- mailbox is closed.+--+-- This function is analogous to+-- @"Pipes.Concurrent".'Pipes.Concurrent.spawn'' 'Pipes.Concurrent.Unbounded'@,+-- but it uses a 'TPQueue.TPQueue' instead of a 'TQueue' to store messages.+spawn :: Ord p => IO (Output (p, a), Input a, STM ())+spawn = do+ q <- TPQueue.newTPQueueIO+ sealed <- STM.newTVarIO False+ let seal = STM.writeTVar sealed True++ {- Use weak TVars to keep track of whether the 'Input' or 'Output' has been+ garbage collected. Seal the mailbox when either of them becomes garbage+ collected.+ -}+ rSend <- STM.newTVarIO ()+ void (STM.mkWeakTVar rSend (STM.atomically seal))+ rRecv <- STM.newTVarIO ()+ void (STM.mkWeakTVar rRecv (STM.atomically seal))++ let sendOrEnd p a = do+ isSealed <- readTVar sealed+ if isSealed+ then pure False+ else TPQueue.writeTPQueue q p a >> pure True++ readOrEnd = fmap Just (TPQueue.readTPQueue q)+ <|> (readTVar sealed >>= check >> pure Nothing)++ _send (p, a) = sendOrEnd p a <* readTVar rSend+ _recv = readOrEnd <* readTVar rRecv+ return (Output _send, Input _recv, seal)+{-# INLINABLE spawn #-}++-- | 'withSpawn' passes its enclosed action an 'Output' and 'Input' like you'd+-- get from 'spawn', but automatically @seal@s them after the action completes.+-- This can be used when you need the @seal@ing behavior available from 'spawn',+-- but want to work at a bit higher level:+--+-- > withSpawn buffer $ \(output, input) -> ...+--+-- 'withSpawn' is exception-safe, since it uses 'bracket' internally.+withSpawn :: Ord p => ((Output (p, a), Input a) -> IO r) -> IO r+withSpawn action = bracket spawn+ (\(_, _, seal) -> atomically seal)+ (\(output, input, _) -> action (output, input))
src/Vgrep/App.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Vgrep.App ( App(..) , runApp, runApp_@@ -14,7 +15,7 @@ import Graphics.Vty (Vty) import qualified Graphics.Vty as Vty import Pipes hiding (next)-import Pipes.Concurrent+import Pipes.Concurrent.PQueue import Pipes.Prelude as P import System.Posix.IO import System.Posix.Types (Fd)@@ -63,16 +64,23 @@ -- '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+runApp app conf externalEvents = withSpawn $ \(evSink, evSource) -> do displayRegion <- displayRegionHack- externalEventThread <- (async . runEffect) (externalEvents >-> toOutput evSink)+ let userEventSink = contramap (User,) evSink+ systemEventSink = contramap (System,) evSink+ externalEventThread <- (async . runEffect) (externalEvents >-> toOutput systemEventSink) initialState <- initialize app- (_, finalState) <- runVgrepT (appEventLoop app evSource evSink)+ (_, finalState) <- runVgrepT (appEventLoop app evSource userEventSink) initialState (Env conf displayRegion) cancel externalEventThread pure finalState +-- | Monomorphic version of 'Data.Functor.Contravariant.contramap', to+-- avoid having to update pipes-concurrency.+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@@ -96,15 +104,17 @@ 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+ eventLoop vty = go+ where+ go = do+ event <- await+ currentState <- get+ case handleAppEvent event 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@@ -118,6 +128,10 @@ 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)
src/Vgrep/System/Grep.hs view
@@ -4,6 +4,7 @@ ( grep , grepForApp , recursiveGrep+ , grepVersion ) where import Control.Concurrent@@ -69,12 +70,18 @@ (_hIn, hOut) <- createGrepProcess grepArgs streamResultsFrom hOut -recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered :: String+grepVersion :: Producer Text IO ()+grepVersion = do+ (_, hOut) <- createGrepProcess [version]+ streamResultsFrom hOut++recursive, withFileName, withLineNumber, skipBinaryFiles, lineBuffered, version :: String recursive = "-r" withFileName = "-H" withLineNumber = "-n" skipBinaryFiles = "-I" lineBuffered = "--line-buffered"+version = "--version" createGrepProcess :: MonadIO io => [String] -> io (Handle, Handle)
src/Vgrep/Widget/Pager/Internal.hs view
@@ -22,10 +22,18 @@ -- positions, and the set of highlighted line numbers. data Pager = Pager { _column :: Int+ -- ^ The current column offset for horizontal scrolling+ , _highlighted :: Set Int+ -- ^ Set of line numbers that are highlighted (i.e. they contain matches)+ , _above :: Seq Text- , _visible :: Seq Text }- deriving (Eq, Show)+ -- ^ Zipper: Lines above the screen++ , _visible :: Seq Text+ -- ^ Zipper: Lines on screen and below++ } deriving (Eq, Show) makeLenses ''Pager
src/Vgrep/Widget/Results/Internal.hs view
@@ -52,11 +52,11 @@ -- ^ 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+ !(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
test/Test/Vgrep/Widget/Results.hs view
@@ -2,10 +2,11 @@ {-# LANGUAGE LambdaCase #-} module Test.Vgrep.Widget.Results (test) where -import Control.Lens (Getter, to, view, views)+import Control.Lens (Getter, _1, over, to, view, views) import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map-import Data.Sequence (Seq)+import Data.Monoid ((<>))+import Data.Sequence (Seq, ViewR (..)) import qualified Data.Sequence as Seq import Test.Case import Test.QuickCheck@@ -23,8 +24,7 @@ } , TestInvariant { description = "Scrolling one page down and up keeps selected line"- , testData = arbitrary- `suchThat` lastLineOnScreen+ , testData = fmap moveToLastLineOnScreen arbitrary `suchThat` \(results, env) -> linesBelowCurrent (> screenHeight env) results , testCase = run (pageDown >> pageUp) , invariant = selectedLine@@ -81,10 +81,12 @@ screenHeight :: Environment -> Int screenHeight = view (region . to regionHeight) -lastLineOnScreen :: (Results, Environment) -> Bool-lastLineOnScreen (results, _env) = case results of- EmptyResults -> True- Results _ _ _ ds _ -> null ds+moveToLastLineOnScreen :: (Results, Environment) -> (Results, Environment)+moveToLastLineOnScreen = over _1 $ \case+ EmptyResults -> EmptyResults+ Results as bs c ds es -> case Seq.viewr ds of+ EmptyR -> Results as bs c ds es+ ds' :> d -> Results as (Seq.reverse ds' <> pure c <> bs) d Seq.empty es lastLine :: (Results, Environment) -> Bool lastLine (results, _env) = case results of
vgrep.cabal view
@@ -1,7 +1,16 @@ name: vgrep-version: 0.1.3.0+version: 0.1.4.0 synopsis: A pager for grep-description: Please see README.md+description: + @vgrep@ is a pager for navigating through @grep@ output.+ .+ Usage:+ .+ > grep -rn foo | vgrep+ > vgrep foo /some/path+ > vgrep foo /some/path | vgrep bar+ .+ <<https://raw.githubusercontent.com/fmthoma/vgrep/master/vgrep.png>> homepage: http://github.com/fmthoma/vgrep#readme license: BSD3 license-file: LICENSE@@ -18,11 +27,13 @@ ghc-options: -Wall default-extensions: LambdaCase , MultiWayIf- exposed-Modules: Control.Monad.State.Extended+ exposed-Modules: Control.Concurrent.STM.TPQueue+ , Control.Monad.State.Extended+ , Pipes.Concurrent.PQueue , Vgrep.App- , Vgrep.Event , Vgrep.Environment , Vgrep.Environment.Config+ , Vgrep.Event , Vgrep.Parser , Vgrep.Results , Vgrep.System.Grep@@ -37,20 +48,22 @@ , 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+ , async >= 2.0.2+ , attoparsec >= 0.12.1.6+ , containers >= 0.5.6.2+ , fingertree >= 0.1.1+ , lens >= 4.13+ , lifted-base >= 0.2.3.6+ , mmorph >= 1.0.4+ , mtl >= 2.2.1+ , pipes >= 4.1.6+ , pipes-concurrency >= 2.0.3+ , process >= 1.2.3+ , stm >= 2.4.4+ , text >= 1.2.1.3+ , transformers >= 0.4.2+ , unix >= 2.7.1+ , vty >= 5.4.0 default-language: Haskell2010 executable vgrep@@ -59,19 +72,21 @@ 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+ build-depends: base >= 4.8 && < 5+ , async >= 2.0.2+ , cabal-file-th >= 0.2.3+ , containers >= 0.5.6.2+ , directory >= 1.2.2+ , lens >= 4.13+ , mtl >= 2.2.1+ , 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+ , vty >= 5.4.0 default-language: Haskell2010 test-suite vgrep-test