diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/Control/Concurrent/STM/TPQueue.hs b/src/Control/Concurrent/STM/TPQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TPQueue.hs @@ -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) diff --git a/src/Control/Monad/State/Extended.hs b/src/Control/Monad/State/Extended.hs --- a/src/Control/Monad/State/Extended.hs +++ b/src/Control/Monad/State/Extended.hs @@ -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 diff --git a/src/Pipes/Concurrent/PQueue.hs b/src/Pipes/Concurrent/PQueue.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Concurrent/PQueue.hs @@ -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)) diff --git a/src/Vgrep/App.hs b/src/Vgrep/App.hs --- a/src/Vgrep/App.hs +++ b/src/Vgrep/App.hs @@ -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) 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 @@ -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) 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 @@ -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 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 @@ -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 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,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 diff --git a/vgrep.cabal b/vgrep.cabal --- a/vgrep.cabal +++ b/vgrep.cabal @@ -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 + . + <> 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