Generic.hs

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

module Ema.Route.Generic (
  -- * Generic deriving types
  GenericRoute (GenericRoute),
  HasSubRoutes,
  HasSubModels,
  WithModel,
  WithSubRoutes,
  WithSubModels,

  -- * Customizing generic deriving
  GenericRouteOpt (..),

  -- * Handy functions
  subModels,

  -- * Export these for DerivingVia coercion representations
  FileRoute (FileRoute),
  FolderRoute (FolderRoute),
) where

import Ema.Route.Class (IsRoute (..))
import Ema.Route.Generic.RGeneric
import Ema.Route.Generic.SubModel as X
import Ema.Route.Generic.SubRoute as X
import Ema.Route.Generic.Verification
import Ema.Route.Lib.File (FileRoute (FileRoute))
import Ema.Route.Lib.Folder (FolderRoute (FolderRoute))
import Ema.Route.Lib.Multi (MultiModel, MultiRoute)
import Ema.Route.Prism.Type (mapRoutePrism)
import GHC.Generics qualified as GHC
import Generics.SOP (All, I (..), NP)
import Optics.Core (ReversibleOptic (re), coercedTo, equality, review, (%))
import Prelude hiding (All, Generic)

-- | DerivingVia type to generically derive `IsRoute`
newtype GenericRoute r (opts :: [Type]) = GenericRoute r
  deriving stock (GHC.Generic)

{- | Associate the route with the given model type.

 Default: `()`
-}
data WithModel (r :: Type)

{- | Specify isomorphic types to delegate sub-route behaviour. Usually this is identical to the route product type.

    The isomorphism is specified by @Coercible@.

    The default implementation uses @FileRoute@ for terminal routes, and
    @FolderRoute@ (with constructor prefix stripped) for wrapping sub-routes types.
-}
data WithSubRoutes (subRoutes :: [Type])

{- | Specify the @Data.Generics.Product.Any.HasAny@ selector type for sub models

  Note: if the selector is a @Symbol@ you must wrap it in a @Proxy@.
-}
data WithSubModels (subModels :: [Type])

{- | Typeclass to control `GenericRoute` behaviour.

  The `FooM` type enables users to define their type optionally, whose default
  is specified in the `Foo` type family (further below).

  You can define your own options, for example:

  @
    data MySubRoutes
    instance GenericRouteOpt r MySubRoutes where
      type
        OptSubRoutesM r MySubRoutes =
          'Just (GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r))
  @

  And use it as:

  > deriving via (GenericRoute MyRoute '[MySubRoutes])
-}
class GenericRouteOpt (r :: Type) (opt :: Type) where
  type OptModelM r opt :: Maybe Type
  type OptModelM r opt = 'Nothing
  type OptSubRoutesM r opt :: Maybe [Type]
  type OptSubRoutesM r opt = 'Nothing
  type OptSubModelsM r opt :: Maybe [Type]
  type OptSubModelsM r opt = 'Nothing

instance GenericRouteOpt r (WithModel t) where
  type OptModelM r (WithModel t) = 'Just t
instance GenericRouteOpt r (WithSubRoutes t) where
  type OptSubRoutesM r (WithSubRoutes t) = 'Just t
instance GenericRouteOpt r (WithSubModels t) where
  type OptSubModelsM r (WithSubModels t) = 'Just t

type family OptModel r (opts :: [Type]) :: Type where
  OptModel r '[] = ()
  OptModel r (opt ': opts) = FromMaybe (OptModel r opts) (OptModelM r opt)

type family OptSubRoutes r (opts :: [Type]) :: [Type] where
  OptSubRoutes r '[] = GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r)
  OptSubRoutes r (opt ': opts) = FromMaybe (OptSubRoutes r opts) (OptSubRoutesM r opt)

type family OptSubModels r (opts :: [Type]) :: [Type] where
  OptSubModels r '[] = MultiModel (SubRoutes r)
  OptSubModels r (opt ': opts) = FromMaybe (OptSubModels r opts) (OptSubModelsM r opt)

type family FromMaybe (def :: a) (maybe :: Maybe a) :: a where
  FromMaybe def 'Nothing = def
  FromMaybe def ( 'Just a) = a

type GenericRouteOpts r opts = All (GenericRouteOpt r) opts

instance
  ( GenericRouteOpts r opts
  , RGeneric r
  , ValidSubRoutes r (OptSubRoutes r opts)
  ) =>
  HasSubRoutes (GenericRoute r opts)
  where
  type SubRoutes (GenericRoute r opts) = OptSubRoutes r opts

instance
  ( VerifyModels
      (RouteModel (GenericRoute r opts))
      (MultiModel (SubRoutes (GenericRoute r opts)))
      (OptSubModels r opts)
  , VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))
  , GSubModels (RouteModel (GenericRoute r opts)) (MultiModel (OptSubRoutes r opts)) (OptSubModels r opts)
  , HasSubRoutes (GenericRoute r opts)
  , GenericRouteOpts r opts
  ) =>
  HasSubModels (GenericRoute r opts)
  where
  subModels m =
    gsubModels @_ @(RouteModel (GenericRoute r opts))
      @(MultiModel (SubRoutes (GenericRoute r opts)))
      @(OptSubModels r opts)
      m

instance
  ( VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))
  , HasSubRoutes r
  , HasSubModels r
  , ValidSubRoutes r (SubRoutes r)
  , RGeneric r
  , mr ~ MultiRoute (SubRoutes r)
  , mm ~ MultiModel (SubRoutes r)
  , RouteModel r ~ OptModel r opts
  , RouteModel mr ~ NP I mm
  , IsRoute mr
  , GenericRouteOpts r opts
  ) =>
  IsRoute (GenericRoute r opts)
  where
  type RouteModel (GenericRoute r opts) = OptModel r opts
  routePrism =
    routePrism @mr
      & mapRoutePrism equality (re (subRoutesIso @r) % coercedTo) (subModels @r)
  routeUniverse m =
    GenericRoute . review subRoutesIso
      <$> routeUniverse (subModels @r m)