content: {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE UndecidableSuperClasses #-}
  
  module Ema.Route.Generic.RGeneric (
    RGeneric (RCode, rfrom, rto),
    RHasDatatypeInfo (RDatatypeName, RConstructorNames),
  ) where
  
  import GHC.TypeLits (ErrorMessage (Text), TypeError)
  import GHC.TypeLits.Extra (Impossible (impossible), TypeErr)
  import Generics.SOP
  import Generics.SOP.Type.Metadata qualified as SOPM
  import Prelude hiding (All, Generic)
  
  -- | Like `Generic` but for Route types only.
  class (Generic r, HasDatatypeInfo r) => RGeneric r where
    type RCode r :: [Type]
    rfrom :: r -> NS I (RCode r)
    rto :: NS I (RCode r) -> r
  
  class (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where
    type RDatatypeName r :: SOPM.DatatypeName
    type RConstructorNames r :: [SOPM.ConstructorName]
  
  instance (Generic r, HasDatatypeInfo r, RGeneric' (Code r), All RouteNP (Code r)) => RGeneric r where
    type RCode r = RCode' (Code r)
    rfrom = rfrom' @(Code r) . unSOP . from
    rto = to . SOP . rto' @(Code r)
  
  instance (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where
    type RDatatypeName r = RDatatypeName' (DatatypeInfoOf r)
    type RConstructorNames r = RConstructorNames' (DatatypeInfoOf r)
  
  class RGeneric' (xss :: [[Type]]) where
    type RCode' xss :: [Type]
    rfrom' :: NS (NP I) xss -> NS I (RCode' xss)
    rto' :: NS I (RCode' xss) -> NS (NP I) xss
  
  instance RGeneric' '[] where
    type RCode' '[] = '[]
    rfrom' = \case {}
    rto' = \case {}
  
  instance (RGeneric' xss, RouteNP xs) => RGeneric' (xs ': xss) where
    type RCode' (xs ': xss) = RouteNPType xs ': RCode' xss
    rfrom' = \case
      Z routeNP -> Z $ I $ fromRouteNP routeNP
      S rest -> S $ rfrom' @xss rest
    rto' = \case
      Z (I t) -> Z $ toRouteNP t
      S rest -> S $ rto' @xss rest
  
  type family RDatatypeName' (info :: SOPM.DatatypeInfo) :: SOPM.DatatypeName where
    RDatatypeName' ('SOPM.ADT _ name _ _) =
      name
    RDatatypeName' ('SOPM.Newtype _ name _) =
      name
  
  type family RConstructorNames' (info :: SOPM.DatatypeInfo) :: [SOPM.ConstructorName] where
    RConstructorNames' ('SOPM.ADT _ _ constrs _) =
      GetConstructorNames constrs
    RConstructorNames' ('SOPM.Newtype _ _ constr) =
      '[GetConstructorName constr]
  
  type family GetConstructorName (info :: SOPM.ConstructorInfo) :: SOPM.ConstructorName where
    GetConstructorName ('SOPM.Constructor name) =
      name
    GetConstructorName ('SOPM.Infix name _ _) =
      name
    GetConstructorName ('SOPM.Record name _) =
      name
  
  type family GetConstructorNames (infos :: [SOPM.ConstructorInfo]) :: [SOPM.ConstructorName] where
    GetConstructorNames '[] = '[]
    GetConstructorNames (x ': xs) = GetConstructorName x ': GetConstructorNames xs
  
  {- | Class of `NP` that can be used in a route tyupe.
  
      Ensures that the constructor can have 0 or 1 products only.
  -}
  class RouteNP (xs :: [Type]) where
    type RouteNPType xs :: Type
    fromRouteNP :: NP I xs -> RouteNPType xs
    toRouteNP :: RouteNPType xs -> NP I xs
  
  instance RouteNP '[] where
    type RouteNPType '[] = ()
    fromRouteNP Nil = ()
    toRouteNP () = Nil
  
  instance RouteNP (x ': '[]) where
    type RouteNPType (x ': '[]) = x
    fromRouteNP (I x :* Nil) = x
    toRouteNP x = I x :* Nil
  
  instance (TypeErr ('Text "MultiRoute: too many arguments")) => RouteNP (x ': x' ': xs) where
    type RouteNPType (x ': x' ': xs) = TypeError ('Text "MultiRoute: too many arguments")
    fromRouteNP _ = impossible
    toRouteNP _ = impossible
  