{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main where
import Control.Concurrent.STM (atomically, writeTVar)
import Control.Monad (void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Text (Text, pack)
import Ease (bounceOut)
import GHCJS.DOM (currentWindowUnchecked)
import GHCJS.DOM.RequestAnimationFrameCallback (newRequestAnimationFrameCallback)
import GHCJS.DOM.Window (Window,
requestAnimationFrame)
import Shpadoinkle (Html, JSM, TVar,
newTVarIO,
shpadoinkle)
import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage)
import Shpadoinkle.Html as H (div,
textProperty)
import Shpadoinkle.Run (runJSorWarp)
import UnliftIO.Concurrent (forkIO, threadDelay)
default (Text)
left :: Double -> Text
left x = "transform:translate3d(150px, " <> pack (show $ x / 5) <> "px, 0)"
easeRange :: Fractional b => b -> (b -> b) -> b -> b
easeRange r e = (* r) . e . (/ r)
dur :: Double
dur = 3000
view :: Double -> Html m a
view clock = H.div
[ textProperty "style" $
"position:absolute;background:red;padding:10px;" <> left
(easeRange dur bounceOut clock) ]
[ if | clock < 500 -> "Wat?"
| clock < 1000 -> "AAAA!!"
| clock < dur * 0.65 -> "Oh no!"
| otherwise -> "I'm ok" ]
wait :: Num n => n
wait = 3000000
animation :: Window -> TVar Double -> JSM ()
animation w t = void $ requestAnimationFrame w =<< go where
go = newRequestAnimationFrameCallback $ \clock' -> do
let clock = clock' - (wait / 1000)
liftIO . atomically $ writeTVar t clock
r <- go
when (clock < dur) . void $ requestAnimationFrame w r
main :: IO ()
main = runJSorWarp 8080 $ do
t <- newTVarIO 0
w <- currentWindowUnchecked
_ <- forkIO $ threadDelay wait >> animation w t
shpadoinkle id runSnabbdom 0 t view stage