Results.hs

{-# 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 =
    Widget { initialize = initResults
           , draw       = renderResultList }

initResults :: Results
initResults = 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 line = do
    modify (feed line)
    resizeToWindow

-- | Move up/down one results page. File group headers will be skipped.
pageUp, pageDown :: Monad m => VgrepT Results m ()
pageUp = do
    unlessS (isJust . moveUp) $ do
        modify (repeatedly (hideNext >=> showPrev))
        void resizeToWindow
    modify (repeatedly moveUp)
pageDown = do
    unlessS (isJust . moveDown) $ do
        modify (repeatedly hidePrev)
        void resizeToWindow
    modify (repeatedly moveDown)

repeatedly :: (a -> Maybe a) -> a -> a
repeatedly f = go
  where
    go x | Just x' <- f x = go x'
         | otherwise      = x

-- | Move up/down one results line. File group headers will be skipped.
prevLine, nextLine :: Monad m => VgrepT Results m ()
prevLine = maybeModify tryPrevLine >> void resizeToWindow
nextLine = maybeModify tryNextLine >> void resizeToWindow

tryPrevLine, tryNextLine :: Results -> Maybe Results
tryPrevLine buf = moveUp   buf <|> (showPrev buf >>= tryPrevLine)
tryNextLine buf = moveDown buf <|> (showNext buf >>= tryNextLine)

maybeModify :: Monad m => (s -> Maybe s) -> VgrepT s m ()
maybeModify f = do
    s <- get
    case f s of
        Just s' -> put s'
        Nothing -> pure ()


renderResultList :: Monad m => VgrepT Results m Image
renderResultList = do
    void resizeToWindow
    visibleLines <- use (to toLines)
    width <- view viewportWidth
    let render = renderLine width (lineNumberWidth visibleLines)
    renderedLines <- traverse render visibleLines
    pure (vertCat renderedLines)
  where lineNumberWidth
            = foldl' max 0
            . map (twoExtraSpaces . length . show)
            . mapMaybe displayLineNumber
        twoExtraSpaces = (+ 2) -- because line numbers are padded,
                               -- see `justifyRight` below

renderLine
    :: Monad m
    => Int
    -> Int
    -> DisplayLine
    -> VgrepT Results m Image
renderLine width lineNumberWidth displayLine = do
    fileHeaderStyle <- view (config . colors . fileHeaders)
    lineNumberStyle <- view (config . colors . lineNumbers)
    resultLineStyle <- view (config . colors . normal)
    selectedStyle   <- view (config . colors . selected)
    pure $ case displayLine of
        FileHeader (File f)
            -> renderFileHeader fileHeaderStyle f
        Line (LineReference n t)
            -> horizCat [ renderLineNumber lineNumberStyle n
                        , renderLineText   resultLineStyle t ]
        SelectedLine (LineReference n t)
            -> horizCat [ renderLineNumber lineNumberStyle n
                        , renderLineText   selectedStyle   t ]
  where
    padWithSpace w = T.take (fromIntegral w)
                   . T.justifyLeft (fromIntegral w) ' '
                   . T.cons ' '
    justifyRight w s = T.justifyRight (fromIntegral w) ' ' (s <> " ")

    renderFileHeader :: Attr -> Text -> Image
    renderFileHeader attr = text' attr . padWithSpace width

    renderLineNumber :: Attr -> Maybe Int -> Image
    renderLineNumber attr = text' attr
                          . justifyRight lineNumberWidth
                          . maybe "" (T.pack . show)

    renderLineText :: Attr -> AnsiFormatted -> Image
    renderLineText attr txt
        = renderAnsi attr
        . takeFormatted (width - lineNumberWidth)
        . padFormatted  (width - lineNumberWidth) ' '
        $ cat [ bare " ", txt, bare (T.replicate width " ") ]

resizeToWindow :: Monad m => VgrepT Results m Redraw
resizeToWindow = do
    height <- view viewportHeight
    currentBuffer <- get
    case Internal.resize height currentBuffer of
        Just resizedBuffer -> put resizedBuffer >> pure Redraw
        Nothing            -> pure Unchanged