{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# 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.Server.Deriving.Utils.DeriveGType
  ( DeriveWith (..),
    DeriveValueOptions (..),
    DeriveTypeOptions (..),
    deriveValue,
    deriveTypeWith,
  )
where

import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CategoryValue (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Proxy
  ( conNameProxy,
    isRecordProxy,
    selNameProxy,
  )
import Data.Morpheus.Server.Deriving.Utils.Types
import Data.Morpheus.Server.Types.Internal
  ( GQLTypeOptions (..),
    TypeData (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeName,
    TypeRef (..),
  )
import GHC.Generics
  ( C,
    Constructor,
    D,
    Datatype,
    Generic (..),
    K1 (..),
    M1 (..),
    Meta,
    Rec0,
    S,
    Selector,
    U1 (..),
    (:*:) (..),
    (:+:) (..),
  )
import Relude hiding (undefined)

data DeriveValueOptions kind c v = DeriveValueOptions
  { forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
__valueTypeName :: TypeName,
    forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueGQLOptions :: GQLTypeOptions,
    forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> forall a. c a => a -> v
__valueApply :: forall a. c a => a -> v,
    forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v
-> forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType :: forall f a. c a => f a -> TypeData
  }

data DeriveTypeOptions kind c v = DeriveTypeDefinitionOptions
  { forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
__typeGQLOptions :: GQLTypeOptions,
    forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> v
__typeApply :: forall f a. c a => f a -> v,
    forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> TypeData
__typeGetType :: forall f a. c a => f a -> TypeData
  }

deriveValue ::
  (CategoryValue kind, Generic a, DeriveWith constraint value (Rep a)) =>
  DeriveValueOptions kind constraint value ->
  a ->
  DataType value
deriveValue :: forall (kind :: TypeCategory) a (constraint :: * -> Constraint)
       value.
(CategoryValue kind, Generic a,
 DeriveWith constraint value (Rep a)) =>
DeriveValueOptions kind constraint value -> a -> DataType value
deriveValue DeriveValueOptions kind constraint value
options = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind constraint value
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

deriveTypeWith ::
  forall kind c v kinded a.
  (CategoryValue kind, DeriveWith c v (Rep a)) =>
  DeriveTypeOptions kind c v ->
  kinded kind a ->
  [ConsRep v]
deriveTypeWith :: forall (kind :: TypeCategory) (c :: * -> Constraint) v
       (kinded :: TypeCategory -> * -> *) a.
(CategoryValue kind, DeriveWith c v (Rep a)) =>
DeriveTypeOptions kind c v -> kinded kind a -> [ConsRep v]
deriveTypeWith DeriveTypeOptions kind c v
options kinded kind a
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @(Rep a))

--  GENERIC UNION
class DeriveWith (c :: Type -> Constraint) (v :: Type) f where
  deriveTypeValue :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> DataType v
  deriveTypeDefinition :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]

instance (Datatype d, DeriveWith c v f) => DeriveWith c v (M1 D d f) where
  deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> M1 D d f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
options (M1 f a
src) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
options f a
src) {dataTypeName :: TypeName
dataTypeName = forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
__valueTypeName DeriveValueOptions kind c v
options}
  deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (M1 D d f) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options proxy (M1 D d f)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @f)

-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'
instance (DeriveWith c v a, DeriveWith c v b) => DeriveWith c v (a :+: b) where
  deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> (:+:) a b a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f (L1 a a
x) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f a a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
  deriveTypeValue DeriveValueOptions kind c v
f (R1 b a
x) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f b a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
  deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (a :+: b) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options proxy (a :+: b)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @b)

instance (DeriveFieldRep con v f, Constructor c) => DeriveWith con v (M1 C c f) where
  deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind con v -> M1 C c f a -> DataType v
deriveTypeValue DeriveValueOptions kind con v
options (M1 f a
src) =
    DataType
      { dataTypeName :: TypeName
dataTypeName = TypeName
"",
        tyIsUnion :: Bool
tyIsUnion = Bool
False,
        tyCons :: ConsRep v
tyCons = forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueGQLOptions DeriveValueOptions kind con v
options) (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind con v
options f a
src)
      }
  deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind con v -> proxy (M1 C c f) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind con v
options proxy (M1 C c f)
_ = [forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
__typeGQLOptions DeriveTypeOptions kind con v
options) (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind con v
options (forall {k} (t :: k). Proxy t
Proxy @f))]

deriveConsRep ::
  Constructor (c :: Meta) =>
  GQLTypeOptions ->
  f c ->
  [FieldRep v] ->
  ConsRep v
deriveConsRep :: forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep GQLTypeOptions
opt f c
proxy [FieldRep v]
fields =
  ConsRep
    { consName :: TypeName
consName = forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
GQLTypeOptions -> f c -> TypeName
conNameProxy GQLTypeOptions
opt f c
proxy,
      [FieldRep v]
consFields :: [FieldRep v]
consFields :: [FieldRep v]
consFields
    }
  where
    consFields :: [FieldRep v]
consFields
      | forall (f :: Meta -> *) (c :: Meta). Constructor c => f c -> Bool
isRecordProxy f c
proxy = [FieldRep v]
fields
      | Bool
otherwise = forall a. [FieldRep a] -> [FieldRep a]
enumerate [FieldRep v]
fields

class DeriveFieldRep (c :: Type -> Constraint) (v :: Type) f where
  toFieldRep :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> [FieldRep v]
  conRep :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]

instance (DeriveFieldRep c v a, DeriveFieldRep c v b) => DeriveFieldRep c v (a :*: b) where
  toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> (:*:) a b a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options (a a
a :*: b a
b) = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options a a
a forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options b a
b
  conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (a :*: b) -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options proxy (a :*: b)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
       (kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @b)

instance (Selector s, c a) => DeriveFieldRep c v (M1 S s (Rec0 a)) where
  toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> M1 S s (Rec0 a) a -> [FieldRep v]
toFieldRep DeriveValueOptions {TypeName
GQLTypeOptions
forall a. c a => a -> v
forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType :: forall (f :: * -> *) a. c a => f a -> TypeData
__valueApply :: forall a. c a => a -> v
__valueGQLOptions :: GQLTypeOptions
__valueTypeName :: TypeName
__valueGetType :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v
-> forall (f :: * -> *) a. c a => f a -> TypeData
__valueApply :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> forall a. c a => a -> v
__valueGQLOptions :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueTypeName :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
..} (M1 (K1 a
src)) =
    [ FieldRep
        { fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
__valueGQLOptions (forall {k} (t :: k). Proxy t
Proxy @s),
          fieldTypeRef :: TypeRef
fieldTypeRef = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
gqlTypeName TypeWrapper
gqlWrappers,
          fieldValue :: v
fieldValue = forall a. c a => a -> v
__valueApply a
src
        }
    ]
    where
      TypeData {TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName :: TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers} = forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType (forall {k} (t :: k). Proxy t
Proxy @a)
  conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v
-> proxy (M1 S s (Rec0 a)) -> [FieldRep v]
conRep DeriveTypeDefinitionOptions {GQLTypeOptions
forall (f :: * -> *) a. c a => f a -> v
forall (f :: * -> *) a. c a => f a -> TypeData
__typeGetType :: forall (f :: * -> *) a. c a => f a -> TypeData
__typeApply :: forall (f :: * -> *) a. c a => f a -> v
__typeGQLOptions :: GQLTypeOptions
__typeGetType :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> TypeData
__typeApply :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> v
__typeGQLOptions :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
..} proxy (M1 S s (Rec0 a))
_ =
    [ FieldRep
        { fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
__typeGQLOptions (forall {k} (t :: k). Proxy t
Proxy @s),
          fieldTypeRef :: TypeRef
fieldTypeRef = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
gqlTypeName TypeWrapper
gqlWrappers,
          fieldValue :: v
fieldValue = forall (f :: * -> *) a. c a => f a -> v
__typeApply (forall {k} (t :: k). Proxy t
Proxy @a)
        }
    ]
    where
      TypeData {TypeName
gqlTypeName :: TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers} = forall (f :: * -> *) a. c a => f a -> TypeData
__typeGetType (forall {k} (t :: k). Proxy t
Proxy @a)

instance DeriveFieldRep c v U1 where
  toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> U1 a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
_ U1 a
_ = []
  conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy U1 -> [FieldRep v]
conRep DeriveTypeOptions kind c v
_ proxy U1
_ = []