{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}

{- | Demonstration of merging multiple sites

  For an alternative (easier) approach, see `Ex05_MultiRoute.hs`.
-}
module Ema.Example.Ex04_Multi where

import Data.Generics.Sum.Any (AsAny (_As))
import Ema
import Ema.Example.Common (tailwindLayout)
import Ema.Example.Ex00_Hello qualified as Ex00
import Ema.Example.Ex01_Basic qualified as Ex01
import Ema.Example.Ex02_Clock qualified as Ex02
import Ema.Example.Ex03_Store qualified as Ex03
import Ema.Route.Generic
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, HasDatatypeInfo, I (I), NP (Nil, (:*)))
import Optics.Core (Prism', (%))
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Prelude hiding (Generic)

data M = M
  { M -> Model
mClock :: Ex02.Model
  , M -> Model
mClockFast :: Ex02.Model
  , M -> Model
mStore :: Ex03.Model
  }
  deriving stock (forall x. Rep M x -> M
forall x. M -> Rep M x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep M x -> M
$cfrom :: forall x. M -> Rep M x
GHC.Generic)

data R
  = R_Index
  | R_Hello Ex00.Route
  | R_Basic Ex01.Route
  | R_Clock Ex02.Route
  | R_ClockFast Ex02.Route
  | R_Store Ex03.Route
  deriving stock (Int -> R -> ShowS
[R] -> ShowS
R -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [R] -> ShowS
$cshowList :: [R] -> ShowS
show :: R -> String
$cshow :: R -> String
showsPrec :: Int -> R -> ShowS
$cshowsPrec :: Int -> R -> ShowS
Show, Eq R
R -> R -> Bool
R -> R -> Ordering
R -> R -> R
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: R -> R -> R
$cmin :: R -> R -> R
max :: R -> R -> R
$cmax :: R -> R -> R
>= :: R -> R -> Bool
$c>= :: R -> R -> Bool
> :: R -> R -> Bool
$c> :: R -> R -> Bool
<= :: R -> R -> Bool
$c<= :: R -> R -> Bool
< :: R -> R -> Bool
$c< :: R -> R -> Bool
compare :: R -> R -> Ordering
$ccompare :: R -> R -> Ordering
Ord, R -> R -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: R -> R -> Bool
$c/= :: R -> R -> Bool
== :: R -> R -> Bool
$c== :: R -> R -> Bool
Eq, forall x. Rep R x -> R
forall x. R -> Rep R x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep R x -> R
$cfrom :: forall x. R -> Rep R x
GHC.Generic)
  deriving anyclass (All @[Type] (SListI @Type) (Code R)
Rep R -> R
R -> Rep R
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep R -> R
$cto :: Rep R -> R
from :: R -> Rep R
$cfrom :: R -> Rep R
Generic, Generic R
forall a.
Generic a
-> (forall (proxy :: Type -> Type).
    proxy a -> DatatypeInfo (Code a))
-> HasDatatypeInfo a
forall (proxy :: Type -> Type). proxy R -> DatatypeInfo (Code R)
datatypeInfo :: forall (proxy :: Type -> Type). proxy R -> DatatypeInfo (Code R)
$cdatatypeInfo :: forall (proxy :: Type -> Type). proxy R -> DatatypeInfo (Code R)
HasDatatypeInfo)
  deriving
    (forall {k} (r :: k). HasSubRoutes @k r
HasSubRoutes, HasSubRoutes @Type R
RouteModel R -> NP @Type I (MultiModel (SubRoutes @Type R))
forall r.
HasSubRoutes @Type r
-> (RouteModel r -> NP @Type I (MultiModel (SubRoutes @Type r)))
-> HasSubModels r
subModels :: RouteModel R -> NP @Type I (MultiModel (SubRoutes @Type R))
$csubModels :: RouteModel R -> NP @Type I (MultiModel (SubRoutes @Type R))
HasSubModels, RouteModel R -> [R]
RouteModel R -> Prism_ String R
forall r.
(RouteModel r -> Prism_ String r)
-> (RouteModel r -> [r]) -> IsRoute r
routeUniverse :: RouteModel R -> [R]
$crouteUniverse :: RouteModel R -> [R]
routePrism :: RouteModel R -> Prism_ String R
$croutePrism :: RouteModel R -> Prism_ String R
IsRoute)
    via ( GenericRoute
            R
            '[ WithModel M
             , WithSubModels
                [ ()
                , ()
                , ()
                , -- You can refer to a record field by the field name
                  -- (We use `Proxy` only because heteregenous type
                  -- lists must be uni-kind).
                  Proxy "mClock"
                , Proxy "mClockFast"
                , -- Or by the field type.
                  -- Thanks to Data.Generics.Product.Any
                  Ex03.Model
                ]
             ]
        )

main :: IO ()
main :: IO ()
main = do
  forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall r.
(Show r, Eq r, EmaStaticSite r) =>
SiteArg r -> IO [String]
Ema.runSite @R ()

instance EmaSite R where
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg R -> m (Dynamic m (RouteModel R))
siteInput Some @Type Action
cliAct () = do
    Dynamic m Model
x1 :: Dynamic m Ex02.Model <- forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @Ex02.Route Some @Type Action
cliAct Int
Ex02.delayNormal
    Dynamic m Model
x2 :: Dynamic m Ex02.Model <- forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @Ex02.Route Some @Type Action
cliAct Int
Ex02.delayFast
    Dynamic m Model
x3 :: Dynamic m Ex03.Model <- forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @Ex03.Route Some @Type Action
cliAct ()
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 Model -> Model -> Model -> M
M Dynamic m Model
x1 Dynamic m Model
x2 Dynamic m Model
x3
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' String R -> RouteModel R -> R -> m (SiteOutput R)
siteOutput Prism' String R
rp RouteModel R
m = \case
    R
R_Index ->
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Format -> a -> Asset a
Ema.AssetGenerated Format
Ema.Html forall a b. (a -> b) -> a -> b
$ Prism' String R -> M -> LByteString
renderIndex Prism' String R
rp RouteModel R
m
    R_Hello Route
r ->
      forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (Prism' String R
rp forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (forall {k} (sel :: k) a s. AsAny @k sel a s => Prism s s a a
_As @"R_Hello")) ()
m2 Route
r
    R_Basic Route
r ->
      forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (Prism' String R
rp forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (forall {k} (sel :: k) a s. AsAny @k sel a s => Prism s s a a
_As @"R_Basic")) ()
m3 Route
r
    R_Clock Route
r ->
      forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (Prism' String R
rp forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (forall {k} (sel :: k) a s. AsAny @k sel a s => Prism s s a a
_As @"R_Clock")) Model
m4 Route
r
    R_ClockFast Route
r ->
      forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (Prism' String R
rp forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (forall {k} (sel :: k) a s. AsAny @k sel a s => Prism s s a a
_As @"R_Clock")) Model
m5 Route
r
    R_Store Route
r ->
      forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (Prism' String R
rp forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (forall {k} (sel :: k) a s. AsAny @k sel a s => Prism s s a a
_As @"R_Store")) Model
m6 Route
r
    where
      I () :* I x
()
m2 :* I x
()
m3 :* I x
Model
m4 :* I x
Model
m5 :* I x
Model
m6 :* NP @Type I xs
Nil = forall r.
HasSubModels r =>
RouteModel r -> NP @Type I (MultiModel (SubRoutes @Type r))
subModels @R RouteModel R
m

renderIndex :: Prism' FilePath R -> M -> LByteString
renderIndex :: Prism' String R -> M -> LByteString
renderIndex Prism' String R
rp M
m =
  Html -> Html -> LByteString
tailwindLayout (Html -> Html
H.title Html
"Ex04_Multi" forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Html
H.base forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/") forall a b. (a -> b) -> a -> b
$
    Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"container mx-auto text-center mt-8 p-2" forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.p Html
"You can compose Ema sites. Here are three sites composed to produce one:"
      Html -> Html
H.ul forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"flex flex-col justify-center .items-center mt-4 space-y-4" forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ R -> Html -> Html
routeElem (Route -> R
R_Hello forall a b. (a -> b) -> a -> b
$ () -> Route
Ex00.Route ()) Html
"Ex00_Hello"
        Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ R -> Html -> Html
routeElem (Route -> R
R_Basic Route
Ex01.Route_Index) Html
"Ex01_Basic"
        Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ R -> Html -> Html
routeElem (Route -> R
R_Clock Route
Ex02.Route_Index) Html
"Ex02_Clock"
        Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ R -> Html -> Html
routeElem (Route -> R
R_ClockFast Route
Ex02.Route_Index) Html
"Ex02_ClockFast"
        Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ R -> Html -> Html
routeElem (Route -> R
R_Store Route
Ex03.Route_Index) Html
"Ex03_Store"
      Html -> Html
H.p forall a b. (a -> b) -> a -> b
$ do
        Html
"The current time is: "
        Html -> Html
H.small forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$ M -> Model
mClock M
m
  where
    routeElem :: R -> Html -> Html
routeElem R
r Html
w = do
      Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-xl text-purple-500 hover:underline" forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (forall a. ToValue a => a -> AttributeValue
H.toValue forall a b. (a -> b) -> a -> b
$ forall r. HasCallStack => Prism' String r -> r -> Text
routeUrl Prism' String R
rp R
r) forall a b. (a -> b) -> a -> b
$ Html
w