{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo     #-}

module Potato.Reflex.Vty.Widget.ScrollBar (
  vScrollBar
) where

import           Relude

import           Potato.Reflex.Vty.Helpers
import           Potato.Reflex.Vty.Widget


import qualified Graphics.Vty as V
import           Reflex
import           Reflex.Network
import           Reflex.Potato.Helpers
import           Reflex.Vty


import           Data.Default
import qualified Data.Sequence as Seq
import Data.Fixed (div')
import Data.These
import Data.Align (align)



emptyDrag2 :: Drag2
emptyDrag2 :: Drag2
emptyDrag2 = Drag2  {
    _drag2_from :: (Int, Int)
_drag2_from       = (Int
0,Int
0)
    , _drag2_to :: (Int, Int)
_drag2_to        = (Int
0,Int
0)
    , _drag2_button :: Button
_drag2_button    = Button
V.BLeft
    , _drag2_modifiers :: [Modifier]
_drag2_modifiers = []
    , _drag2_state :: DragState
_drag2_state     = DragState
DragStart
  }

componentSub :: (Num a) => (a,a) -> (a,a) -> (a,a)
componentSub :: forall a. Num a => (a, a) -> (a, a) -> (a, a)
componentSub (a
a,a
b) (a
c,a
d) = (a
aforall a. Num a => a -> a -> a
-a
c,a
bforall a. Num a => a -> a -> a
-a
d)

onlyIfSimultaneous :: (Reflex t) => Event t a -> Event t b -> Event t a
onlyIfSimultaneous :: forall t a b. Reflex t => Event t a -> Event t b -> Event t a
onlyIfSimultaneous Event t a
eva Event t b
evb = forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align Event t a
eva Event t b
evb) forall a b. (a -> b) -> a -> b
$ \case
  These a
a b
_ -> forall a. a -> Maybe a
Just a
a
  These a b
_ -> forall a. Maybe a
Nothing

-- TODO write UTs
-- TODO reduce constraints
vScrollBar :: forall t m a. (MonadWidget t m)
  => Dynamic t Int -- ^ content height
  -> m (Dynamic t Int) -- ^ offset
vScrollBar :: forall t (m :: * -> *) a.
MonadWidget t m =>
Dynamic t Int -> m (Dynamic t Int)
vScrollBar Dynamic t Int
contentSizeDyn = mdo
  Dynamic t Int
maxSizeDyn <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  let
    Dynamic t Float
screen_over_content_dyn :: Dynamic t Float = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Int
a Int
b -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b ) Dynamic t Int
maxSizeDyn Dynamic t Int
contentSizeDyn
    maxSizeDiffDyn :: Dynamic t Int
maxSizeDiffDyn = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-) Dynamic t Int
maxSizeDyn Dynamic t Int
boxHeightDyn

    maxContentSizeDiffDyn :: Dynamic t Float
maxContentSizeDiffDyn = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-) Dynamic t Int
contentSizeDyn Dynamic t Int
maxSizeDyn

    boxHeightDyn :: Dynamic t Int
boxHeightDyn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Num a => a -> a -> a
(*) Dynamic t Float
screen_over_content_dyn (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
maxSizeDyn)
    boxRegionDyn :: Dynamic t Region
boxRegionDyn = Int -> Int -> Int -> Int -> Region
Region forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int
offsetScreenUnitDyn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int
1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int
boxHeightDyn

  --innerDragEv will only fire on drag events that started on the scroll bar handle portion
  Event t Drag2
innerDragEv <- forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m,
 HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Region -> Dynamic t Bool -> m a -> m a
pane Dynamic t Region
boxRegionDyn (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn Bool
True) forall a b. (a -> b) -> a -> b
$ do
    -- render the scroll bar handle
    forall {k} (t :: k) (m :: * -> *).
(HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) =>
Behavior t Char -> m ()
fill (forall {k} (t :: k) a. Reflex t => a -> Behavior t a
constant Char
'#')
    forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag2)
drag2 Button
V.BLeft

  Event t Drag2
d2ev <- forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Button -> m (Event t Drag2)
drag2 Button
V.BLeft
  let
    moveDragEv :: Event t Drag2
moveDragEv = forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe (\Drag2
d2 -> if Drag2 -> DragState
_drag2_state Drag2
d2 forall a. Eq a => a -> a -> Bool
== DragState
Dragging then forall a. a -> Maybe a
Just Drag2
d2 else forall a. Maybe a
Nothing) Event t Drag2
d2ev
  Dynamic t Drag2
lastDrag <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Drag2
emptyDrag2 Event t Drag2
d2ev
  let
    deltaDragEv_d1' :: Event t (Drag2, Drag2)
deltaDragEv_d1' = forall {k} (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Drag2
lastDrag) Event t Drag2
moveDragEv
    deltaDragEv_d1 :: Event t (Int, Int)
deltaDragEv_d1 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Drag2
pd,Drag2
d) -> Drag2 -> (Int, Int)
_drag2_to Drag2
d forall a. Num a => (a, a) -> (a, a) -> (a, a)
`componentSub` Drag2 -> (Int, Int)
_drag2_to Drag2
pd) Event t (Drag2, Drag2)
deltaDragEv_d1'
    -- only process the event if they are simultaneous with innerDragEv (thus meaning they started on the scroll bar handle)
    -- the reason we need to do it this way is because `pane` messes with the mouse coords so we need to get the mouse coords from outside
    deltaDragEv :: Event t Int
deltaDragEv = forall t a b. Reflex t => Event t a -> Event t b -> Event t a
onlyIfSimultaneous (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Event t (Int, Int)
deltaDragEv_d1) Event t Drag2
innerDragEv

  let
    content_over_screen_dyn :: Dynamic t Float
content_over_screen_dyn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Float
x -> Float
1 forall a. Fractional a => a -> a -> a
/ Float
x) Dynamic t Float
screen_over_content_dyn
    dragDeltaAdjustedEv :: Event t Float
dragDeltaAdjustedEv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Float
x,Int
y) -> Float
x forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (forall {k} (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Float
content_over_screen_dyn) Event t Int
deltaDragEv)

  -- TODO movement when you click on areas off the bar
  -- TODO maybe do ^ v arrows at top and bottom to click scroll through 1 at a time

  -- TODO ugg you probably need an inputCaptured event here :\ (or you could just get rid of keyboard movement...)
  -- keyboard/scroll movement
  Event t KeyCombo
kup <- 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 <- forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KDown
  Event t KeyCombo
kpgup <- forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KPageUp
  Event t KeyCombo
kpgdown <- forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KPageDown
  Event t ScrollDirection
mscroll <- forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t ScrollDirection)
mouseScroll
  let
    requestedScroll :: Event t Float
    requestedScroll :: Event t Float
requestedScroll = forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
      [ Float
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kdown
      , (-Float
1) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kup

      -- maybe scale to height of scroll bar?
      , Float
8 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kpgdown
      , (-Float
8) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kpgup

      , forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ScrollDirection
mscroll forall a b. (a -> b) -> a -> b
$ \case
          ScrollDirection
ScrollDirection_Up -> (-Float
1)
          ScrollDirection
ScrollDirection_Down -> Float
1
      ]

  -- then put it all together
  let
    foldOffsetFn :: (a, a) -> a -> a
foldOffsetFn (a
maxdiff, a
delta) a
c = forall a. Ord a => a -> a -> a
max a
0 (forall a. Ord a => a -> a -> a
min a
maxdiff (a
cforall a. Num a => a -> a -> a
+a
delta))
  Dynamic t Float
offsetFloatDyn <- forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn forall {a}. (Ord a, Num a) => (a, a) -> a -> a
foldOffsetFn Float
0 (forall {k} (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Float
maxContentSizeDiffDyn) (forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t Float
dragDeltaAdjustedEv, Event t Float
requestedScroll]))

  let
    offsetScreenUnitDyn :: Dynamic t Int
offsetScreenUnitDyn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Num a => a -> a -> a
(*) Dynamic t Float
screen_over_content_dyn forall a b. (a -> b) -> a -> b
$ Dynamic t Float
offsetFloatDyn

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (RealFrac a, Integral b) => a -> b
floor Dynamic t Float
offsetFloatDyn


{-

  data DragState = DragStart | Dragging | DragEnd deriving (Eq, Ord, Show)

  -- | Same as 'Drag' but able to track drag start case
  data Drag2 = Drag2
    { _drag2_from      :: (Int, Int) -- ^ Where the drag began
    , _drag2_to        :: (Int, Int) -- ^ Where the mouse currently is
    , _drag2_button    :: V.Button -- ^ Which mouse button is dragging
    , _drag2_modifiers :: [V.Modifier] -- ^ What modifiers are held
    , _drag2_state     :: DragState -- ^ Whether the drag ended (the mouse button was released)
    }
    deriving (Eq, Ord, Show)

  -- | Same as 'drag' but returns 'Drag2' which tracks drag start events
  drag2
    :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
    => V.Button
    -> m (Event t Drag2)
  drag2 btn = mdo-}