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

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

Messages:

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

module Monomer.Widgets.Animation.Fade (
  -- * Configuration
  FadeCfg,
  -- * Constructors
  animFadeIn,
  animFadeIn_,
  animFadeOut,
  animFadeOut_
) where

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

import qualified Data.Sequence as Seq

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

import qualified Monomer.Lens as L

{-|
Configuration options for fade:

- '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.
-}
data FadeCfg e = FadeCfg {
  forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart :: Maybe Bool,
  forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration :: Maybe Millisecond,
  forall e. FadeCfg e -> [e]
_fdcOnFinished :: [e]
} deriving (FadeCfg e -> FadeCfg e -> Bool
forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FadeCfg e -> FadeCfg e -> Bool
$c/= :: forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
== :: FadeCfg e -> FadeCfg e -> Bool
$c== :: forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
Eq, Int -> FadeCfg e -> ShowS
forall e. Show e => Int -> FadeCfg e -> ShowS
forall e. Show e => [FadeCfg e] -> ShowS
forall e. Show e => FadeCfg e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FadeCfg e] -> ShowS
$cshowList :: forall e. Show e => [FadeCfg e] -> ShowS
show :: FadeCfg e -> String
$cshow :: forall e. Show e => FadeCfg e -> String
showsPrec :: Int -> FadeCfg e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> FadeCfg e -> ShowS
Show)

instance Default (FadeCfg e) where
  def :: FadeCfg e
def = FadeCfg {
    _fdcAutoStart :: Maybe Bool
_fdcAutoStart = forall a. Maybe a
Nothing,
    _fdcDuration :: Maybe Millisecond
_fdcDuration = forall a. Maybe a
Nothing,
    _fdcOnFinished :: [e]
_fdcOnFinished = []
  }

instance Semigroup (FadeCfg e) where
  <> :: FadeCfg e -> FadeCfg e -> FadeCfg e
(<>) FadeCfg e
fc1 FadeCfg e
fc2 = FadeCfg {
    _fdcAutoStart :: Maybe Bool
_fdcAutoStart = forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
fc2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
fc1,
    _fdcDuration :: Maybe Millisecond
_fdcDuration = forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
fc2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
fc1,
    _fdcOnFinished :: [e]
_fdcOnFinished = forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
fc1 forall a. Semigroup a => a -> a -> a
<> forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
fc2
  }

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

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

instance CmbDuration (FadeCfg e) Millisecond where
  duration :: Millisecond -> FadeCfg e
duration Millisecond
dur = forall a. Default a => a
def {
    _fdcDuration :: Maybe Millisecond
_fdcDuration = forall a. a -> Maybe a
Just Millisecond
dur
  }

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

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

instance Default FadeState where
  def :: FadeState
def = FadeState {
    _fdsRunning :: Bool
_fdsRunning = Bool
False,
    _fdsStartTs :: Millisecond
_fdsStartTs = Millisecond
0
  }

-- | Animates a widget from not visible state to fully visible.
animFadeIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeIn :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeIn WidgetNode s e
managed = forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget from not visible state to fully visible. Accepts config.
animFadeIn_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ :: forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ [FadeCfg e]
configs WidgetNode s e
managed = forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animFadeIn" forall {s}. Widget s e
widget WidgetNode s e
managed where
  config :: FadeCfg e
config = forall a. Monoid a => [a] -> a
mconcat [FadeCfg e]
configs
  widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
True FadeCfg e
config forall a. Default a => a
def

-- | Animates a widget from visible state to not visible.
animFadeOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeOut :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeOut WidgetNode s e
managed = forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget from visible state to not visible. Accepts config.
animFadeOut_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ :: forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ [FadeCfg e]
configs WidgetNode s e
managed = forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animFadeOut" forall {s}. Widget s e
widget WidgetNode s e
managed where
  config :: FadeCfg e
config = forall a. Monoid a => [a] -> a
mconcat [FadeCfg e]
configs
  widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
False FadeCfg e
config forall a. Default a => a
def

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

makeFade :: WidgetEvent e => Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade :: forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config FadeState
state = forall {s}. Widget s e
widget where
  widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer FadeState
state forall a. Default a => a
def {
    containerInit :: ContainerInitHandler s e
containerInit = forall {p} {s}.
HasTimestamp p Millisecond =>
p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e FadeState
containerMerge = forall {p} {s} {p}.
p -> WidgetNode s e -> p -> FadeState -> WidgetResult s e
merge,
    containerHandleMessage :: ContainerMessageHandler s e
containerHandleMessage = forall {p} {p} {s} {p}.
(Typeable p, HasTimestamp p Millisecond) =>
p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage,
    containerRender :: ContainerRenderHandler s e
containerRender = forall {p} {p}.
HasTimestamp p Millisecond =>
p -> p -> Renderer -> IO ()
render,
    containerRenderAfter :: ContainerRenderHandler s e
containerRenderAfter = forall {p} {p}. p -> p -> Renderer -> IO ()
renderPost
  }

  FadeState Bool
running Millisecond
start = FadeState
state
  autoStart :: Bool
autoStart = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
config)
  duration :: Millisecond
duration = forall a. a -> Maybe a -> a
fromMaybe Millisecond
500 (forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
config)
  period :: Millisecond
period = Millisecond
20
  steps :: Int
steps = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Millisecond
duration forall a. Integral a => a -> a -> a
`div` Millisecond
period

  finishedReq :: WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node = forall i s e.
Typeable i =>
WidgetNode s e -> i -> Millisecond -> WidgetRequest s e
delayedMessage WidgetNode s e
node AnimationMsg
AnimationFinished Millisecond
duration
  renderReq :: p -> p -> WidgetRequest s e
renderReq p
wenv p
node = forall {s} {e}. WidgetRequest s e
req where
    widgetId :: WidgetId
widgetId = p
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    req :: WidgetRequest s e
req = forall s e.
WidgetId -> Millisecond -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Millisecond
period (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 :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config (Bool -> Millisecond -> FadeState
FadeState Bool
True Millisecond
ts)
    result :: WidgetResult s e
result
      | Bool
autoStart = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall {s} {e}. WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node, forall {p} {a} {p} {s} {e}.
(HasInfo p a, HasWidgetId a WidgetId) =>
p -> p -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]
      | Bool
otherwise = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

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

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

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

    newNode :: FadeState -> WidgetNode s e
newNode FadeState
newState = WidgetNode s e
node
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config FadeState
newState
    result :: WidgetResult s e
result = case AnimationMsg
msg of
      AnimationMsg
AnimationStart -> forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (forall {s}.
HasWidget (WidgetNode s e) (Widget s e) =>
FadeState -> WidgetNode s e
newNode FadeState
startState) [WidgetRequest s e]
startReqs
      AnimationMsg
AnimationStop -> forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (forall {s}.
HasWidget (WidgetNode s e) (Widget s e) =>
FadeState -> WidgetNode s e
newNode forall a. Default a => a
def) [forall s e. WidgetId -> WidgetRequest s e
RenderStop WidgetId
widgetId]
      AnimationMsg
AnimationFinished
        | FadeState -> Bool
_fdsRunning FadeState
state -> forall e s. Typeable e => WidgetNode s e -> [e] -> WidgetResult s e
resultEvts WidgetNode s e
node (forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
config)
        | Bool
otherwise -> forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

  render :: p -> p -> Renderer -> IO ()
render p
wenv p
node Renderer
renderer = do
    Renderer -> IO ()
saveContext Renderer
renderer
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running forall a b. (a -> b) -> a -> b
$
      Renderer -> Double -> IO ()
setGlobalAlpha Renderer
renderer Double
alpha
    where
      ts :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
      currStep :: Double
currStep = Double -> Double
clampAlpha forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
ts forall a. Num a => a -> a -> a
- Millisecond
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
duration
      alpha :: Double
alpha
        | Bool
isFadeIn = Double
currStep
        | Bool
otherwise = Double
1 forall a. Num a => a -> a -> a
- Double
currStep

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