module Vgrep.Widget.Pager (
pagerWidget
, PagerWidget
, Pager ()
, moveToLine
, scroll
, scrollPage
, scrollPageFraction
, hScroll
, replaceBufferContents
) where
import Control.Applicative (liftA2)
import Control.Lens.Compat hiding ((:<), (:>))
import Data.Foldable
import qualified Data.IntMap.Strict as Map
import Data.Monoid ((<>))
import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import Graphics.Vty.Attributes
import Graphics.Vty.Image
import Vgrep.Ansi
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 }
initPager :: Pager
initPager = Pager
{ _column = 0
, _highlighted = Map.empty
, _above = Seq.empty
, _visible = Seq.empty }
replaceBufferContents
:: Monad m
=> Seq Text
-> Map.IntMap AnsiFormatted
-> VgrepT Pager m ()
replaceBufferContents newContent newHighlightedLines = put initPager
{ _visible = newContent
, _highlighted = newHighlightedLines }
moveToLine :: Monad m => Int -> VgrepT Pager m Redraw
moveToLine n = view viewportHeight >>= \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 = view viewportHeight >>= \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 viewportHeight >>= \height ->
scroll (n * (height 1))
scrollPageFraction :: Monad m => Rational -> VgrepT Pager m Redraw
scrollPageFraction a = view viewportHeight >>= \height ->
scroll (round (a * (fromIntegral 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 <- view viewportWidth
height <- view viewportHeight
startPosition <- use position
startColumn <- use (column . to fromIntegral)
visibleLines <- use (visible . to (Seq.take height) . to toList)
highlightedLines <- use highlighted
let (renderedLineNumbers, renderedTextLines)
= over both fold
. unzip
. map renderLine
$ zip [startPosition+1..] visibleLines
where
renderLine :: (Int, Text) -> (Image, Image)
renderLine (num, txt) = case Map.lookup num highlightedLines of
Just formatted -> ( renderLineNumber lineNumberColorHl num
, renderFormatted textColorHl formatted )
Nothing -> ( renderLineNumber lineNumberColor num
, renderLineText textColor txt )
renderLineNumber :: Attr -> Int -> Image
renderLineNumber attr
= text' attr
. (`snoc` ' ')
. cons ' '
. T.pack
. show
renderLineText :: Attr -> Text -> Image
renderLineText attr
= text' attr
. T.justifyLeft width ' '
. T.take width
. cons ' '
. T.drop startColumn
renderFormatted :: Attr -> AnsiFormatted -> Image
renderFormatted attr
= renderAnsi attr
. padFormatted width ' '
. takeFormatted width
. (bare " " <>)
. dropFormatted startColumn
pure (resizeWidth width (renderedLineNumbers <|> renderedTextLines))