module Vgrep.Widget.Pager (
pagerWidget
, PagerWidget
, Pager ()
, 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 (Text)
import qualified Data.Text 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
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
replaceBufferContents
:: Monad m
=> Seq Text
-> [Int]
-> VgrepT Pager m ()
replaceBufferContents newContent newHighlightedLines = put initPager
{ _visible = newContent
, _highlighted = Set.fromList newHighlightedLines }
moveToLine :: Monad m => Int -> VgrepT Pager m Redraw
moveToLine n = views region regionHeight >>= \height -> do
setPosition (n height `div` 2)
pure Redraw
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 }
scrollPage :: Monad m => Int -> VgrepT Pager m Redraw
scrollPage n = view region >>= \displayRegion ->
let height = regionHeight displayRegion
in scroll (n * (height 1))
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 ++ " "