{-# 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
vScrollBar :: forall t m a. (MonadWidget t m)
=> Dynamic t Int
-> m (Dynamic t Int)
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
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
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'
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)
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
, 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
]
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