{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module Ema.Route.Generic.SubRoute (
HasSubRoutes (SubRoutes),
subRoutesIso,
GSubRoutes,
gtoSubRoutes,
gfromSubRoutes,
ValidSubRoutes,
) where
import Data.SOP.Constraint (AllZipF)
import Data.SOP.NS (trans_NS)
import Ema.Route.Generic.RGeneric (RGeneric (..))
import Ema.Route.Lib.Multi (MultiRoute)
import GHC.TypeLits (AppendSymbol, Symbol)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.TypeLits.Extra.Symbol (StripPrefix, ToLower)
import Ema.Route.Lib.File (FileRoute)
import Ema.Route.Lib.Folder (FolderRoute)
#else
import GHC.TypeLits
#endif
import Generics.SOP (All, I (..), NS, SameShapeAs, Top, unI)
import Generics.SOP.Type.Metadata qualified as SOPM
import Optics.Core (Iso', iso)
import Prelude hiding (All)
class HasSubRoutes r where
type SubRoutes r :: [Type]
subRoutesIso ::
forall r.
( RGeneric r
, HasSubRoutes r
, ValidSubRoutes r (SubRoutes r)
) =>
Iso' r (MultiRoute (SubRoutes r))
subRoutesIso :: Iso' r (MultiRoute (SubRoutes @Type r))
subRoutesIso =
(r -> MultiRoute (SubRoutes @Type r))
-> (MultiRoute (SubRoutes @Type r) -> r)
-> Iso' r (MultiRoute (SubRoutes @Type r))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (forall (subRoutes :: [Type]).
(RGeneric r, ValidSubRoutes r subRoutes) =>
NS @Type I (RCode r) -> MultiRoute subRoutes
forall r (subRoutes :: [Type]).
(RGeneric r, ValidSubRoutes r subRoutes) =>
NS @Type I (RCode r) -> MultiRoute subRoutes
gtoSubRoutes @r (NS @Type I (RCode' (Code r)) -> MultiRoute (SubRoutes @Type r))
-> (r -> NS @Type I (RCode' (Code r)))
-> r
-> MultiRoute (SubRoutes @Type r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> NS @Type I (RCode' (Code r))
forall r. RGeneric r => r -> NS @Type I (RCode r)
rfrom) (NS @Type I (RCode' (Code r)) -> r
forall r. RGeneric r => NS @Type I (RCode r) -> r
rto (NS @Type I (RCode' (Code r)) -> r)
-> (MultiRoute (SubRoutes @Type r) -> NS @Type I (RCode' (Code r)))
-> MultiRoute (SubRoutes @Type r)
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (subRoutes :: [Type]).
(RGeneric r, ValidSubRoutes r subRoutes) =>
MultiRoute subRoutes -> NS @Type I (RCode r)
forall r (subRoutes :: [Type]).
(RGeneric r, ValidSubRoutes r subRoutes) =>
MultiRoute subRoutes -> NS @Type I (RCode r)
gfromSubRoutes @r)
gtoSubRoutes ::
forall r subRoutes.
( RGeneric r
, ValidSubRoutes r subRoutes
) =>
NS I (RCode r) ->
MultiRoute subRoutes
gtoSubRoutes :: NS @Type I (RCode r) -> MultiRoute subRoutes
gtoSubRoutes = Proxy @(Type -> Type -> Constraint) (Coercible @Type)
-> (forall x y. Coercible @Type x y => I x -> I y)
-> NS @Type I (RCode' (Code r))
-> MultiRoute subRoutes
forall {k1} {k2} (c :: k1 -> k2 -> Constraint) (xs :: [k1])
(ys :: [k2]) (proxy :: (k1 -> k2 -> Constraint) -> Type)
(f :: k1 -> Type) (g :: k2 -> Type).
AllZip @k1 @k2 c xs ys =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> NS @k1 f xs
-> NS @k2 g ys
trans_NS (Proxy @(Type -> Type -> Constraint) (Coercible @Type)
forall {k} (t :: k). Proxy @k t
Proxy @Coercible) (y -> I y
forall a. a -> I a
I (y -> I y) -> (I x -> y) -> I x -> I y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> y
coerce (x -> y) -> (I x -> x) -> I x -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI)
gfromSubRoutes ::
forall r subRoutes.
( RGeneric r
, ValidSubRoutes r subRoutes
) =>
MultiRoute subRoutes ->
NS I (RCode r)
gfromSubRoutes :: MultiRoute subRoutes -> NS @Type I (RCode r)
gfromSubRoutes = Proxy @(Type -> Type -> Constraint) (Coercible @Type)
-> (forall x y. Coercible @Type x y => I x -> I y)
-> MultiRoute subRoutes
-> NS @Type I (RCode' (Code r))
forall {k1} {k2} (c :: k1 -> k2 -> Constraint) (xs :: [k1])
(ys :: [k2]) (proxy :: (k1 -> k2 -> Constraint) -> Type)
(f :: k1 -> Type) (g :: k2 -> Type).
AllZip @k1 @k2 c xs ys =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> NS @k1 f xs
-> NS @k2 g ys
trans_NS (Proxy @(Type -> Type -> Constraint) (Coercible @Type)
forall {k} (t :: k). Proxy @k t
Proxy @Coercible) (y -> I y
forall a. a -> I a
I (y -> I y) -> (I x -> y) -> I x -> I y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> y
coerce (x -> y) -> (I x -> x) -> I x -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI)
type ValidSubRoutes r subRoutes =
( SameShapeAs (RCode r) subRoutes
, SameShapeAs subRoutes (RCode r)
, All Top (RCode r)
, All Top subRoutes
, AllZipF Coercible (RCode r) subRoutes
, AllZipF Coercible subRoutes (RCode r)
)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where
GSubRoutes _ _ '[] = '[]
GSubRoutes name (c ': cs) (() ': xs) =
FileRoute (Constructor2RoutePath name c ".html")
': GSubRoutes name cs xs
GSubRoutes name (c ': cs) (x ': xs) =
FolderRoute (Constructor2RoutePath name c "") x
': GSubRoutes name cs xs
type family
Constructor2RoutePath
(name :: SOPM.DatatypeName)
(constr :: SOPM.ConstructorName)
(suffix :: Symbol) ::
Symbol
where
Constructor2RoutePath name constr suffix =
AppendSymbol
(
ToLower
( StripPrefix
(AppendSymbol name "_")
constr
)
)
suffix
#else
type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where
GSubRoutes _ _ _ = TypeError ('Text "GHC 9.2 is required for anyclass deriving of HasSubRoutes")
#endif