diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/src/Control/Monad/State/Extended.hs b/src/Control/Monad/State/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/State/Extended.hs @@ -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) diff --git a/src/Vgrep/App.hs b/src/Vgrep/App.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/App.hs @@ -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 diff --git a/src/Vgrep/Environment.hs b/src/Vgrep/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment.hs @@ -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 diff --git a/src/Vgrep/Environment/Config.hs b/src/Vgrep/Environment/Config.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Environment/Config.hs @@ -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 } diff --git a/src/Vgrep/Event.hs b/src/Vgrep/Event.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Event.hs @@ -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) diff --git a/src/Vgrep/Parser.hs b/src/Vgrep/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Parser.hs @@ -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 } } diff --git a/src/Vgrep/Results.hs b/src/Vgrep/Results.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Results.hs @@ -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) diff --git a/src/Vgrep/System/Grep.hs b/src/Vgrep/System/Grep.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/System/Grep.hs @@ -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') diff --git a/src/Vgrep/Text.hs b/src/Vgrep/Text.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Text.hs @@ -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 + [] -> [] diff --git a/src/Vgrep/Type.hs b/src/Vgrep/Type.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Type.hs @@ -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 diff --git a/src/Vgrep/Widget.hs b/src/Vgrep/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget.hs @@ -0,0 +1,5 @@ +module Vgrep.Widget + ( module Vgrep.Widget.Type + ) where + +import Vgrep.Widget.Type diff --git a/src/Vgrep/Widget/HorizontalSplit.hs b/src/Vgrep/Widget/HorizontalSplit.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/HorizontalSplit.hs @@ -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) ] + diff --git a/src/Vgrep/Widget/HorizontalSplit/Internal.hs b/src/Vgrep/Widget/HorizontalSplit/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/HorizontalSplit/Internal.hs @@ -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 diff --git a/src/Vgrep/Widget/Pager.hs b/src/Vgrep/Widget/Pager.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/Pager.hs @@ -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 ++ " " diff --git a/src/Vgrep/Widget/Pager/Internal.hs b/src/Vgrep/Widget/Pager/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/Pager/Internal.hs @@ -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 diff --git a/src/Vgrep/Widget/Results.hs b/src/Vgrep/Widget/Results.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/Results.hs @@ -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 diff --git a/src/Vgrep/Widget/Results/Internal.hs b/src/Vgrep/Widget/Results/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/Results/Internal.hs @@ -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) diff --git a/src/Vgrep/Widget/Type.hs b/src/Vgrep/Widget/Type.hs new file mode 100644 --- /dev/null +++ b/src/Vgrep/Widget/Type.hs @@ -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. + } diff --git a/test/Data/Text/Lazy/Testable.hs b/test/Data/Text/Lazy/Testable.hs new file mode 100644 --- /dev/null +++ b/test/Data/Text/Lazy/Testable.hs @@ -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 diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,12 @@ +import Test.DocTest + +main :: IO () +main = + let extensions = + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XOverloadedStrings" ] + sourceFolders = + [ "src" + , "app" ] + in doctest (extensions ++ sourceFolders) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,7 @@ +import Test.Tasty + +import qualified Test.Vgrep.Widget as Widget + +main :: IO () +main = defaultMain $ + testGroup "Unit tests" [ Widget.test ] diff --git a/test/Test/Case.hs b/test/Test/Case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Case.hs @@ -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) diff --git a/test/Test/Vgrep/Widget.hs b/test/Test/Vgrep/Widget.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vgrep/Widget.hs @@ -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 ] diff --git a/test/Test/Vgrep/Widget/Pager.hs b/test/Test/Vgrep/Widget/Pager.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vgrep/Widget/Pager.hs @@ -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 diff --git a/test/Test/Vgrep/Widget/Results.hs b/test/Test/Vgrep/Widget/Results.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vgrep/Widget/Results.hs @@ -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]) diff --git a/test/Vgrep/Environment/Testable.hs b/test/Vgrep/Environment/Testable.hs new file mode 100644 --- /dev/null +++ b/test/Vgrep/Environment/Testable.hs @@ -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 } diff --git a/test/Vgrep/Widget/Pager/Testable.hs b/test/Vgrep/Widget/Pager/Testable.hs new file mode 100644 --- /dev/null +++ b/test/Vgrep/Widget/Pager/Testable.hs @@ -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) } diff --git a/test/Vgrep/Widget/Results/Testable.hs b/test/Vgrep/Widget/Results/Testable.hs new file mode 100644 --- /dev/null +++ b/test/Vgrep/Widget/Results/Testable.hs @@ -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) diff --git a/vgrep.cabal b/vgrep.cabal new file mode 100644 --- /dev/null +++ b/vgrep.cabal @@ -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