{-# LANGUAGE GADTs #-}

module Data.Morpheus.Server.Deriving.Schema.Union
  ( buildUnionTypeContent,
  )
where

import Data.List (partition)
import Data.Morpheus.Internal.Utils (fromElems)
import Data.Morpheus.Server.Deriving.Schema.Enum
  ( defineEnumUnit,
  )
import Data.Morpheus.Server.Deriving.Schema.Object
  ( defineObjectType,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    fieldTypeName,
    isEmptyConstraint,
    isUnionRef,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CategoryValue,
    KindedType (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType,
    TypeData (gqlTypeName),
    __typeData,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    FieldContent (..),
    IN,
    TRUE,
    TypeContent (..),
    TypeName,
    UnionMember (..),
    mkNullaryMember,
    mkUnionMember,
  )
import Relude

buildUnionTypeContent ::
  ( GQLType a,
    CategoryValue kind
  ) =>
  KindedType kind a ->
  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
  SchemaT c (TypeContent TRUE kind CONST)
buildUnionTypeContent :: forall a (kind :: TypeCategory) (c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
buildUnionTypeContent KindedType kind a
scope [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons = forall a (kind :: TypeCategory) (c :: TypeCategory).
GQLType a =>
KindedType kind a
-> [TypeName]
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType KindedType kind a
scope [TypeName]
unionRef [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons
  where
    unionRef :: [TypeName]
unionRef = forall k. FieldRep k -> TypeName
fieldTypeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall v. ConsRep v -> [FieldRep v]
consFields [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRefRep
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionRefRep, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall k. TypeName -> ConsRep k -> Bool
isUnionRef (TypeData -> TypeName
gqlTypeName (forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData KindedType kind a
scope))) [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons

mkUnionType ::
  GQLType a =>
  KindedType kind a ->
  [TypeName] ->
  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
  SchemaT c (TypeContent TRUE kind CONST)
mkUnionType :: forall a (kind :: TypeCategory) (c :: TypeCategory).
GQLType a =>
KindedType kind a
-> [TypeName]
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType p :: KindedType kind a
p@KindedType kind a
InputType [TypeName]
unionRef [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons = forall (s :: Stage) (a :: TypeCategory).
UnionTypeDefinition 'IN s -> TypeContent ('IN <=? a) a s
DataInputUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SchemaT c [UnionMember 'IN CONST]
typeMembers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems)
  where
    ([ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaryCons, [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons
    nullaryMembers :: [UnionMember IN CONST]
    nullaryMembers :: [UnionMember 'IN CONST]
nullaryMembers = forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkNullaryMember forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. ConsRep v -> TypeName
consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaryCons
    defineEnumEmpty :: SchemaT c ()
defineEnumEmpty
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaryCons = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = forall (cat :: TypeCategory). SchemaT cat ()
defineEnumUnit
    typeMembers :: SchemaT c [UnionMember 'IN CONST]
typeMembers =
      (forall a. Semigroup a => a -> a -> a
<> [UnionMember 'IN CONST]
nullaryMembers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> [UnionMember 'IN CONST]
withRefs
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( SchemaT c ()
defineEnumEmpty forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (kind :: TypeCategory) a (c :: TypeCategory).
KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions KindedType kind a
p [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons
            )
      where
        withRefs :: [TypeName] -> [UnionMember 'IN CONST]
withRefs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef forall a. Semigroup a => a -> a -> a
<>)
mkUnionType p :: KindedType kind a
p@KindedType kind a
OutputType [TypeName]
unionRef [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons =
  forall (s :: Stage) (a :: TypeCategory).
UnionTypeDefinition 'OUT s -> TypeContent ('OUT <=? a) a s
DataUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (kind :: TypeCategory) a (c :: TypeCategory).
KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions KindedType kind a
p [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef forall a. Semigroup a => a -> a -> a
<>))

buildUnions ::
  KindedType kind a ->
  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
  SchemaT c [TypeName]
buildUnions :: forall (kind :: TypeCategory) a (c :: TypeCategory).
KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
buildUnions KindedType kind a
proxy [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (kind :: TypeCategory) a (cat :: TypeCategory).
KindedType kind a
-> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat ()
defineObjectType KindedType kind a
proxy) [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ConsRep v -> TypeName
consName [ConsRep (Maybe (FieldContent TRUE kind CONST))]
cons