{-# 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
    , currentFileResults

    -- * Re-exports
    , 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

-- | 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.
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


-- | 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 :: 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

-- | Move up/down one results page. File group headers will be skipped.
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

-- | Move up/down one results line. File group headers will be skipped.
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) -- because line numbers are padded,
                               -- see `justifyRight` below

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