{-| Description: Widgets that scroll when their contents don't fit
-}
module Reflex.Vty.Widget.Scroll where

import Control.Monad.Fix
import Data.Default
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Input.Mouse

-- | Configuration options for automatic scroll-to-bottom behavior
data ScrollToBottom
  = ScrollToBottom_Always
  -- ^ Always scroll to the bottom on new output
  | ScrollToBottom_Maintain
  -- ^ Scroll down with new output only when, prior to the new output being
  -- added, the widget was scrolled all the way to the bottom.
  deriving (ScrollToBottom -> ScrollToBottom -> Bool
(ScrollToBottom -> ScrollToBottom -> Bool)
-> (ScrollToBottom -> ScrollToBottom -> Bool) -> Eq ScrollToBottom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScrollToBottom -> ScrollToBottom -> Bool
$c/= :: ScrollToBottom -> ScrollToBottom -> Bool
== :: ScrollToBottom -> ScrollToBottom -> Bool
$c== :: ScrollToBottom -> ScrollToBottom -> Bool
Eq, Eq ScrollToBottom
Eq ScrollToBottom
-> (ScrollToBottom -> ScrollToBottom -> Ordering)
-> (ScrollToBottom -> ScrollToBottom -> Bool)
-> (ScrollToBottom -> ScrollToBottom -> Bool)
-> (ScrollToBottom -> ScrollToBottom -> Bool)
-> (ScrollToBottom -> ScrollToBottom -> Bool)
-> (ScrollToBottom -> ScrollToBottom -> ScrollToBottom)
-> (ScrollToBottom -> ScrollToBottom -> ScrollToBottom)
-> Ord ScrollToBottom
ScrollToBottom -> ScrollToBottom -> Bool
ScrollToBottom -> ScrollToBottom -> Ordering
ScrollToBottom -> ScrollToBottom -> ScrollToBottom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScrollToBottom -> ScrollToBottom -> ScrollToBottom
$cmin :: ScrollToBottom -> ScrollToBottom -> ScrollToBottom
max :: ScrollToBottom -> ScrollToBottom -> ScrollToBottom
$cmax :: ScrollToBottom -> ScrollToBottom -> ScrollToBottom
>= :: ScrollToBottom -> ScrollToBottom -> Bool
$c>= :: ScrollToBottom -> ScrollToBottom -> Bool
> :: ScrollToBottom -> ScrollToBottom -> Bool
$c> :: ScrollToBottom -> ScrollToBottom -> Bool
<= :: ScrollToBottom -> ScrollToBottom -> Bool
$c<= :: ScrollToBottom -> ScrollToBottom -> Bool
< :: ScrollToBottom -> ScrollToBottom -> Bool
$c< :: ScrollToBottom -> ScrollToBottom -> Bool
compare :: ScrollToBottom -> ScrollToBottom -> Ordering
$ccompare :: ScrollToBottom -> ScrollToBottom -> Ordering
$cp1Ord :: Eq ScrollToBottom
Ord, Int -> ScrollToBottom -> ShowS
[ScrollToBottom] -> ShowS
ScrollToBottom -> String
(Int -> ScrollToBottom -> ShowS)
-> (ScrollToBottom -> String)
-> ([ScrollToBottom] -> ShowS)
-> Show ScrollToBottom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScrollToBottom] -> ShowS
$cshowList :: [ScrollToBottom] -> ShowS
show :: ScrollToBottom -> String
$cshow :: ScrollToBottom -> String
showsPrec :: Int -> ScrollToBottom -> ShowS
$cshowsPrec :: Int -> ScrollToBottom -> ShowS
Show)

-- | Configuration for the scrollable element. Controls scroll behavior.
data ScrollableConfig t = ScrollableConfig
  { ScrollableConfig t -> Event t Int
_scrollableConfig_scrollBy :: Event t Int
  -- ^ Number of lines to scroll by
  , ScrollableConfig t -> Event t ScrollPos
_scrollableConfig_scrollTo :: Event t ScrollPos
  -- ^ Specific position to scroll to
  , ScrollableConfig t -> ScrollPos
_scrollableConfig_startingPosition :: ScrollPos
  -- ^ The initial scroll position
  , ScrollableConfig t -> Behavior t (Maybe ScrollToBottom)
_scrollableConfig_scrollToBottom :: Behavior t (Maybe ScrollToBottom)
  -- ^ How the scroll position should be adjusted as new content is added
  }

instance Reflex t => Default (ScrollableConfig t) where
  def :: ScrollableConfig t
def = Event t Int
-> Event t ScrollPos
-> ScrollPos
-> Behavior t (Maybe ScrollToBottom)
-> ScrollableConfig t
forall k (t :: k).
Event t Int
-> Event t ScrollPos
-> ScrollPos
-> Behavior t (Maybe ScrollToBottom)
-> ScrollableConfig t
ScrollableConfig Event t Int
forall k (t :: k) a. Reflex t => Event t a
never Event t ScrollPos
forall k (t :: k) a. Reflex t => Event t a
never ScrollPos
ScrollPos_Top (Maybe ScrollToBottom -> Behavior t (Maybe ScrollToBottom)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ScrollToBottom
forall a. Maybe a
Nothing)

-- | The scroll position
data ScrollPos = ScrollPos_Top | ScrollPos_Line Int | ScrollPos_Bottom
  deriving (Int -> ScrollPos -> ShowS
[ScrollPos] -> ShowS
ScrollPos -> String
(Int -> ScrollPos -> ShowS)
-> (ScrollPos -> String)
-> ([ScrollPos] -> ShowS)
-> Show ScrollPos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScrollPos] -> ShowS
$cshowList :: [ScrollPos] -> ShowS
show :: ScrollPos -> String
$cshow :: ScrollPos -> String
showsPrec :: Int -> ScrollPos -> ShowS
$cshowsPrec :: Int -> ScrollPos -> ShowS
Show, ScrollPos -> ScrollPos -> Bool
(ScrollPos -> ScrollPos -> Bool)
-> (ScrollPos -> ScrollPos -> Bool) -> Eq ScrollPos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScrollPos -> ScrollPos -> Bool
$c/= :: ScrollPos -> ScrollPos -> Bool
== :: ScrollPos -> ScrollPos -> Bool
$c== :: ScrollPos -> ScrollPos -> Bool
Eq, Eq ScrollPos
Eq ScrollPos
-> (ScrollPos -> ScrollPos -> Ordering)
-> (ScrollPos -> ScrollPos -> Bool)
-> (ScrollPos -> ScrollPos -> Bool)
-> (ScrollPos -> ScrollPos -> Bool)
-> (ScrollPos -> ScrollPos -> Bool)
-> (ScrollPos -> ScrollPos -> ScrollPos)
-> (ScrollPos -> ScrollPos -> ScrollPos)
-> Ord ScrollPos
ScrollPos -> ScrollPos -> Bool
ScrollPos -> ScrollPos -> Ordering
ScrollPos -> ScrollPos -> ScrollPos
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScrollPos -> ScrollPos -> ScrollPos
$cmin :: ScrollPos -> ScrollPos -> ScrollPos
max :: ScrollPos -> ScrollPos -> ScrollPos
$cmax :: ScrollPos -> ScrollPos -> ScrollPos
>= :: ScrollPos -> ScrollPos -> Bool
$c>= :: ScrollPos -> ScrollPos -> Bool
> :: ScrollPos -> ScrollPos -> Bool
$c> :: ScrollPos -> ScrollPos -> Bool
<= :: ScrollPos -> ScrollPos -> Bool
$c<= :: ScrollPos -> ScrollPos -> Bool
< :: ScrollPos -> ScrollPos -> Bool
$c< :: ScrollPos -> ScrollPos -> Bool
compare :: ScrollPos -> ScrollPos -> Ordering
$ccompare :: ScrollPos -> ScrollPos -> Ordering
$cp1Ord :: Eq ScrollPos
Ord)

-- | The output of a 'scrollable', indicating its current scroll position.
data Scrollable t = Scrollable
  { Scrollable t -> Behavior t ScrollPos
_scrollable_scrollPosition :: Behavior t ScrollPos
  , Scrollable t -> Behavior t Int
_scrollable_totalLines :: Behavior t Int
  , Scrollable t -> Behavior t Int
_scrollable_scrollHeight :: Behavior t Int
  }

-- | Scrollable widget. The output exposes the current scroll position and
-- total number of lines (including those that are hidden)
scrollable
  :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)
  => ScrollableConfig t
  -> (m (Behavior t V.Image, Event t ()))
  -> m (Scrollable t)
scrollable :: ScrollableConfig t
-> m (Behavior t Image, Event t ()) -> m (Scrollable t)
scrollable (ScrollableConfig Event t Int
scrollBy Event t ScrollPos
scrollTo ScrollPos
startingPos Behavior t (Maybe ScrollToBottom)
onAppend) m (Behavior t Image, Event t ())
mkImg = do
  (Behavior t Image
img, Event t ()
update) <- m (Behavior t Image, Event t ())
mkImg
  let sz :: Behavior t Int
sz = Image -> Int
V.imageHeight (Image -> Int) -> Behavior t Image -> Behavior t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Image
img
  Event t KeyCombo
kup <- Key -> m (Event t KeyCombo)
forall k (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KUp
  Event t KeyCombo
kdown <- Key -> m (Event t KeyCombo)
forall k (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KDown
  Event t ScrollDirection
m <- m (Event t ScrollDirection)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t ScrollDirection)
mouseScroll
  let requestedScroll :: Event t Int
      requestedScroll :: Event t Int
requestedScroll = [Event t Int] -> Event t Int
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
        [ Int
1 Int -> Event t KeyCombo -> Event t Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kdown
        , (-Int
1) Int -> Event t KeyCombo -> Event t Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kup
        , Event t ScrollDirection -> (ScrollDirection -> Int) -> Event t Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ScrollDirection
m ((ScrollDirection -> Int) -> Event t Int)
-> (ScrollDirection -> Int) -> Event t Int
forall a b. (a -> b) -> a -> b
$ \case
            ScrollDirection
ScrollDirection_Up -> (-Int
1)
            ScrollDirection
ScrollDirection_Down -> Int
1
        , Event t Int
scrollBy
        ]
  Dynamic t Int
dh <- m (Dynamic t Int)
forall k (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  Dynamic t ScrollPos
lineIndex <- ((ScrollPos -> Maybe ScrollPos) -> ScrollPos -> Maybe ScrollPos)
-> ScrollPos
-> Event t (ScrollPos -> Maybe ScrollPos)
-> m (Dynamic t ScrollPos)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
foldDynMaybe (ScrollPos -> Maybe ScrollPos) -> ScrollPos -> Maybe ScrollPos
forall a b. (a -> b) -> a -> b
($) ScrollPos
startingPos (Event t (ScrollPos -> Maybe ScrollPos) -> m (Dynamic t ScrollPos))
-> Event t (ScrollPos -> Maybe ScrollPos)
-> m (Dynamic t ScrollPos)
forall a b. (a -> b) -> a -> b
$ [Event t (ScrollPos -> Maybe ScrollPos)]
-> Event t (ScrollPos -> Maybe ScrollPos)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ (\((Int
totalLines, Int
h), Int
d) ScrollPos
sp -> ScrollPos -> Maybe ScrollPos
forall a. a -> Maybe a
Just (ScrollPos -> Maybe ScrollPos) -> ScrollPos -> Maybe ScrollPos
forall a b. (a -> b) -> a -> b
$ ScrollPos -> Int -> Int -> Int -> ScrollPos
scrollByLines ScrollPos
sp Int
totalLines Int
h Int
d) (((Int, Int), Int) -> ScrollPos -> Maybe ScrollPos)
-> Event t ((Int, Int), Int)
-> Event t (ScrollPos -> Maybe ScrollPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t (Int, Int) -> Event t Int -> Event t ((Int, Int), Int)
forall k (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach ((,) (Int -> Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Int
sz Behavior t (Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh) Event t Int
requestedScroll
    , (\((Int
totalLines, Int
h), ScrollPos
newScrollPosition) ScrollPos
_ -> ScrollPos -> Maybe ScrollPos
forall a. a -> Maybe a
Just (ScrollPos -> Maybe ScrollPos) -> ScrollPos -> Maybe ScrollPos
forall a b. (a -> b) -> a -> b
$ case ScrollPos
newScrollPosition of
        ScrollPos_Line Int
n -> Int -> Int -> Int -> ScrollPos
scrollToLine Int
totalLines Int
h Int
n
        ScrollPos
ScrollPos_Top -> ScrollPos
ScrollPos_Top
        ScrollPos
ScrollPos_Bottom -> ScrollPos
ScrollPos_Bottom
      ) (((Int, Int), ScrollPos) -> ScrollPos -> Maybe ScrollPos)
-> Event t ((Int, Int), ScrollPos)
-> Event t (ScrollPos -> Maybe ScrollPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t (Int, Int)
-> Event t ScrollPos -> Event t ((Int, Int), ScrollPos)
forall k (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach ((,) (Int -> Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Int
sz Behavior t (Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh) Event t ScrollPos
scrollTo
    , (\Maybe ScrollToBottom
cfg ScrollPos
sp -> case Maybe ScrollToBottom
cfg of
        Just ScrollToBottom
ScrollToBottom_Always -> case ScrollPos
sp of
          ScrollPos
ScrollPos_Bottom -> Maybe ScrollPos
forall a. Maybe a
Nothing
          ScrollPos
_ -> ScrollPos -> Maybe ScrollPos
forall a. a -> Maybe a
Just ScrollPos
ScrollPos_Bottom
        Maybe ScrollToBottom
_ -> Maybe ScrollPos
forall a. Maybe a
Nothing) (Maybe ScrollToBottom -> ScrollPos -> Maybe ScrollPos)
-> Event t (Maybe ScrollToBottom)
-> Event t (ScrollPos -> Maybe ScrollPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t (Maybe ScrollToBottom)
-> Event t () -> Event t (Maybe ScrollToBottom)
forall k (t :: k) b a.
Reflex t =>
Behavior t b -> Event t a -> Event t b
tag Behavior t (Maybe ScrollToBottom)
onAppend Event t ()
update
    ]
  let imgsToTell :: Int -> ScrollPos -> Int -> Image -> Image
imgsToTell Int
height ScrollPos
scrollPos Int
totalLines Image
images = case ScrollPos
scrollPos of
        ScrollPos
ScrollPos_Bottom -> Int -> Image -> Image
V.translateY ((-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
totalLines Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height)) Image
images
        ScrollPos
ScrollPos_Top -> Image
images -- take height images
        ScrollPos_Line Int
n -> Int -> Image -> Image
V.translateY ((-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Image
images
  Behavior t [Image] -> m ()
forall k (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages (Behavior t [Image] -> m ()) -> Behavior t [Image] -> m ()
forall a b. (a -> b) -> a -> b
$ (Image -> [Image]) -> Behavior t Image -> Behavior t [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
:[]) (Behavior t Image -> Behavior t [Image])
-> Behavior t Image -> Behavior t [Image]
forall a b. (a -> b) -> a -> b
$ Int -> ScrollPos -> Int -> Image -> Image
imgsToTell (Int -> ScrollPos -> Int -> Image -> Image)
-> Behavior t Int
-> Behavior t (ScrollPos -> Int -> Image -> Image)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh Behavior t (ScrollPos -> Int -> Image -> Image)
-> Behavior t ScrollPos -> Behavior t (Int -> Image -> Image)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t ScrollPos -> Behavior t ScrollPos
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t ScrollPos
lineIndex Behavior t (Int -> Image -> Image)
-> Behavior t Int -> Behavior t (Image -> Image)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Int
sz Behavior t (Image -> Image) -> Behavior t Image -> Behavior t Image
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Image
img
  Scrollable t -> m (Scrollable t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Scrollable t -> m (Scrollable t))
-> Scrollable t -> m (Scrollable t)
forall a b. (a -> b) -> a -> b
$ Scrollable :: forall k (t :: k).
Behavior t ScrollPos
-> Behavior t Int -> Behavior t Int -> Scrollable t
Scrollable
    { _scrollable_scrollPosition :: Behavior t ScrollPos
_scrollable_scrollPosition = Dynamic t ScrollPos -> Behavior t ScrollPos
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t ScrollPos
lineIndex
    , _scrollable_totalLines :: Behavior t Int
_scrollable_totalLines = Behavior t Int
sz
    , _scrollable_scrollHeight :: Behavior t Int
_scrollable_scrollHeight = Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh
    }

-- | Modify the scroll position by the given number of lines
scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos
scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos
scrollByLines ScrollPos
sp Int
totalLines Int
height Int
delta =
  let newPos :: Int
newPos = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (ScrollPos -> Int
start ScrollPos
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta)) Int
totalLines
  in Int -> Int -> Int -> ScrollPos
scrollToLine Int
totalLines Int
height Int
newPos
  where
    start :: ScrollPos -> Int
start ScrollPos
ScrollPos_Top = Int
0
    start ScrollPos
ScrollPos_Bottom = Int
totalLines Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height
    start (ScrollPos_Line Int
n) = Int
n

-- | Scroll to a particular line
scrollToLine :: Int -> Int -> Int -> ScrollPos
scrollToLine :: Int -> Int -> Int -> ScrollPos
scrollToLine Int
totalLines Int
height Int
newPos = if
  | Int
totalLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
height -> ScrollPos
ScrollPos_Top
  | Int
newPos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> ScrollPos
ScrollPos_Top
  | Int
newPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
totalLines -> ScrollPos
ScrollPos_Bottom
  | Bool
otherwise -> Int -> ScrollPos
ScrollPos_Line Int
newPos