Add initial support for animation

.ghcid

@@ -1,3 +1,3 @@
---command "stack repl --main-is monomer:exe:books"
+--command "stack repl --main-is monomer:exe:monomer-exe"
 --test ":main"
 --restart=package.yaml

app/Main.hs

@@ -132,7 +132,11 @@ handleAppEvent wenv node model evt = case evt of
   _ -> []
 
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
-buildUI wenv model = traceShow "Creating UI" widgetScroll where
+buildUI wenv model = traceShow "Creating UI" widgetAnimate where
+  widgetAnimate = vstack [
+      fadeIn (label "Hello!!!!" `style` [bgColor red]),
+      fadeOut (label "Good bye!!!!" `style` [bgColor green])
+    ]
   widgetButtons = vstack [
       button "Confirm" ShowConfirm
     ]

src/Monomer/Widgets.hs

@@ -25,7 +25,9 @@ module Monomer.Widgets (
   module Monomer.Widgets.TextField,
   module Monomer.Widgets.ThemeSwitch,
   module Monomer.Widgets.Tooltip,
-  module Monomer.Widgets.ZStack
+  module Monomer.Widgets.ZStack,
+  -- Animation
+  module Monomer.Widgets.Animate.Fade
 ) where
 
 import Monomer.Widgets.Alert
@@ -55,3 +57,5 @@ import Monomer.Widgets.TextField
 import Monomer.Widgets.ThemeSwitch
 import Monomer.Widgets.Tooltip
 import Monomer.Widgets.ZStack
+
+import Monomer.Widgets.Animate.Fade

src/Monomer/Widgets/Animate/Fade.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Monomer.Widgets.Animate.Fade (
+  fadeIn,
+  fadeIn_,
+  fadeOut,
+  fadeOut_
+) where
+
+import Codec.Serialise
+import Control.Applicative ((<|>))
+import Control.Lens ((&), (^.), (.~), (%~), at)
+import Data.Default
+import Data.Maybe
+import GHC.Generics
+
+import qualified Data.Sequence as Seq
+
+import Monomer.Widgets.Container
+
+import qualified Monomer.Lens as L
+
+newtype FadeCfg = FadeCfg {
+  _fdcDuration :: Maybe Int
+} deriving (Eq, Show)
+
+instance Default FadeCfg where
+  def = FadeCfg {
+    _fdcDuration = Nothing
+  }
+
+instance Semigroup FadeCfg where
+  (<>) fc1 fc2 = FadeCfg {
+    _fdcDuration = _fdcDuration fc2 <|> _fdcDuration fc1
+  }
+
+instance Monoid FadeCfg where
+  mempty = def
+
+newtype FadeState = FadeState {
+  _fdsStart :: Int
+} deriving (Eq, Show, Generic, Serialise)
+
+instance Default FadeState where
+  def = FadeState {
+    _fdsStart = 0
+  }
+
+fadeIn :: WidgetNode s e -> WidgetNode s e
+fadeIn managed = fadeIn_ def managed
+
+fadeIn_ :: [FadeCfg] -> WidgetNode s e -> WidgetNode s e
+fadeIn_ configs managed = makeNode widget managed where
+  config = mconcat configs
+  widget = makeFade True config def
+
+fadeOut :: WidgetNode s e -> WidgetNode s e
+fadeOut managed = fadeOut_ def managed
+
+fadeOut_ :: [FadeCfg] -> WidgetNode s e -> WidgetNode s e
+fadeOut_ configs managed = makeNode widget managed where
+  config = mconcat configs
+  widget = makeFade False config def
+
+makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
+makeNode widget managedWidget = defaultWidgetNode "fadeIn" widget
+  & L.info . L.focusable .~ False
+  & L.children .~ Seq.singleton managedWidget
+
+makeFade :: Bool -> FadeCfg -> FadeState -> Widget s e
+makeFade isFadeIn config state = widget where
+  widget = createContainer () def {
+    containerInit = init,
+    containerRestore = restore,
+    containerRender = render,
+    containerRenderAfter = renderPost
+  }
+
+  FadeState start = state
+  duration = fromMaybe 2000 (_fdcDuration config)
+  period = 50
+  steps = duration `div` period
+
+  renderReq wenv node = req where
+    widgetId = node ^. L.info . L.widgetId
+    req = RenderEvery widgetId period (Just steps)
+
+  init wenv node = result where
+    newState = state {
+      _fdsStart = wenv ^. L.timestamp
+    }
+    newNode = node
+      & L.widget .~ makeFade isFadeIn config newState
+    result = resultReqs newNode [renderReq wenv node]
+
+  restore wenv oldState oldInfo node = result where
+    result = resultWidget node
+
+  render renderer wenv node = do
+    saveContext renderer
+    setGlobalAlpha renderer alpha
+    where
+      ts = wenv ^. L.timestamp
+      currStep = clampAlpha $ fromIntegral (ts - start) / fromIntegral duration
+      alpha
+        | isFadeIn = currStep
+        | otherwise = 1 - currStep
+
+  renderPost renderer wenv node = do
+    restoreContext renderer