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

-- | A payload's variant label, stored on the job row for filtering and grouping.
module Arbiter.Core.Job.Kind
  ( HasKind (..)
  , constructorKind
  , constructorKinds
  , GKindOf (..)
  , GKindsOf (..)
  ) where

import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (C1, D1, Generic (..), M1 (..), Meta (MetaCons), Rep, V1, (:+:) (..))
import GHC.TypeLits (KnownSymbol, symbolVal)

-- | A payload's per-job variant label. Defaults to unlabelled.
class HasKind payload where
  -- | The label stored for a job.
  kindOf :: payload -> Maybe Text
  default kindOf :: (GKindOf (Rep payload), Generic payload) => payload -> Maybe Text
  kindOf = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (payload -> Text) -> payload -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. payload -> Text
forall a. (GKindOf (Rep a), Generic a) => a -> Text
constructorKind

  -- | Every label 'kindOf' can return. Empty when the set is not known.
  kindsFor :: [Text]
  default kindsFor :: (GKindsOf (Rep payload)) => [Text]
  kindsFor = forall a. GKindsOf (Rep a) => [Text]
constructorKinds @payload

instance {-# OVERLAPPABLE #-} HasKind payload where
  kindOf :: payload -> Maybe Text
kindOf payload
_ = Maybe Text
forall a. Maybe a
Nothing
  kindsFor :: [Text]
kindsFor = []

-- | The constructor name of a value, for a payload that wraps the sum it wants
-- labelled. Needs @Generic@ on the wrapped type.
--
-- @
-- instance HasKind Envelope where
--   kindOf = Just . constructorKind . envelopePayload
--   kindsFor = constructorKinds \@EmailPayload
-- @
constructorKind :: (GKindOf (Rep a), Generic a) => a -> Text
constructorKind :: forall a. (GKindOf (Rep a), Generic a) => a -> Text
constructorKind = Rep a (ZonkAny 0) -> Text
forall a. Rep a a -> Text
forall {k} (f :: k -> *) (a :: k). GKindOf f => f a -> Text
gKindOf (Rep a (ZonkAny 0) -> Text)
-> (a -> Rep a (ZonkAny 0)) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

-- | Every constructor name of a type, in declaration order.
constructorKinds :: forall a. (GKindsOf (Rep a)) => [Text]
constructorKinds :: forall a. GKindsOf (Rep a) => [Text]
constructorKinds = forall {k} (f :: k). GKindsOf f => [Text]
forall (f :: * -> *). GKindsOf f => [Text]
gKindsOf @(Rep a)

-- | The constructor name of a generic value.
class GKindOf f where
  gKindOf :: f a -> Text

instance (GKindOf f) => GKindOf (D1 d f) where
  gKindOf :: forall (a :: k). D1 d f a -> Text
gKindOf (M1 f a
inner) = f a -> Text
forall (a :: k). f a -> Text
forall {k} (f :: k -> *) (a :: k). GKindOf f => f a -> Text
gKindOf f a
inner

instance (GKindOf f, GKindOf g) => GKindOf (f :+: g) where
  gKindOf :: forall (a :: k). (:+:) f g a -> Text
gKindOf (L1 f a
inner) = f a -> Text
forall (a :: k). f a -> Text
forall {k} (f :: k -> *) (a :: k). GKindOf f => f a -> Text
gKindOf f a
inner
  gKindOf (R1 g a
inner) = g a -> Text
forall (a :: k). g a -> Text
forall {k} (f :: k -> *) (a :: k). GKindOf f => f a -> Text
gKindOf g a
inner

instance (KnownSymbol n) => GKindOf (C1 (MetaCons n fx s) f) where
  gKindOf :: forall (a :: k). C1 ('MetaCons n fx s) f a -> Text
gKindOf C1 ('MetaCons n fx s) f a
_ = String -> Text
T.pack (Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @n))

instance GKindOf V1 where
  gKindOf :: forall (a :: k). V1 a -> Text
gKindOf V1 a
empty = case V1 a
empty of {}

-- | Every constructor name of a generic representation, in declaration order.
class GKindsOf f where
  gKindsOf :: [Text]

instance (GKindsOf f) => GKindsOf (D1 d f) where
  gKindsOf :: [Text]
gKindsOf = forall {k} (f :: k). GKindsOf f => [Text]
forall (f :: k -> *). GKindsOf f => [Text]
gKindsOf @f

instance (GKindsOf f, GKindsOf g) => GKindsOf (f :+: g) where
  gKindsOf :: [Text]
gKindsOf = forall {k} (f :: k). GKindsOf f => [Text]
forall (f :: k -> *). GKindsOf f => [Text]
gKindsOf @f [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> forall {k} (f :: k). GKindsOf f => [Text]
forall (f :: k -> *). GKindsOf f => [Text]
gKindsOf @g

instance (KnownSymbol n) => GKindsOf (C1 (MetaCons n fx s) f) where
  gKindsOf :: [Text]
gKindsOf = [String -> Text
T.pack (Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @n))]

instance GKindsOf V1 where
  gKindsOf :: [Text]
gKindsOf = []