{-# 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.Server.Deriving.Utils.GRep
  ( GRep (..),
    RepContext (..),
    ConsRep (..),
    FieldRep (..),
    TypeRep (..),
    deriveValue,
    deriveTypeWith,
    isEmptyConstraint,
    isUnionRef,
    unpackMonad,
  )
where

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

data RepContext gql fun f result = RepContext
  { forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
optApply :: forall a. fun a => f a -> result,
    forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optTypeData :: forall proxy a. gql a => proxy a -> TypeData
  }

deriveValue ::
  (Generic a, GRep gql constraint value (Rep a), gql a) =>
  RepContext gql constraint Identity value ->
  a ->
  TypeRep value
deriveValue :: forall a (gql :: * -> Constraint) (constraint :: * -> Constraint)
       value.
(Generic a, GRep gql constraint value (Rep a), gql a) =>
RepContext gql constraint Identity value -> a -> TypeRep value
deriveValue RepContext gql constraint Identity value
options a
value = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql constraint Identity value
options (forall a x. Generic a => a -> Rep a x
from a
value)) {TypeName
dataTypeName :: TypeName
dataTypeName :: TypeName
dataTypeName}
  where
    dataTypeName :: TypeName
dataTypeName = TypeData -> TypeName
gqlTypeName (forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optTypeData RepContext gql constraint Identity value
options (forall a. a -> Identity a
Identity a
value))

deriveTypeWith ::
  forall kind gql c v kinded a.
  (GRep gql c v (Rep a)) =>
  RepContext gql c Proxy v ->
  kinded kind a ->
  [ConsRep v]
deriveTypeWith :: forall {k} (kind :: k) (gql :: * -> Constraint)
       (c :: * -> Constraint) v (kinded :: k -> * -> *) a.
GRep gql c v (Rep a) =>
RepContext gql c Proxy v -> kinded kind a -> [ConsRep v]
deriveTypeWith RepContext gql c Proxy v
options kinded kind a
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @(Rep a))

--  GENERIC UNION
class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
  deriveTypeValue :: RepContext gql c Identity v -> f a -> TypeRep v
  deriveTypeDefinition :: RepContext gql c Proxy v -> proxy f -> [ConsRep v]

instance (Datatype d, GRep gql c v f) => GRep gql c v (M1 D d f) where
  deriveTypeValue :: forall (a :: k).
RepContext gql c Identity v -> M1 D d f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
options (M1 f a
src) = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
options f a
src
  deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (M1 D d f) -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options proxy (M1 D d f)
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
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 :: forall (a :: k).
RepContext gql c Identity v -> (:+:) a b a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f (L1 a a
x) = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f a a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
  deriveTypeValue RepContext gql c Identity v
f (R1 b a
x) = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f b a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
  deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (a :+: b) -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options proxy (a :+: b)
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @b)

instance (DeriveFieldRep gql con v f, Constructor c) => GRep gql con v (M1 C c f) where
  deriveTypeValue :: forall (a :: k).
RepContext gql con Identity v -> M1 C c f a -> TypeRep v
deriveTypeValue RepContext gql con Identity v
options (M1 f a
src) =
    TypeRep
      { dataTypeName :: TypeName
dataTypeName = TypeName
"",
        tyIsUnion :: Bool
tyIsUnion = Bool
False,
        tyCons :: ConsRep v
tyCons = forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (a :: k).
DeriveFieldRep gql c v f =>
RepContext gql c Identity v -> f a -> [FieldRep v]
toFieldRep RepContext gql con Identity v
options f a
src)
      }
  deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql con Proxy v -> proxy (M1 C c f) -> [ConsRep v]
deriveTypeDefinition RepContext gql con Proxy v
options proxy (M1 C c f)
_ = [forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
       (f :: k -> *) (proxy :: (k -> *) -> *).
DeriveFieldRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [FieldRep v]
conRep RepContext gql con Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @f))]

deriveConsRep ::
  Constructor (c :: Meta) =>
  f c ->
  [FieldRep v] ->
  ConsRep v
deriveConsRep :: forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep f c
proxy [FieldRep v]
fields = ConsRep {[FieldRep v]
TypeName
consFields :: [FieldRep v]
consName :: TypeName
consFields :: [FieldRep v]
consName :: TypeName
..}
  where
    consName :: TypeName
consName = forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
f c -> TypeName
conNameProxy f c
proxy
    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 (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
  toFieldRep :: RepContext gql c Identity v -> f a -> [FieldRep v]
  conRep :: RepContext gql c Proxy v -> proxy f -> [FieldRep v]

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

instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where
  toFieldRep :: forall (a :: k).
RepContext gql c Identity v -> M1 S s (Rec0 a) a -> [FieldRep v]
toFieldRep RepContext {forall a. c a => Identity a -> v
forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optApply :: forall a. c a => Identity a -> v
optTypeData :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optApply :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
..} (M1 (K1 a
src)) =
    [ FieldRep
        { fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (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 => Identity a -> v
optApply (forall a. a -> Identity a
Identity a
src)
        }
    ]
    where
      TypeData {TypeName
gqlTypeName :: TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers} = forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData (forall {k} (t :: k). Proxy t
Proxy @a)
  conRep :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (M1 S s (Rec0 a)) -> [FieldRep v]
conRep RepContext {forall a. c a => Proxy a -> v
forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optApply :: forall a. c a => Proxy a -> v
optTypeData :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optApply :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
       (f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
..} proxy (M1 S s (Rec0 a))
_ =
    [ FieldRep
        { fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (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 => Proxy a -> v
optApply (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 (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData (forall {k} (t :: k). Proxy t
Proxy @a)

instance DeriveFieldRep gql c v U1 where
  toFieldRep :: forall (a :: k).
RepContext gql c Identity v -> U1 a -> [FieldRep v]
toFieldRep RepContext gql c Identity v
_ U1 a
_ = []
  conRep :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy U1 -> [FieldRep v]
conRep RepContext gql c Proxy v
_ proxy U1
_ = []

data TypeRep (v :: Type) = TypeRep
  { forall v. TypeRep v -> TypeName
dataTypeName :: TypeName,
    forall v. TypeRep v -> Bool
tyIsUnion :: Bool,
    forall v. TypeRep v -> ConsRep v
tyCons :: ConsRep v
  }
  deriving (forall a b. a -> TypeRep b -> TypeRep a
forall a b. (a -> b) -> TypeRep a -> TypeRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TypeRep b -> TypeRep a
$c<$ :: forall a b. a -> TypeRep b -> TypeRep a
fmap :: forall a b. (a -> b) -> TypeRep a -> TypeRep b
$cfmap :: forall a b. (a -> b) -> TypeRep a -> TypeRep b
Functor)

data ConsRep (v :: Type) = ConsRep
  { forall v. ConsRep v -> TypeName
consName :: TypeName,
    forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep v]
  }
  deriving (forall a b. a -> ConsRep b -> ConsRep a
forall a b. (a -> b) -> ConsRep a -> ConsRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ConsRep b -> ConsRep a
$c<$ :: forall a b. a -> ConsRep b -> ConsRep a
fmap :: forall a b. (a -> b) -> ConsRep a -> ConsRep b
$cfmap :: forall a b. (a -> b) -> ConsRep a -> ConsRep b
Functor)

data FieldRep (a :: Type) = FieldRep
  { forall a. FieldRep a -> FieldName
fieldSelector :: FieldName,
    forall a. FieldRep a -> TypeRef
fieldTypeRef :: TypeRef,
    forall a. FieldRep a -> a
fieldValue :: a
  }
  deriving (forall a b. a -> FieldRep b -> FieldRep a
forall a b. (a -> b) -> FieldRep a -> FieldRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FieldRep b -> FieldRep a
$c<$ :: forall a b. a -> FieldRep b -> FieldRep a
fmap :: forall a b. (a -> b) -> FieldRep a -> FieldRep b
$cfmap :: forall a b. (a -> b) -> FieldRep a -> FieldRep b
Functor)

-- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }
enumerate :: [FieldRep a] -> [FieldRep a]
enumerate :: forall a. [FieldRep a] -> [FieldRep a]
enumerate = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a}. Show a => a -> FieldRep a -> FieldRep a
setFieldName ([Int
0 ..] :: [Int])
  where
    setFieldName :: a -> FieldRep a -> FieldRep a
setFieldName a
i FieldRep a
field = FieldRep a
field {fieldSelector :: FieldName
fieldSelector = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ Text
"_" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall b a. (Show a, IsString b) => a -> b
show a
i)}

isEmptyConstraint :: ConsRep a -> Bool
isEmptyConstraint :: forall a. ConsRep a -> Bool
isEmptyConstraint ConsRep {consFields :: forall v. ConsRep v -> [FieldRep v]
consFields = []} = Bool
True
isEmptyConstraint ConsRep a
_ = Bool
False

isUnionRef :: TypeName -> ConsRep k -> Bool
isUnionRef :: forall k. TypeName -> ConsRep k -> Bool
isUnionRef TypeName
baseName ConsRep {TypeName
consName :: TypeName
consName :: forall v. ConsRep v -> TypeName
consName, consFields :: forall v. ConsRep v -> [FieldRep v]
consFields = [FieldRep k
fieldRep]} =
  TypeName
consName forall a. Eq a => a -> a -> Bool
== TypeName
baseName forall a. Semigroup a => a -> a -> a
<> TypeRef -> TypeName
typeConName (forall a. FieldRep a -> TypeRef
fieldTypeRef FieldRep k
fieldRep)
isUnionRef TypeName
_ ConsRep k
_ = Bool
False

unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad :: forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons

unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField :: forall (m :: * -> *) a. Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField FieldRep {m a
TypeRef
FieldName
fieldValue :: m a
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
fieldValue :: forall a. FieldRep a -> a
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
..} = do
  a
cont <- m a
fieldValue
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldRep {fieldValue :: a
fieldValue = a
cont, TypeRef
FieldName
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..})

unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons :: forall (m :: * -> *) a. Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons ConsRep {[FieldRep (m a)]
TypeName
consFields :: [FieldRep (m a)]
consName :: TypeName
consFields :: forall v. ConsRep v -> [FieldRep v]
consName :: forall v. ConsRep v -> TypeName
..} = forall v. TypeName -> [FieldRep v] -> ConsRep v
ConsRep TypeName
consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField [FieldRep (m a)]
consFields