{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Ema.Example.Ex03_Clock where
import Control.Concurrent (threadDelay)
import qualified Data.LVar as LVar
import Data.List ((!!))
import Data.Some (Some)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Ema (Ema (..))
import qualified Ema
import qualified Ema.CLI
import qualified Ema.Helper.Blaze as EB
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
data Route
= Index
| OnlyTime
deriving (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
(Int -> Route -> ShowS)
-> (Route -> String) -> ([Route] -> ShowS) -> Show Route
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show, Int -> Route
Route -> Int
Route -> [Route]
Route -> Route
Route -> Route -> [Route]
Route -> Route -> Route -> [Route]
(Route -> Route)
-> (Route -> Route)
-> (Int -> Route)
-> (Route -> Int)
-> (Route -> [Route])
-> (Route -> Route -> [Route])
-> (Route -> Route -> [Route])
-> (Route -> Route -> Route -> [Route])
-> Enum Route
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Route -> Route -> Route -> [Route]
$cenumFromThenTo :: Route -> Route -> Route -> [Route]
enumFromTo :: Route -> Route -> [Route]
$cenumFromTo :: Route -> Route -> [Route]
enumFromThen :: Route -> Route -> [Route]
$cenumFromThen :: Route -> Route -> [Route]
enumFrom :: Route -> [Route]
$cenumFrom :: Route -> [Route]
fromEnum :: Route -> Int
$cfromEnum :: Route -> Int
toEnum :: Int -> Route
$ctoEnum :: Int -> Route
pred :: Route -> Route
$cpred :: Route -> Route
succ :: Route -> Route
$csucc :: Route -> Route
Enum, Route
Route -> Route -> Bounded Route
forall a. a -> a -> Bounded a
maxBound :: Route
$cmaxBound :: Route
minBound :: Route
$cminBound :: Route
Bounded)
instance Ema UTCTime Route where
encodeRoute :: UTCTime -> Route -> String
encodeRoute UTCTime
_time = \case
Route
Index -> String
"index.html"
Route
OnlyTime -> String
"time.html"
decodeRoute :: UTCTime -> String -> Maybe Route
decodeRoute UTCTime
_time = \case
String
"index.html" -> Route -> Maybe Route
forall a. a -> Maybe a
Just Route
Index
String
"time.html" -> Route -> Maybe Route
forall a. a -> Maybe a
Just Route
OnlyTime
String
_ -> Maybe Route
forall a. Maybe a
Nothing
main :: IO ()
main :: IO ()
main = do
IO (Either Any (DSum Action Identity)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any (DSum Action Identity)) -> IO ())
-> IO (Either Any (DSum Action Identity)) -> IO ()
forall a b. (a -> b) -> a -> b
$
(Some Action -> UTCTime -> Route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar UTCTime -> m Any)
-> IO (Either Any (DSum Action Identity))
forall model route b.
(Ema model route, Show route) =>
(Some Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
Ema.runEma (\Some Action
act UTCTime
m -> Format -> LByteString -> Asset LByteString
forall a. Format -> a -> Asset a
Ema.AssetGenerated Format
Ema.Html (LByteString -> Asset LByteString)
-> (Route -> LByteString) -> Route -> Asset LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Some Action -> UTCTime -> Route -> LByteString
render Some Action
act UTCTime
m) ((forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar UTCTime -> m Any)
-> IO (Either Any (DSum Action Identity)))
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar UTCTime -> m Any)
-> IO (Either Any (DSum Action Identity))
forall a b. (a -> b) -> a -> b
$ \Some Action
_act LVar UTCTime
model ->
m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
LVar UTCTime -> UTCTime -> m ()
forall (m :: * -> *) a. MonadIO m => LVar a -> a -> m ()
LVar.set LVar UTCTime
model (UTCTime -> m ()) -> m UTCTime -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
render :: Some Ema.CLI.Action -> UTCTime -> Route -> LByteString
render :: Some Action -> UTCTime -> Route -> LByteString
render Some Action
emaAction UTCTime
now Route
r =
Some Action -> Html -> Html -> LByteString
EB.twindLayout Some Action
emaAction (Html -> Html
H.title Html
"Clock" Html -> Html -> Html
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Html
H.base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/") (Html -> LByteString) -> Html -> LByteString
forall a b. (a -> b) -> a -> b
$
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"container mx-auto" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-8 p-2 text-center" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
case Route
r of
Route
Index ->
Html
"The current date & time is: "
Route
OnlyTime ->
Html
"The current time is: "
Html -> Html
H.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-6xl font-bold mt-2" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (AttributeValue
"text-" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> UTCTime -> AttributeValue
forall a t. (IsString a, FormatTime t) => t -> a
randomColor UTCTime
now AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"-500") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
let fmt :: String
fmt = case Route
r of
Route
Index -> String
"%Y/%m/%d %H:%M:%S"
Route
OnlyTime -> String
"%H:%M:%S"
String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmt UTCTime
now
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-4 text-center" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
case Route
r of
Route
Index -> do
Route -> Html -> Html
forall r. Ema UTCTime r => r -> Html -> Html
routeElem Route
OnlyTime Html
"Hide day?"
Route
OnlyTime -> do
Route -> Html -> Html
forall r. Ema UTCTime r => r -> Html -> Html
routeElem Route
Index Html
"Show day?"
where
routeElem :: r -> Html -> Html
routeElem r
r' Html
w =
Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-xl text-purple-500 hover:underline" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! r -> Attribute
forall r. Ema UTCTime r => r -> Attribute
routeHref r
r' (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
w
routeHref :: r -> Attribute
routeHref r
r' =
AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue)
-> (Text -> String) -> Text -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ UTCTime -> r -> Text
forall r model. Ema model r => model -> r -> Text
Ema.routeUrl UTCTime
now r
r')
randomColor :: t -> a
randomColor t
t =
let epochSecs :: Int
epochSecs = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Read Int => String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe @Int (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s" t
t
colors :: [a]
colors = [a
"green", a
"gray", a
"purple", a
"red", a
"blue", a
"yellow", a
"black", a
"pink"]
in [a]
colors [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
epochSecs ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
colors)