{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Ema.Route.Generic.SubRoute (
  HasSubRoutes (SubRoutes),
  subRoutesIso,
  -- DerivingVia types
  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)

{- | HasSubRoutes is a class of routes with an underlying MultiRoute (and MultiModel) representation.

 The idea is that by deriving HasSubRoutes (and HasSubModels), we get IsRoute for free (based on MultiRoute).

 TODO: Rename this class, or change the API.
-}
class HasSubRoutes r where
  -- | The sub-routes in the `r` (for each constructor).
  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)

-- | @subRoutes@ are valid sub-routes of @r@
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) =
    -- TODO: The .html suffix part should be overridable.
    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
      ( -- Instead of ToLower we want Camel2Kebab here, ideally.
        -- So that `Foo_BarQux` encodes to bar-qux instead of barqux.
        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