content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Generic.GRep
    ( GRep (..),
      GRepFun (..),
      GRepCons (..),
      GRepField (..),
      GRepValue (..),
      GRepType (..),
      deriveValue,
      deriveType,
    )
  where
  
  import Data.List (partition)
  import Data.Morpheus.Generic.Proxy
    ( conNameP,
      isRecordP,
      selNameP,
    )
  import Data.Morpheus.Types.Internal.AST
    ( FieldName,
      TypeName,
      TypeRef (..),
      TypeWrapper,
      packName,
    )
  import Data.Text (pack)
  import GHC.Generics
    ( C,
      Constructor,
      D,
      Datatype,
      Generic (..),
      K1 (..),
      M1 (..),
      Meta,
      Rec0,
      S,
      Selector,
      U1 (..),
      (:*:) (..),
      (:+:) (..),
    )
  import Relude hiding (undefined)
  
  data GRepFun gql fun f result = GRepFun
    { grepFun :: forall a. (fun a) => f a -> result,
      grepTypename :: forall proxy a. (gql a) => proxy a -> TypeName,
      grepWrappers :: forall proxy a. (gql a) => proxy a -> TypeWrapper
    }
  
  deriveValue ::
    (Generic a, GRep gql constraint value (Rep a), gql a) =>
    GRepFun gql constraint Identity value ->
    a ->
    GRepValue value
  deriveValue options value
    | null cons = GRepValueEnum typename (consName cons)
    | isUnion = case (isUnionRef typename cons, consFields cons) of
        (True, [GRepField {..}]) -> GRepValueUnionRef (typeConName fieldTypeRef) fieldValue
        _ -> GRepValueUnion typename (consName cons) (consFields cons)
    | otherwise = GRepValueObject typename (consFields cons)
    where
      (isUnion, cons) = deriveTypeValue options (from value)
      typename = grepTypename options (Identity value)
  
  toRep :: f a -> Proxy (Rep a)
  toRep _ = Proxy
  
  deriveType ::
    forall kind gql c v kinded m a.
    (GRep gql c (m v) (Rep a), Monad m, gql a) =>
    GRepFun gql c Proxy (m v) ->
    kinded kind a ->
    m (GRepType v)
  deriveType ctx x = toType <$> unpackMonad (deriveTypeDefinition ctx (toRep x))
    where
      toType cons | all null cons = GRepTypeEnum (consName <$> cons)
      toType [GRepCons {consFields}] = GRepTypeObject consFields
      toType cons = GRepTypeUnion unionRef unionCons
        where
          unionRef = toVer <$> concatMap consFields unionRefRep
            where
              toVer GRepField {..} = (typeConName fieldTypeRef, fieldValue)
          --
          (unionRefRep, unionCons) = partition (isUnionRef typename) cons
          typename = grepTypename ctx x
  
  --  GENERIC UNION
  class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
    deriveTypeValue :: GRepFun gql c Identity v -> f a -> (Bool, GRepCons v)
    deriveTypeDefinition :: GRepFun gql c Proxy v -> proxy f -> [GRepCons v]
  
  instance (Datatype d, GRep gql c v f) => GRep gql c v (M1 D d f) where
    deriveTypeValue options (M1 src) = deriveTypeValue options src
    deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @f)
  
  -- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'
  instance (GRep gql c v a, GRep gql c v b) => GRep gql c v (a :+: b) where
    deriveTypeValue f (L1 x) = (True, snd (deriveTypeValue f x))
    deriveTypeValue f (R1 x) = (True, snd (deriveTypeValue f x))
    deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @a) <> deriveTypeDefinition options (Proxy @b)
  
  instance (DeriveFieldRep gql con v f, Constructor c) => GRep gql con v (M1 C c f) where
    deriveTypeValue options (M1 src) = (False, deriveConsRep (Proxy @c) (toFieldRep options src))
    deriveTypeDefinition options _ = [deriveConsRep (Proxy @c) (conRep options (Proxy @f))]
  
  deriveConsRep ::
    (Constructor (c :: Meta)) =>
    f c ->
    [GRepField v] ->
    GRepCons v
  deriveConsRep proxy fields = GRepCons {..}
    where
      consName = conNameP proxy
      consFields
        | isRecordP proxy = fields
        | otherwise = enumerate fields
  
  class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
    toFieldRep :: GRepFun gql c Identity v -> f a -> [GRepField v]
    conRep :: GRepFun gql c Proxy v -> proxy f -> [GRepField v]
    scanRec :: GRepFun gql c Proxy v -> proxy f -> [v]
  
  instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where
    toFieldRep options (a :*: b) = toFieldRep options a <> toFieldRep options b
    conRep options _ = conRep options (Proxy @a) <> conRep options (Proxy @b)
    scanRec ctx _ = scanRec ctx (Proxy @a) <> scanRec ctx (Proxy @b)
  
  instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where
    toFieldRep GRepFun {..} (M1 (K1 src)) =
      [ GRepField
          { fieldSelector = selNameP (Proxy @s),
            fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),
            fieldValue = grepFun (Identity src)
          }
      ]
  
    conRep GRepFun {..} _ =
      [ GRepField
          { fieldSelector = selNameP (Proxy @s),
            fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),
            fieldValue = grepFun (Proxy @a)
          }
      ]
    scanRec GRepFun {..} _ = [grepFun (Proxy @a)]
  
  instance DeriveFieldRep gql c v U1 where
    toFieldRep _ _ = []
    conRep _ _ = []
    scanRec _ _ = []
  
  data GRepType v
    = GRepTypeEnum [TypeName]
    | GRepTypeObject [GRepField v]
    | GRepTypeUnion
        { variantRefs :: [(TypeName, v)],
          inlineVariants :: [GRepCons v]
        }
  
  instance Foldable GRepType where
    foldr _ res GRepTypeEnum {} = res
    foldr f res (GRepTypeObject fields) = foldr f res (map fieldValue fields)
    foldr f res GRepTypeUnion {inlineVariants, variantRefs} = foldr f res (concatMap toList inlineVariants <> map snd variantRefs)
  
  data GRepValue v
    = GRepValueUnionRef
        { unionRefTypeName :: TypeName,
          unionRefValue :: v
        }
    | GRepValueUnion
        { unionTypeName :: TypeName,
          unionVariantName :: TypeName,
          unionFields :: [GRepField v]
        }
    | GRepValueObject
        { objectTypeName :: TypeName,
          objectFields :: [GRepField v]
        }
    | GRepValueEnum
        { enumTypeName :: TypeName,
          enumVariantName :: TypeName
        }
    deriving (Functor)
  
  data GRepCons (a :: Type) = GRepCons
    { consName :: TypeName,
      consFields :: [GRepField a]
    }
    deriving (Functor)
  
  instance Foldable GRepCons where
    foldMap f GRepCons {..} = foldMap f (map fieldValue consFields)
  
  data GRepField (a :: Type) = GRepField
    { fieldSelector :: FieldName,
      fieldTypeRef :: TypeRef,
      fieldValue :: a
    }
    deriving (Functor)
  
  -- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }
  enumerate :: [GRepField a] -> [GRepField a]
  enumerate = zipWith setFieldName ([0 ..] :: [Int])
    where
      setFieldName i field = field {fieldSelector = packName $ "_" <> pack (show i)}
  
  isUnionRef :: TypeName -> GRepCons k -> Bool
  isUnionRef baseName GRepCons {consName, consFields = [fieldRep]} =
    consName == baseName <> typeConName (fieldTypeRef fieldRep)
  isUnionRef _ _ = False
  
  unpackMonad :: (Monad m) => [GRepCons (m a)] -> m [GRepCons a]
  unpackMonad = traverse unpackMonadFromCons
  
  unpackMonadFromField :: (Monad m) => GRepField (m a) -> m (GRepField a)
  unpackMonadFromField GRepField {..} = do
    cont <- fieldValue
    pure (GRepField {fieldValue = cont, ..})
  
  unpackMonadFromCons :: (Monad m) => GRepCons (m a) -> m (GRepCons a)
  unpackMonadFromCons GRepCons {..} = GRepCons consName <$> traverse unpackMonadFromField consFields
  