{-|
Module      : Monomer.Widgets.Animation.Slide
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Slide animation widget. Wraps a child widget whose content will be animated.

Messages:

- Accepts a 'AnimationMsg', used to control the state of the animation.
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Animation.Slide (
  -- * Configuration
  SlideCfg,
  -- * Constructors
  animSlideIn,
  animSlideIn_,
  animSlideOut,
  animSlideOut_,
  slideLeft,
  slideRight,
  slideTop,
  slideBottom
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (%~), at)
import Control.Monad (when)
import Data.Default
import Data.Maybe
import Data.Typeable (cast)
import GHC.Generics

import qualified Data.Sequence as Seq

import Monomer.Helper
import Monomer.Widgets.Container
import Monomer.Widgets.Animation.Types

import qualified Monomer.Lens as L

data SlideDirection
  = SlideLeft
  | SlideRight
  | SlideUp
  | SlideDown
  deriving (SlideDirection -> SlideDirection -> Bool
(SlideDirection -> SlideDirection -> Bool)
-> (SlideDirection -> SlideDirection -> Bool) -> Eq SlideDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlideDirection -> SlideDirection -> Bool
$c/= :: SlideDirection -> SlideDirection -> Bool
== :: SlideDirection -> SlideDirection -> Bool
$c== :: SlideDirection -> SlideDirection -> Bool
Eq, Int -> SlideDirection -> ShowS
[SlideDirection] -> ShowS
SlideDirection -> String
(Int -> SlideDirection -> ShowS)
-> (SlideDirection -> String)
-> ([SlideDirection] -> ShowS)
-> Show SlideDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlideDirection] -> ShowS
$cshowList :: [SlideDirection] -> ShowS
show :: SlideDirection -> String
$cshow :: SlideDirection -> String
showsPrec :: Int -> SlideDirection -> ShowS
$cshowsPrec :: Int -> SlideDirection -> ShowS
Show)

{-|
Configuration options for slide:

- 'autoStart': whether the first time the widget is added, animation should run.
- 'duration': how long the animation lasts in ms.
- 'onFinished': event to raise when animation is complete.
- Individual combinators for direction.
-}
data SlideCfg e = SlideCfg {
  SlideCfg e -> Maybe SlideDirection
_slcDirection :: Maybe SlideDirection,
  SlideCfg e -> Maybe Bool
_slcAutoStart :: Maybe Bool,
  SlideCfg e -> Maybe Int
_slcDuration :: Maybe Int,
  SlideCfg e -> [e]
_slcOnFinished :: [e]
} deriving (SlideCfg e -> SlideCfg e -> Bool
(SlideCfg e -> SlideCfg e -> Bool)
-> (SlideCfg e -> SlideCfg e -> Bool) -> Eq (SlideCfg e)
forall e. Eq e => SlideCfg e -> SlideCfg e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlideCfg e -> SlideCfg e -> Bool
$c/= :: forall e. Eq e => SlideCfg e -> SlideCfg e -> Bool
== :: SlideCfg e -> SlideCfg e -> Bool
$c== :: forall e. Eq e => SlideCfg e -> SlideCfg e -> Bool
Eq, Int -> SlideCfg e -> ShowS
[SlideCfg e] -> ShowS
SlideCfg e -> String
(Int -> SlideCfg e -> ShowS)
-> (SlideCfg e -> String)
-> ([SlideCfg e] -> ShowS)
-> Show (SlideCfg e)
forall e. Show e => Int -> SlideCfg e -> ShowS
forall e. Show e => [SlideCfg e] -> ShowS
forall e. Show e => SlideCfg e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlideCfg e] -> ShowS
$cshowList :: forall e. Show e => [SlideCfg e] -> ShowS
show :: SlideCfg e -> String
$cshow :: forall e. Show e => SlideCfg e -> String
showsPrec :: Int -> SlideCfg e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> SlideCfg e -> ShowS
Show)

instance Default (SlideCfg e) where
  def :: SlideCfg e
def = SlideCfg :: forall e.
Maybe SlideDirection
-> Maybe Bool -> Maybe Int -> [e] -> SlideCfg e
SlideCfg {
    _slcDirection :: Maybe SlideDirection
_slcDirection = Maybe SlideDirection
forall a. Maybe a
Nothing,
    _slcAutoStart :: Maybe Bool
_slcAutoStart = Maybe Bool
forall a. Maybe a
Nothing,
    _slcDuration :: Maybe Int
_slcDuration = Maybe Int
forall a. Maybe a
Nothing,
    _slcOnFinished :: [e]
_slcOnFinished = []
  }

instance Semigroup (SlideCfg e) where
  <> :: SlideCfg e -> SlideCfg e -> SlideCfg e
(<>) SlideCfg e
fc1 SlideCfg e
fc2 = SlideCfg :: forall e.
Maybe SlideDirection
-> Maybe Bool -> Maybe Int -> [e] -> SlideCfg e
SlideCfg {
    _slcDirection :: Maybe SlideDirection
_slcDirection = SlideCfg e -> Maybe SlideDirection
forall e. SlideCfg e -> Maybe SlideDirection
_slcDirection SlideCfg e
fc2 Maybe SlideDirection
-> Maybe SlideDirection -> Maybe SlideDirection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SlideCfg e -> Maybe SlideDirection
forall e. SlideCfg e -> Maybe SlideDirection
_slcDirection SlideCfg e
fc1,
    _slcAutoStart :: Maybe Bool
_slcAutoStart = SlideCfg e -> Maybe Bool
forall e. SlideCfg e -> Maybe Bool
_slcAutoStart SlideCfg e
fc2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SlideCfg e -> Maybe Bool
forall e. SlideCfg e -> Maybe Bool
_slcAutoStart SlideCfg e
fc1,
    _slcDuration :: Maybe Int
_slcDuration = SlideCfg e -> Maybe Int
forall e. SlideCfg e -> Maybe Int
_slcDuration SlideCfg e
fc2 Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SlideCfg e -> Maybe Int
forall e. SlideCfg e -> Maybe Int
_slcDuration SlideCfg e
fc1,
    _slcOnFinished :: [e]
_slcOnFinished = SlideCfg e -> [e]
forall e. SlideCfg e -> [e]
_slcOnFinished SlideCfg e
fc1 [e] -> [e] -> [e]
forall a. Semigroup a => a -> a -> a
<> SlideCfg e -> [e]
forall e. SlideCfg e -> [e]
_slcOnFinished SlideCfg e
fc2
  }

instance Monoid (SlideCfg e) where
  mempty :: SlideCfg e
mempty = SlideCfg e
forall a. Default a => a
def

instance CmbAutoStart (SlideCfg e) where
  autoStart_ :: Bool -> SlideCfg e
autoStart_ Bool
start = SlideCfg e
forall a. Default a => a
def {
    _slcAutoStart :: Maybe Bool
_slcAutoStart = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
start
  }

instance CmbDuration (SlideCfg e) Int where
  duration :: Int -> SlideCfg e
duration Int
dur = SlideCfg e
forall a. Default a => a
def {
    _slcDuration :: Maybe Int
_slcDuration = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
dur
  }

instance CmbOnFinished (SlideCfg e) e where
  onFinished :: e -> SlideCfg e
onFinished e
fn = SlideCfg Any
forall a. Default a => a
def {
    _slcOnFinished :: [e]
_slcOnFinished = [e
fn]
  }

-- | Slide from/to left.
slideLeft :: SlideCfg e
slideLeft :: SlideCfg e
slideLeft = SlideCfg e
forall a. Default a => a
def { _slcDirection :: Maybe SlideDirection
_slcDirection = SlideDirection -> Maybe SlideDirection
forall a. a -> Maybe a
Just SlideDirection
SlideLeft }

-- | Slide from/to right.
slideRight :: SlideCfg e
slideRight :: SlideCfg e
slideRight = SlideCfg e
forall a. Default a => a
def { _slcDirection :: Maybe SlideDirection
_slcDirection = SlideDirection -> Maybe SlideDirection
forall a. a -> Maybe a
Just SlideDirection
SlideRight }

-- | Slide from/to top.
slideTop :: SlideCfg e
slideTop :: SlideCfg e
slideTop = SlideCfg e
forall a. Default a => a
def { _slcDirection :: Maybe SlideDirection
_slcDirection = SlideDirection -> Maybe SlideDirection
forall a. a -> Maybe a
Just SlideDirection
SlideUp }

-- | Slide from/to bottom.
slideBottom :: SlideCfg e
slideBottom :: SlideCfg e
slideBottom = SlideCfg e
forall a. Default a => a
def { _slcDirection :: Maybe SlideDirection
_slcDirection = SlideDirection -> Maybe SlideDirection
forall a. a -> Maybe a
Just SlideDirection
SlideDown }

data SlideState = SlideState {
  SlideState -> Bool
_slsRunning :: Bool,
  SlideState -> Int
_slsStartTs :: Int
} deriving (SlideState -> SlideState -> Bool
(SlideState -> SlideState -> Bool)
-> (SlideState -> SlideState -> Bool) -> Eq SlideState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlideState -> SlideState -> Bool
$c/= :: SlideState -> SlideState -> Bool
== :: SlideState -> SlideState -> Bool
$c== :: SlideState -> SlideState -> Bool
Eq, Int -> SlideState -> ShowS
[SlideState] -> ShowS
SlideState -> String
(Int -> SlideState -> ShowS)
-> (SlideState -> String)
-> ([SlideState] -> ShowS)
-> Show SlideState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlideState] -> ShowS
$cshowList :: [SlideState] -> ShowS
show :: SlideState -> String
$cshow :: SlideState -> String
showsPrec :: Int -> SlideState -> ShowS
$cshowsPrec :: Int -> SlideState -> ShowS
Show, (forall x. SlideState -> Rep SlideState x)
-> (forall x. Rep SlideState x -> SlideState) -> Generic SlideState
forall x. Rep SlideState x -> SlideState
forall x. SlideState -> Rep SlideState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SlideState x -> SlideState
$cfrom :: forall x. SlideState -> Rep SlideState x
Generic)

instance Default SlideState where
  def :: SlideState
def = SlideState :: Bool -> Int -> SlideState
SlideState {
    _slsRunning :: Bool
_slsRunning = Bool
False,
    _slsStartTs :: Int
_slsStartTs = Int
0
  }

-- | Animates a widget from the left to fully visible.
animSlideIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animSlideIn :: WidgetNode s e -> WidgetNode s e
animSlideIn WidgetNode s e
managed = [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideIn_ [SlideCfg e]
forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget from the provided direction to fully visible (defaults
--   to left). Accepts config.
animSlideIn_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideIn_ :: [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideIn_ [SlideCfg e]
configs WidgetNode s e
managed = WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animSlideIn" Widget s e
forall s. Widget s e
widget WidgetNode s e
managed where
  config :: SlideCfg e
config = [SlideCfg e] -> SlideCfg e
forall a. Monoid a => [a] -> a
mconcat [SlideCfg e]
configs
  widget :: Widget s e
widget = Bool -> SlideCfg e -> SlideState -> Widget s e
forall e s.
WidgetEvent e =>
Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
True SlideCfg e
config SlideState
forall a. Default a => a
def

-- | Animates a widget to the left from visible to not visible.
animSlideOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animSlideOut :: WidgetNode s e -> WidgetNode s e
animSlideOut WidgetNode s e
managed = [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideOut_ [SlideCfg e]
forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget to the the provided direction from visible to not
--   visible (defaults to left). Accepts config.
animSlideOut_ :: WidgetEvent e => [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideOut_ :: [SlideCfg e] -> WidgetNode s e -> WidgetNode s e
animSlideOut_ [SlideCfg e]
configs WidgetNode s e
managed = WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animSlideOut" Widget s e
forall s. Widget s e
widget WidgetNode s e
managed where
  config :: SlideCfg e
config = [SlideCfg e] -> SlideCfg e
forall a. Monoid a => [a] -> a
mconcat [SlideCfg e]
configs
  widget :: Widget s e
widget = Bool -> SlideCfg e -> SlideState -> Widget s e
forall e s.
WidgetEvent e =>
Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
False SlideCfg e
config SlideState
forall a. Default a => a
def

makeNode
  :: WidgetEvent e => WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
wType Widget s e
widget WidgetNode s e
managedWidget = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
wType Widget s e
widget
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e -> Seq (WidgetNode s e)
forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget

makeSlide :: WidgetEvent e => Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide :: Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
isSlideIn SlideCfg e
config SlideState
state = Widget s e
forall s. Widget s e
widget where
  widget :: Widget s e
widget = SlideState -> Container s e SlideState -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer SlideState
state Container s e SlideState
forall a. Default a => a
def {
    containerUseScissor :: Bool
containerUseScissor = Bool
True,
    containerInit :: ContainerInitHandler s e
containerInit = ContainerInitHandler s e
forall p s.
HasTimestamp p Int =>
p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e SlideState
containerMerge = ContainerMergeHandler s e SlideState
forall p s p.
p -> WidgetNode s e -> p -> SlideState -> WidgetResult s e
merge,
    containerHandleMessage :: ContainerMessageHandler s e
containerHandleMessage = ContainerMessageHandler s e
forall a s s p.
(Typeable a, HasTimestamp s Int) =>
s -> WidgetNode s e -> p -> a -> Maybe (WidgetResult s e)
handleMessage,
    containerRender :: ContainerRenderHandler s e
containerRender = ContainerRenderHandler s e
forall s s a a.
(HasTimestamp s Int, HasInfo s a, HasViewport a a, HasW a Double,
 HasH a Double) =>
s -> s -> Renderer -> IO ()
render,
    containerRenderAfter :: ContainerRenderHandler s e
containerRenderAfter = ContainerRenderHandler s e
forall p p. p -> p -> Renderer -> IO ()
renderPost
  }

  SlideState Bool
running Int
start = SlideState
state
  autoStart :: Bool
autoStart = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (SlideCfg e -> Maybe Bool
forall e. SlideCfg e -> Maybe Bool
_slcAutoStart SlideCfg e
config)
  duration :: Int
duration = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
500 (SlideCfg e -> Maybe Int
forall e. SlideCfg e -> Maybe Int
_slcDuration SlideCfg e
config)
  period :: Int
period = Int
20
  steps :: Int
steps = Int
duration Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
period

  finishedReq :: WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node = WidgetNode s e -> AnimationMsg -> Int -> WidgetRequest s e
forall i s e.
Typeable i =>
WidgetNode s e -> i -> Int -> WidgetRequest s e
delayedMessage WidgetNode s e
node AnimationMsg
AnimationFinished Int
duration
  renderReq :: p -> s -> WidgetRequest s e
renderReq p
wenv s
node = WidgetRequest s e
forall s e. WidgetRequest s e
req where
    widgetId :: WidgetId
widgetId = s
node s -> Getting WidgetId s WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (a -> Const WidgetId a) -> s -> Const WidgetId s
forall s a. HasInfo s a => Lens' s a
L.info ((a -> Const WidgetId a) -> s -> Const WidgetId s)
-> ((WidgetId -> Const WidgetId WidgetId) -> a -> Const WidgetId a)
-> Getting WidgetId s WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId) -> a -> Const WidgetId a
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    req :: WidgetRequest s e
req = WidgetId -> Int -> Maybe Int -> WidgetRequest s e
forall s e. WidgetId -> Int -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Int
period (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
steps)

  init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetResult s e
result where
    ts :: Int
ts = p
wenv p -> Getting Int p Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int p Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> SlideCfg e -> SlideState -> Widget s e
forall e s.
WidgetEvent e =>
Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
isSlideIn SlideCfg e
config (Bool -> Int -> SlideState
SlideState Bool
True Int
ts)
    result :: WidgetResult s e
result
      | Bool
autoStart = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetNode s e -> WidgetRequest s e
forall s e. WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node, p -> WidgetNode s e -> WidgetRequest s e
forall s a p s e.
(HasInfo s a, HasWidgetId a WidgetId) =>
p -> s -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]
      | Bool
otherwise = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

  merge :: p -> WidgetNode s e -> p -> SlideState -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode SlideState
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> SlideCfg e -> SlideState -> Widget s e
forall e s.
WidgetEvent e =>
Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
isSlideIn SlideCfg e
config SlideState
oldState

  handleMessage :: s -> WidgetNode s e -> p -> a -> Maybe (WidgetResult s e)
handleMessage s
wenv WidgetNode s e
node p
target a
message = Maybe (WidgetResult s e)
result where
    result :: Maybe (WidgetResult s e)
result = a -> Maybe AnimationMsg
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
message Maybe AnimationMsg
-> (AnimationMsg -> Maybe (WidgetResult s e))
-> Maybe (WidgetResult s e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just (WidgetResult s e -> Maybe (WidgetResult s e))
-> (AnimationMsg -> WidgetResult s e)
-> AnimationMsg
-> Maybe (WidgetResult s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
forall s s.
HasTimestamp s Int =>
s -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg s
wenv WidgetNode s e
node

  handleAnimateMsg :: s -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg s
wenv WidgetNode s e
node AnimationMsg
msg = WidgetResult s e
result where
    widgetId :: WidgetId
widgetId = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    ts :: Int
ts = s
wenv s -> Getting Int s Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int s Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    startState :: SlideState
startState = Bool -> Int -> SlideState
SlideState Bool
True Int
ts
    startReqs :: [WidgetRequest s e]
startReqs = [WidgetNode s e -> WidgetRequest s e
forall s e. WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node, s -> WidgetNode s e -> WidgetRequest s e
forall s a p s e.
(HasInfo s a, HasWidgetId a WidgetId) =>
p -> s -> WidgetRequest s e
renderReq s
wenv WidgetNode s e
node]

    newNode :: SlideState -> WidgetNode s e
newNode SlideState
newState = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> SlideCfg e -> SlideState -> Widget s e
forall e s.
WidgetEvent e =>
Bool -> SlideCfg e -> SlideState -> Widget s e
makeSlide Bool
isSlideIn SlideCfg e
config SlideState
newState
    result :: WidgetResult s e
result = case AnimationMsg
msg of
      AnimationMsg
AnimationStart -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (SlideState -> WidgetNode s e
forall s.
HasWidget (WidgetNode s e) (Widget s e) =>
SlideState -> WidgetNode s e
newNode SlideState
startState) [WidgetRequest s e]
startReqs
      AnimationMsg
AnimationStop -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (SlideState -> WidgetNode s e
forall s.
HasWidget (WidgetNode s e) (Widget s e) =>
SlideState -> WidgetNode s e
newNode SlideState
forall a. Default a => a
def) [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
RenderStop WidgetId
widgetId]
      AnimationMsg
AnimationFinished
        | SlideState -> Bool
_slsRunning SlideState
state -> WidgetNode s e -> [e] -> WidgetResult s e
forall e s. Typeable e => WidgetNode s e -> [e] -> WidgetResult s e
resultEvts WidgetNode s e
node (SlideCfg e -> [e]
forall e. SlideCfg e -> [e]
_slcOnFinished SlideCfg e
config)
        | Bool
otherwise -> WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

  render :: s -> s -> Renderer -> IO ()
render s
wenv s
node Renderer
renderer = do
    Renderer -> IO ()
saveContext Renderer
renderer
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Double -> Double -> Point
Point Double
offsetX Double
offsetY)
    where
      viewport :: a
viewport = s
node s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. (a -> Const a a) -> s -> Const a s
forall s a. HasInfo s a => Lens' s a
L.info ((a -> Const a a) -> s -> Const a s)
-> ((a -> Const a a) -> a -> Const a a) -> Getting a s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> a -> Const a a
forall s a. HasViewport s a => Lens' s a
L.viewport
      ts :: Int
ts = s
wenv s -> Getting Int s Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int s Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp
      dir :: SlideDirection
dir = SlideDirection -> Maybe SlideDirection -> SlideDirection
forall a. a -> Maybe a -> a
fromMaybe SlideDirection
SlideLeft (SlideCfg e -> Maybe SlideDirection
forall e. SlideCfg e -> Maybe SlideDirection
_slcDirection SlideCfg e
config)

      bwdStep :: Double
bwdStep = Double -> Double -> Double -> Double
forall a. Ord a => a -> a -> a -> a
clamp Double
0 Double
1 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
duration
      fwdStep :: Double
fwdStep = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bwdStep

      offsetX :: Double
offsetX
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideLeft Bool -> Bool -> Bool
&& Bool
isSlideIn = -Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasW s a => Lens' s a
L.w
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideLeft = -Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
bwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasW s a => Lens' s a
L.w
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideRight Bool -> Bool -> Bool
&& Bool
isSlideIn = Double
fwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasW s a => Lens' s a
L.w
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideRight = Double
bwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasW s a => Lens' s a
L.w
        | Bool
otherwise = Double
0
      offsetY :: Double
offsetY
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideUp Bool -> Bool -> Bool
&& Bool
isSlideIn = -Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasH s a => Lens' s a
L.h
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideUp = -Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
bwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasH s a => Lens' s a
L.h
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideDown Bool -> Bool -> Bool
&& Bool
isSlideIn = Double
fwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasH s a => Lens' s a
L.h
        | SlideDirection
dir SlideDirection -> SlideDirection -> Bool
forall a. Eq a => a -> a -> Bool
== SlideDirection
SlideDown = Double
bwdStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* a
viewport a -> Getting Double a Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double a Double
forall s a. HasH s a => Lens' s a
L.h
        | Bool
otherwise = Double
0

  renderPost :: p -> p -> Renderer -> IO ()
renderPost p
wenv p
node Renderer
renderer = do
    Renderer -> IO ()
restoreContext Renderer
renderer