{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Vgrep.Widget.Results (
resultsWidget
, ResultsWidget
, Results ()
, feedResult
, resizeToWindow
, prevLine
, nextLine
, pageUp
, pageDown
, currentFileName
, currentLineNumber
, currentFileResults
, module Vgrep.Results
) where
import Control.Applicative
import Control.Lens.Compat
import Control.Monad.State.Extended
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Graphics.Vty.Attributes
import Graphics.Vty.Image hiding ((<|>))
import Vgrep.Ansi
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
resultsWidget :: ResultsWidget
resultsWidget :: ResultsWidget
resultsWidget =
Widget :: forall s.
s
-> (forall (m :: * -> *). Monad m => VgrepT s m Image) -> Widget s
Widget { initialize :: Results
initialize = Results
initResults
, draw :: forall (m :: * -> *). Monad m => VgrepT Results m Image
draw = forall (m :: * -> *). Monad m => VgrepT Results m Image
renderResultList }
initResults :: Results
initResults :: Results
initResults = Results
EmptyResults
feedResult :: Monad m => FileLineReference -> VgrepT Results m Redraw
feedResult :: FileLineReference -> VgrepT Results m Redraw
feedResult FileLineReference
line = do
(Results -> Results) -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FileLineReference -> Results -> Results
feed FileLineReference
line)
VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
pageUp, pageDown :: Monad m => VgrepT Results m ()
pageUp :: VgrepT Results m ()
pageUp = do
(Results -> Bool) -> VgrepT Results m () -> VgrepT Results m ()
forall s (m :: * -> *).
MonadState s m =>
(s -> Bool) -> m () -> m ()
unlessS (Maybe Results -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Results -> Bool)
-> (Results -> Maybe Results) -> Results -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Results -> Maybe Results
moveUp) (VgrepT Results m () -> VgrepT Results m ())
-> VgrepT Results m () -> VgrepT Results m ()
forall a b. (a -> b) -> a -> b
$ do
(Results -> Results) -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Results -> Maybe Results) -> Results -> Results
forall a. (a -> Maybe a) -> a -> a
repeatedly (Results -> Maybe Results
hideNext (Results -> Maybe Results)
-> (Results -> Maybe Results) -> Results -> Maybe Results
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Results -> Maybe Results
showPrev))
VgrepT Results m Redraw -> VgrepT Results m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
(Results -> Results) -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Results -> Maybe Results) -> Results -> Results
forall a. (a -> Maybe a) -> a -> a
repeatedly Results -> Maybe Results
moveUp)
pageDown :: VgrepT Results m ()
pageDown = do
(Results -> Bool) -> VgrepT Results m () -> VgrepT Results m ()
forall s (m :: * -> *).
MonadState s m =>
(s -> Bool) -> m () -> m ()
unlessS (Maybe Results -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Results -> Bool)
-> (Results -> Maybe Results) -> Results -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Results -> Maybe Results
moveDown) (VgrepT Results m () -> VgrepT Results m ())
-> VgrepT Results m () -> VgrepT Results m ()
forall a b. (a -> b) -> a -> b
$ do
(Results -> Results) -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Results -> Maybe Results) -> Results -> Results
forall a. (a -> Maybe a) -> a -> a
repeatedly Results -> Maybe Results
hidePrev)
VgrepT Results m Redraw -> VgrepT Results m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
(Results -> Results) -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Results -> Maybe Results) -> Results -> Results
forall a. (a -> Maybe a) -> a -> a
repeatedly Results -> Maybe Results
moveDown)
repeatedly :: (a -> Maybe a) -> a -> a
repeatedly :: (a -> Maybe a) -> a -> a
repeatedly a -> Maybe a
f = a -> a
go
where
go :: a -> a
go a
x | Just a
x' <- a -> Maybe a
f a
x = a -> a
go a
x'
| Bool
otherwise = a
x
prevLine, nextLine :: Monad m => VgrepT Results m ()
prevLine :: VgrepT Results m ()
prevLine = (Results -> Maybe Results) -> VgrepT Results m ()
forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> VgrepT s m ()
maybeModify Results -> Maybe Results
tryPrevLine VgrepT Results m () -> VgrepT Results m () -> VgrepT Results m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VgrepT Results m Redraw -> VgrepT Results m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
nextLine :: VgrepT Results m ()
nextLine = (Results -> Maybe Results) -> VgrepT Results m ()
forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> VgrepT s m ()
maybeModify Results -> Maybe Results
tryNextLine VgrepT Results m () -> VgrepT Results m () -> VgrepT Results m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VgrepT Results m Redraw -> VgrepT Results m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
tryPrevLine, tryNextLine :: Results -> Maybe Results
tryPrevLine :: Results -> Maybe Results
tryPrevLine Results
buf = Results -> Maybe Results
moveUp Results
buf Maybe Results -> Maybe Results -> Maybe Results
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Results -> Maybe Results
showPrev Results
buf Maybe Results -> (Results -> Maybe Results) -> Maybe Results
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Results -> Maybe Results
tryPrevLine)
tryNextLine :: Results -> Maybe Results
tryNextLine Results
buf = Results -> Maybe Results
moveDown Results
buf Maybe Results -> Maybe Results -> Maybe Results
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Results -> Maybe Results
showNext Results
buf Maybe Results -> (Results -> Maybe Results) -> Maybe Results
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Results -> Maybe Results
tryNextLine)
maybeModify :: Monad m => (s -> Maybe s) -> VgrepT s m ()
maybeModify :: (s -> Maybe s) -> VgrepT s m ()
maybeModify s -> Maybe s
f = do
s
s <- VgrepT s m s
forall s (m :: * -> *). MonadState s m => m s
get
case s -> Maybe s
f s
s of
Just s
s' -> s -> VgrepT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s'
Maybe s
Nothing -> () -> VgrepT s m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
renderResultList :: Monad m => VgrepT Results m Image
renderResultList :: VgrepT Results m Image
renderResultList = do
VgrepT Results m Redraw -> VgrepT Results m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void VgrepT Results m Redraw
forall (m :: * -> *). Monad m => VgrepT Results m Redraw
resizeToWindow
[DisplayLine]
visibleLines <- Getting [DisplayLine] Results [DisplayLine]
-> VgrepT Results m [DisplayLine]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Results -> [DisplayLine]) -> SimpleGetter Results [DisplayLine]
forall s a. (s -> a) -> SimpleGetter s a
to Results -> [DisplayLine]
toLines)
Int
width <- Getting Int Environment Int -> VgrepT Results m Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Environment Int
Lens' Environment Int
viewportWidth
let render :: DisplayLine -> VgrepT Results m Image
render = Int -> Int -> DisplayLine -> VgrepT Results m Image
forall (m :: * -> *).
Monad m =>
Int -> Int -> DisplayLine -> VgrepT Results m Image
renderLine Int
width ([DisplayLine] -> Int
lineNumberWidth [DisplayLine]
visibleLines)
[Image]
renderedLines <- (DisplayLine -> VgrepT Results m Image)
-> [DisplayLine] -> VgrepT Results m [Image]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DisplayLine -> VgrepT Results m Image
render [DisplayLine]
visibleLines
Image -> VgrepT Results m Image
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Image] -> Image
vertCat [Image]
renderedLines)
where lineNumberWidth :: [DisplayLine] -> Int
lineNumberWidth
= (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0
([Int] -> Int) -> ([DisplayLine] -> [Int]) -> [DisplayLine] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
twoExtraSpaces (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (Int -> [Char]) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show)
([Int] -> [Int])
-> ([DisplayLine] -> [Int]) -> [DisplayLine] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DisplayLine -> Maybe Int) -> [DisplayLine] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DisplayLine -> Maybe Int
displayLineNumber
twoExtraSpaces :: Int -> Int
twoExtraSpaces = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
renderLine
:: Monad m
=> Int
-> Int
-> DisplayLine
-> VgrepT Results m Image
renderLine :: Int -> Int -> DisplayLine -> VgrepT Results m Image
renderLine Int
width Int
lineNumberWidth DisplayLine
displayLine = do
Attr
fileHeaderStyle <- Getting Attr Environment Attr -> VgrepT Results m Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment
Lens' Environment Config
config ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment)
-> ((Attr -> Const Attr Attr) -> Config -> Const Attr Config)
-> Getting Attr Environment Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Colors -> Const Attr Colors) -> Config -> Const Attr Config
Lens' Config Colors
colors ((Colors -> Const Attr Colors) -> Config -> Const Attr Config)
-> ((Attr -> Const Attr Attr) -> Colors -> Const Attr Colors)
-> (Attr -> Const Attr Attr)
-> Config
-> Const Attr Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Const Attr Attr) -> Colors -> Const Attr Colors
Lens' Colors Attr
fileHeaders)
Attr
lineNumberStyle <- Getting Attr Environment Attr -> VgrepT Results m Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment
Lens' Environment Config
config ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment)
-> ((Attr -> Const Attr Attr) -> Config -> Const Attr Config)
-> Getting Attr Environment Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Colors -> Const Attr Colors) -> Config -> Const Attr Config
Lens' Config Colors
colors ((Colors -> Const Attr Colors) -> Config -> Const Attr Config)
-> ((Attr -> Const Attr Attr) -> Colors -> Const Attr Colors)
-> (Attr -> Const Attr Attr)
-> Config
-> Const Attr Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Const Attr Attr) -> Colors -> Const Attr Colors
Lens' Colors Attr
lineNumbers)
Attr
resultLineStyle <- Getting Attr Environment Attr -> VgrepT Results m Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment
Lens' Environment Config
config ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment)
-> ((Attr -> Const Attr Attr) -> Config -> Const Attr Config)
-> Getting Attr Environment Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Colors -> Const Attr Colors) -> Config -> Const Attr Config
Lens' Config Colors
colors ((Colors -> Const Attr Colors) -> Config -> Const Attr Config)
-> ((Attr -> Const Attr Attr) -> Colors -> Const Attr Colors)
-> (Attr -> Const Attr Attr)
-> Config
-> Const Attr Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Const Attr Attr) -> Colors -> Const Attr Colors
Lens' Colors Attr
normal)
Attr
selectedStyle <- Getting Attr Environment Attr -> VgrepT Results m Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment
Lens' Environment Config
config ((Config -> Const Attr Config)
-> Environment -> Const Attr Environment)
-> ((Attr -> Const Attr Attr) -> Config -> Const Attr Config)
-> Getting Attr Environment Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Colors -> Const Attr Colors) -> Config -> Const Attr Config
Lens' Config Colors
colors ((Colors -> Const Attr Colors) -> Config -> Const Attr Config)
-> ((Attr -> Const Attr Attr) -> Colors -> Const Attr Colors)
-> (Attr -> Const Attr Attr)
-> Config
-> Const Attr Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Const Attr Attr) -> Colors -> Const Attr Colors
Lens' Colors Attr
selected)
Image -> VgrepT Results m Image
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Image -> VgrepT Results m Image)
-> Image -> VgrepT Results m Image
forall a b. (a -> b) -> a -> b
$ case DisplayLine
displayLine of
FileHeader (File Text
f)
-> Attr -> Text -> Image
renderFileHeader Attr
fileHeaderStyle Text
f
Line (LineReference Maybe Int
n AnsiFormatted
t)
-> [Image] -> Image
horizCat [ Attr -> Maybe Int -> Image
renderLineNumber Attr
lineNumberStyle Maybe Int
n
, Attr -> AnsiFormatted -> Image
renderLineText Attr
resultLineStyle AnsiFormatted
t ]
SelectedLine (LineReference Maybe Int
n AnsiFormatted
t)
-> [Image] -> Image
horizCat [ Attr -> Maybe Int -> Image
renderLineNumber Attr
lineNumberStyle Maybe Int
n
, Attr -> AnsiFormatted -> Image
renderLineText Attr
selectedStyle AnsiFormatted
t ]
where
padWithSpace :: a -> Text -> Text
padWithSpace a
w = Int -> Text -> Text
T.take (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> Text -> Text
T.justifyLeft (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) Char
' '
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
' '
justifyRight :: a -> Text -> Text
justifyRight a
w Text
s = Int -> Char -> Text -> Text
T.justifyRight (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) Char
' ' (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")
renderFileHeader :: Attr -> Text -> Image
renderFileHeader :: Attr -> Text -> Image
renderFileHeader Attr
attr = Attr -> Text -> Image
text' Attr
attr (Text -> Image) -> (Text -> Text) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
forall a. Integral a => a -> Text -> Text
padWithSpace Int
width
renderLineNumber :: Attr -> Maybe Int -> Image
renderLineNumber :: Attr -> Maybe Int -> Image
renderLineNumber Attr
attr = Attr -> Text -> Image
text' Attr
attr
(Text -> Image) -> (Maybe Int -> Text) -> Maybe Int -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
forall a. Integral a => a -> Text -> Text
justifyRight Int
lineNumberWidth
(Text -> Text) -> (Maybe Int -> Text) -> Maybe Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ([Char] -> Text
T.pack ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show)
renderLineText :: Attr -> AnsiFormatted -> Image
renderLineText :: Attr -> AnsiFormatted -> Image
renderLineText Attr
attr AnsiFormatted
txt
= Attr -> AnsiFormatted -> Image
renderAnsi Attr
attr
(AnsiFormatted -> Image)
-> (AnsiFormatted -> AnsiFormatted) -> AnsiFormatted -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> AnsiFormatted -> AnsiFormatted
forall a. Int -> Formatted a -> Formatted a
takeFormatted (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNumberWidth)
(AnsiFormatted -> AnsiFormatted)
-> (AnsiFormatted -> AnsiFormatted)
-> AnsiFormatted
-> AnsiFormatted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> AnsiFormatted -> AnsiFormatted
forall a. Int -> Char -> Formatted a -> Formatted a
padFormatted (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNumberWidth) Char
' '
(AnsiFormatted -> Image) -> AnsiFormatted -> Image
forall a b. (a -> b) -> a -> b
$ [AnsiFormatted] -> AnsiFormatted
forall attr.
(Eq attr, Monoid attr) =>
[Formatted attr] -> Formatted attr
cat [ Text -> AnsiFormatted
forall attr. Text -> Formatted attr
bare Text
" ", AnsiFormatted
txt, Text -> AnsiFormatted
forall attr. Text -> Formatted attr
bare (Int -> Text -> Text
T.replicate Int
width Text
" ") ]
resizeToWindow :: Monad m => VgrepT Results m Redraw
resizeToWindow :: VgrepT Results m Redraw
resizeToWindow = do
Int
height <- Getting Int Environment Int -> VgrepT Results m Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Environment Int
Lens' Environment Int
viewportHeight
Results
currentBuffer <- VgrepT Results m Results
forall s (m :: * -> *). MonadState s m => m s
get
case Int -> Results -> Maybe Results
Internal.resize Int
height Results
currentBuffer of
Just Results
resizedBuffer -> Results -> VgrepT Results m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Results
resizedBuffer VgrepT Results m ()
-> VgrepT Results m Redraw -> VgrepT Results m Redraw
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Redraw -> VgrepT Results m Redraw
forall (f :: * -> *) a. Applicative f => a -> f a
pure Redraw
Redraw
Maybe Results
Nothing -> Redraw -> VgrepT Results m Redraw
forall (f :: * -> *) a. Applicative f => a -> f a
pure Redraw
Unchanged