vgrep-0.2.3.0: app/Main.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main (main) where
import Control.Concurrent.Async
import Control.Lens.Compat
import Control.Monad.Reader
import Data.Maybe
import Data.Ratio
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import Data.Version (showVersion)
import qualified Graphics.Vty as Vty
import Graphics.Vty.Input.Events hiding (Event)
import Graphics.Vty.Picture
import Language.Haskell.TH
import Pipes as P
import Pipes.Concurrent
import qualified Pipes.Prelude as P
import System.Directory
import System.Environment (getArgs)
import System.Exit
import System.IO
import System.Process
import System.Posix.IO
import Paths_vgrep
import Vgrep.App as App
import Vgrep.Command
import Vgrep.Environment
import Vgrep.Event
import qualified Vgrep.Key as Key
import qualified Vgrep.KeybindingMap as KeybindingMap
import Vgrep.Parser
import Vgrep.System.Grep
import Vgrep.Text
import Vgrep.Type
import qualified Vgrep.Widget as Widget
import Vgrep.Widget.HorizontalSplit
import Vgrep.Widget.Pager
import Vgrep.Widget.Results
main :: IO ()
main = do
args <- getArgs
when ("-V" `elem` args || "--version" `elem` args) (printVersion >> exitSuccess)
when ("--help" `elem` args) (printHelp >> exitSuccess)
when ("--dump-default-config" `elem` args) (printDefaultConfig >> exitSuccess)
hSetBuffering stdin LineBuffering
hSetBuffering stdout LineBuffering
cfg <- loadConfig mempty
inputFromTerminal <- hIsTerminalDevice stdin
outputToTerminal <- hIsTerminalDevice stdout
case (inputFromTerminal, outputToTerminal) of
(True, False) -> runHeadless (const recursiveGrep)
(False, False)
| null args -> doNothingJustPipe
| otherwise -> 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
doNothingJustPipe = runEffect (P.stdinLn >-> P.stdoutLn)
printVersion = do
putStrLn ("vgrep " <> showVersion version)
putStrLn ""
putStrLn "grep version: "
runEffect (grepVersion >-> P.take 1 >-> P.map (" " <>) >-> stdoutText)
printHelp = putStrLn helpText
where helpText = $(runIO (readFile "help.txt") >>= stringE)
printDefaultConfig = putStrLn defaultConfigFile
where defaultConfigFile = $(runIO (readFile "config.yaml.example") >>= stringE)
type MainWidget = HSplitWidget Results Pager
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 (Widget.draw mainWidget))
mainWidget :: MainWidget
mainWidget = hSplitWidget resultsWidget pagerWidget
---------------------------------------------------------------------------
-- Events
eventHandler
:: MonadIO m
=> Event
-> Environment
-> AppState
-> Next (VgrepT AppState m Redraw)
eventHandler = \case
ReceiveInputEvent line -> \_ _ -> handleFeedInput line
ReceiveResultEvent line -> \_ _ -> handleFeedResult line
VtyEvent event -> handleVty event
where
handleFeedResult, handleFeedInput
:: MonadIO m
=> Text
-> Next (VgrepT AppState m Redraw)
handleFeedResult line = Continue $ case parseLine line of
Just l -> do
l' <- traverseOf (lineReference . lineText) expandFormattedLine l
zoom results (feedResult l')
Nothing -> pure Unchanged
handleFeedInput line = Continue $ do
expandedLine <- expandLineForDisplay line
modifying inputLines (|> expandedLine)
pure Unchanged
handleVty
:: MonadIO m
=> Vty.Event
-> Environment
-> AppState
-> Next (VgrepT AppState m Redraw)
handleVty = \case
EvResize w h -> \_ _ -> handleResizeEvent w h
ev | Just chord <- Key.fromVty ev -> handleKeyEvent chord
| otherwise -> \_ _ -> Skip
handleResizeEvent :: Monad m => Int -> Int -> Next (VgrepT AppState m Redraw)
handleResizeEvent w h = Continue $ do
modifyEnvironment . set viewport $
Viewport { _vpWidth = w, _vpHeight = h }
pure Redraw
handleKeyEvent
:: MonadIO m
=> Key.Chord
-> Environment
-> AppState
-> Next (VgrepT AppState m Redraw)
handleKeyEvent chord environment state =
executeCommand command state
where
globalBindings = view (config . keybindings . globalKeybindings) environment
resultsBindings = view (config . keybindings . resultsKeybindings) environment
pagerBindings = view (config . keybindings . pagerKeybindings) environment
localBindings = case view (widgetState . currentWidget) state of
Left _ -> resultsBindings
Right _ -> pagerBindings
lookupCmd = fromMaybe Unset . KeybindingMap.lookup chord
command = case lookupCmd localBindings of
Unset -> lookupCmd globalBindings
defined -> defined
executeCommand :: MonadIO m => Command -> AppState -> Next (VgrepT AppState m Redraw)
executeCommand = \case
Unset -> skip
DisplayPagerOnly -> continue (zoom widgetState rightOnly)
DisplayResultsOnly -> continue (zoom widgetState leftOnly)
SplitFocusPager -> continue splitViewPager
SplitFocusResults -> continue splitViewResults
PagerUp -> continue (zoom pager (scroll (-1)))
PagerDown -> continue (zoom pager (scroll 1))
PagerPageUp -> continue (zoom pager (scrollPage (-1)))
PagerPageDown -> continue (zoom pager (scrollPage 1))
PagerHalfPageUp -> continue (zoom pager (scrollPageFraction (-1%2)))
PagerHalfPageDown -> continue (zoom pager (scrollPageFraction (1%2)))
PagerScrollLeft -> continue (zoom pager (hScroll (-1)))
PagerScrollRight -> continue (zoom pager (hScroll 1))
ResultsUp -> continue (zoom results prevLine >> pure Redraw)
ResultsDown -> continue (zoom results nextLine >> pure Redraw)
ResultsPageUp -> continue (zoom results pageUp >> pure Redraw)
ResultsPageDown -> continue (zoom results pageDown >> pure Redraw)
PrevResult -> continue (zoom results prevLine >> loadSelectedFileToPager)
NextResult -> continue (zoom results nextLine >> loadSelectedFileToPager)
PagerGotoResult -> continue (loadSelectedFileToPager >> splitViewPager)
OpenFileInEditor -> invokeEditor
Exit -> halt
where
continue = const . Continue
skip = const Skip
halt = const (Interrupt Halt)
splitViewPager, splitViewResults :: Monad m => VgrepT AppState m Redraw
splitViewPager = zoom widgetState (splitView FocusRight (1 % 3))
splitViewResults = zoom widgetState (splitView FocusLeft (2 % 3))
loadSelectedFileToPager :: MonadIO m => VgrepT AppState m Redraw
loadSelectedFileToPager = do
maybeFileName <- use (results . currentFileName . to (fmap T.unpack))
whenJust maybeFileName $ \selectedFile -> do
fileExists <- liftIO (doesFileExist selectedFile)
fileContent <- if fileExists
then readLinesFrom selectedFile
else use inputLines
displayContent <- expandForDisplay fileContent
highlightedLines <- use (results . currentFileResults)
zoom pager (replaceBufferContents displayContent highlightedLines)
moveToSelectedLineNumber
pure Redraw
where
readLinesFrom f = liftIO $ do
content <- TL.readFile f
pure (fileLines content)
fileLines = S.fromList . map TL.toStrict . TL.lines
moveToSelectedLineNumber :: Monad m => VgrepT AppState m ()
moveToSelectedLineNumber =
use (results . currentLineNumber)
>>= (`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 :: AppState -> Next (VgrepT AppState m Redraw)
invokeEditor state = case view (results . currentFileName . to (fmap T.unpack)) state of
Just selectedFile -> Interrupt $ Suspend $ \environment -> do
let configuredEditor = view (config . editor) environment
selectedLineNumber = view (results . currentLineNumber . to (fromMaybe 0)) state
liftIO $ doesFileExist selectedFile >>= \case
True -> exec configuredEditor ['+' : show selectedLineNumber, selectedFile]
False -> hPutStrLn stderr ("File not found: " ++ show selectedFile)
Nothing -> Skip
exec :: MonadIO io => FilePath -> [String] -> io ()
exec command args = liftIO $ do
tty <- openFd "/dev/tty" ReadWrite Nothing defaultFileFlags >>= fdToHandle
(_,_,_,h) <- createProcess (proc command args) {std_in = UseHandle tty}
void (waitForProcess h)
hClose tty
---------------------------------------------------------------------------
-- 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