{-# OPTIONS_GHC -Wno-orphans #-}

{- | Merging multiple Ema sites into one.

    This is implemented in using `sop-core`'s NS and NP types. Use as
    `MultiRoute '[MySite1, MySite2, ...]`.
-}
module Ema.Route.Lib.Multi (
  MultiRoute,
  MultiModel,
) where

import Data.SOP (I (..), NP (..), NS (..))
import Ema.Route.Class (IsRoute (..))
import Ema.Route.Prism
import Ema.Site (EmaSite (..), EmaStaticSite)
import Optics.Core (equality, iso, prism', (%))

{- | The merged site's route is represented as a n-ary sum (`NS`) of the
 sub-routes.
-}
type MultiRoute (rs :: [Type]) = NS I rs

type family MultiModel (rs :: [Type]) :: [Type] where
  MultiModel '[] = '[]
  MultiModel (r ': rs) = RouteModel r : MultiModel rs

type family MultiSiteArg (rs :: [Type]) :: [Type] where
  MultiSiteArg '[] = '[]
  MultiSiteArg (r ': rs) = SiteArg r : MultiSiteArg rs

instance IsRoute (MultiRoute '[]) where
  type RouteModel (MultiRoute '[]) = NP I '[]
  routePrism :: RouteModel (MultiRoute ('[] @Type))
-> Prism_ FilePath (MultiRoute ('[] @Type))
routePrism = NP @Type I ('[] @Type) -> Prism_ FilePath (MultiRoute ('[] @Type))
impossiblePrism
    where
      impossiblePrism :: (NP I '[] -> Prism_ FilePath (MultiRoute '[]))
      impossiblePrism :: NP @Type I ('[] @Type) -> Prism_ FilePath (MultiRoute ('[] @Type))
impossiblePrism NP @Type I ('[] @Type)
Nil =
        forall s a. Prism' s a -> Prism_ s a
toPrism_ forall a b. (a -> b) -> a -> b
$ forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\case {}) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
  routeUniverse :: RouteModel (MultiRoute ('[] @Type)) -> [MultiRoute ('[] @Type)]
routeUniverse NP @Type I ('[] @Type)
RouteModel (MultiRoute ('[] @Type))
Nil = forall a. Monoid a => a
mempty

instance
  ( IsRoute r
  , IsRoute (MultiRoute rs)
  , RouteModel (MultiRoute rs) ~ NP I (MultiModel rs)
  ) =>
  IsRoute (MultiRoute (r ': rs))
  where
  type RouteModel (MultiRoute (r ': rs)) = NP I (RouteModel r ': MultiModel rs)
  routePrism :: RouteModel (MultiRoute ((':) @Type r rs))
-> Prism_ FilePath (MultiRoute ((':) @Type r rs))
routePrism =
    forall r. IsRoute r => RouteModel r -> Prism_ FilePath r
routePrism @r
      forall a r (as :: [Type]) (rs :: [Type]).
(a -> Prism_ FilePath r)
-> (NP @Type I as -> Prism_ FilePath (NS @Type I rs))
-> NP @Type I ((':) @Type a as)
-> Prism_ FilePath (NS @Type I ((':) @Type r rs))
`nsRoutePrism` forall r. IsRoute r => RouteModel r -> Prism_ FilePath r
routePrism @(MultiRoute rs)
  routeUniverse :: RouteModel (MultiRoute ((':) @Type r rs))
-> [MultiRoute ((':) @Type r rs)]
routeUniverse (I x
m :* NP @Type I xs
ms) =
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall r. IsRoute r => RouteModel r -> [r]
routeUniverse @r x
m)
      forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) (forall r. IsRoute r => RouteModel r -> [r]
routeUniverse @(MultiRoute rs) NP @Type I xs
ms)

instance EmaSite (MultiRoute '[]) where
  type SiteArg (MultiRoute '[]) = NP I '[]
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg (MultiRoute ('[] @Type))
-> m (Dynamic m (RouteModel (MultiRoute ('[] @Type))))
siteInput Some @Type Action
_ NP @Type I ('[] @Type)
SiteArg (MultiRoute ('[] @Type))
Nil = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall {k} (a :: k -> Type). NP @k a ('[] @k)
Nil
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath (MultiRoute ('[] @Type))
-> RouteModel (MultiRoute ('[] @Type))
-> MultiRoute ('[] @Type)
-> m (SiteOutput (MultiRoute ('[] @Type)))
siteOutput Prism' FilePath (MultiRoute ('[] @Type))
_ NP @Type I ('[] @Type)
RouteModel (MultiRoute ('[] @Type))
Nil = \case {}

instance
  ( EmaStaticSite r
  , EmaStaticSite (MultiRoute rs)
  , SiteArg (MultiRoute rs) ~ NP I (MultiSiteArg rs)
  , RouteModel (MultiRoute rs) ~ NP I (MultiModel rs)
  ) =>
  EmaSite (MultiRoute (r ': rs))
  where
  type SiteArg (MultiRoute (r ': rs)) = NP I (MultiSiteArg (r ': rs))
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg (MultiRoute ((':) @Type r rs))
-> m (Dynamic m (RouteModel (MultiRoute ((':) @Type r rs))))
siteInput Some @Type Action
cliAct (I x
i :* NP @Type I xs
is) = do
    Dynamic m (RouteModel r)
m <- forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @r Some @Type Action
cliAct x
i
    Dynamic m (NP @Type I (MultiModel rs))
ms <- forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @(MultiRoute rs) Some @Type Action
cliAct NP @Type I xs
is
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a (as :: [Type]).
(a, NP @Type I as) -> NP @Type I ((':) @Type a as)
toNP forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic m (RouteModel r)
m forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Dynamic m (NP @Type I (MultiModel rs))
ms
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath (MultiRoute ((':) @Type r rs))
-> RouteModel (MultiRoute ((':) @Type r rs))
-> MultiRoute ((':) @Type r rs)
-> m (SiteOutput (MultiRoute ((':) @Type r rs)))
siteOutput Prism' FilePath (MultiRoute ((':) @Type r rs))
rp (I x
m :* NP @Type I xs
ms) =
    forall a (as :: [Type]).
NS @Type I ((':) @Type a as) -> Either a (NS @Type I as)
fromNS
      forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' FilePath r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput @r (Prism' FilePath (MultiRoute ((':) @Type r rs))
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 {a} {as :: [Type]}.
Prism
  (NS @Type I ((':) @Type a as)) (NS @Type I ((':) @Type a as)) a a
headRoute) x
m)
        (forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' FilePath r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput @(MultiRoute rs) (Prism' FilePath (MultiRoute ((':) @Type r rs))
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 {a} {as :: [Type]}.
Prism
  (NS @Type I ((':) @Type a as))
  (NS @Type I ((':) @Type a as))
  (NS @Type I as)
  (NS @Type I as)
tailRoute) NP @Type I xs
ms)
    where
      tailRoute :: Prism
  (NS @Type I ((':) @Type a as))
  (NS @Type I ((':) @Type a as))
  (NS @Type I as)
  (NS @Type I as)
tailRoute =
        (forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) (forall a (as :: [Type]).
NS @Type I ((':) @Type a as) -> Either a (NS @Type I as)
fromNS forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> forall l r. Either l r -> Maybe r
rightToMaybe))
      headRoute :: Prism
  (NS @Type I ((':) @Type a as)) (NS @Type I ((':) @Type a as)) a a
headRoute =
        (forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall a (as :: [Type]).
NS @Type I ((':) @Type a as) -> Either a (NS @Type I as)
fromNS forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> forall l r. Either l r -> Maybe l
leftToMaybe))

-- | Like `eitherRoutePrism` but uses sop-core types instead of Either/Product.
nsRoutePrism ::
  (a -> Prism_ FilePath r) ->
  (NP I as -> Prism_ FilePath (NS I rs)) ->
  (NP I (a ': as) -> Prism_ FilePath (NS I (r ': rs)))
nsRoutePrism :: forall a r (as :: [Type]) (rs :: [Type]).
(a -> Prism_ FilePath r)
-> (NP @Type I as -> Prism_ FilePath (NS @Type I rs))
-> NP @Type I ((':) @Type a as)
-> Prism_ FilePath (NS @Type I ((':) @Type r rs))
nsRoutePrism a -> Prism_ FilePath r
a NP @Type I as -> Prism_ FilePath (NS @Type I rs)
b =
  forall a r1 b r2.
(a -> Prism_ FilePath r1)
-> (b -> Prism_ FilePath r2)
-> (a, b)
-> Prism_ FilePath (Either r1 r2)
eitherRoutePrism a -> Prism_ FilePath r
a NP @Type I as -> Prism_ FilePath (NS @Type I rs)
b
    forall a b. a -> (a -> b) -> b
& forall pr pf r1 r2 b a.
(Is pr A_Prism, Is pf A_Prism) =>
Optic' pf ('[] @Type) FilePath FilePath
-> Optic' pr ('[] @Type) r1 r2
-> (b -> a)
-> (a -> Prism_ FilePath r1)
-> b
-> Prism_ FilePath r2
mapRoutePrism forall s a t b.
((s :: Type) ~ (a :: Type), (t :: Type) ~ (b :: Type)) =>
Iso s t a b
equality (forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS forall a (as :: [Type]).
NS @Type I ((':) @Type a as) -> Either a (NS @Type I as)
fromNS) forall a (as :: [Type]).
NP @Type I ((':) @Type a as) -> (a, NP @Type I as)
fromNP

fromNP :: NP I (a ': as) -> (a, NP I as)
fromNP :: forall a (as :: [Type]).
NP @Type I ((':) @Type a as) -> (a, NP @Type I as)
fromNP (I x
x :* NP @Type I xs
y) = (x
x, NP @Type I xs
y)

toNP :: (a, NP I as) -> NP I (a ': as)
toNP :: forall a (as :: [Type]).
(a, NP @Type I as) -> NP @Type I ((':) @Type a as)
toNP (a
x, NP @Type I as
y) = forall a. a -> I a
I a
x forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NP @k a xs -> NP @k a ((':) @k x xs)
:* NP @Type I as
y

fromNS :: NS I (a ': as) -> Either a (NS I as)
fromNS :: forall a (as :: [Type]).
NS @Type I ((':) @Type a as) -> Either a (NS @Type I as)
fromNS = \case
  Z (I x
x) -> forall a b. a -> Either a b
Left x
x
  S NS @Type I xs
xs -> forall a b. b -> Either a b
Right NS @Type I xs
xs

toNS :: Either a (NS I as) -> NS I (a ': as)
toNS :: forall a (as :: [Type]).
Either a (NS @Type I as) -> NS @Type I ((':) @Type a as)
toNS = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NS @k a ((':) @k x xs)
Z forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> I a
I) forall {k} (a :: k -> Type) (xs :: [k]) (x :: k).
NS @k a xs -> NS @k a ((':) @k x xs)
S