{-# 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 :: 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 = KindedType kind a
-> [TypeName]
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
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 = FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall k. FieldRep k -> TypeName
fieldTypeName (FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConsRep (Maybe (FieldContent TRUE kind CONST))
 -> [FieldRep (Maybe (FieldContent TRUE kind CONST))])
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConsRep (Maybe (FieldContent TRUE kind CONST))
-> [FieldRep (Maybe (FieldContent TRUE kind CONST))]
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) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ([ConsRep (Maybe (FieldContent TRUE kind CONST))],
    [ConsRep (Maybe (FieldContent TRUE kind CONST))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TypeName -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool
forall k. TypeName -> ConsRep k -> Bool
isUnionRef (TypeData -> TypeName
gqlTypeName (KindedType kind a -> TypeData
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 :: 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 = UnionTypeDefinition IN CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
UnionTypeDefinition IN s -> TypeContent (IN <=? a) a s
DataInputUnion (UnionTypeDefinition IN CONST -> TypeContent TRUE kind CONST)
-> SchemaT c (UnionTypeDefinition IN CONST)
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SchemaT c [UnionMember IN CONST]
typeMembers SchemaT c [UnionMember IN CONST]
-> ([UnionMember IN CONST]
    -> SchemaT c (UnionTypeDefinition IN CONST))
-> SchemaT c (UnionTypeDefinition IN CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [UnionMember IN CONST] -> SchemaT c (UnionTypeDefinition IN CONST)
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) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> ([ConsRep (Maybe (FieldContent TRUE kind CONST))],
    [ConsRep (Maybe (FieldContent TRUE kind CONST))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool
forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind CONST))]
unionCons
    nullaryMembers :: [UnionMember IN CONST]
    nullaryMembers :: [UnionMember IN CONST]
nullaryMembers = TypeName -> UnionMember IN CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkNullaryMember (TypeName -> UnionMember IN CONST)
-> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName)
-> ConsRep (Maybe (FieldContent TRUE kind CONST))
-> UnionMember IN CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName
forall v. ConsRep v -> TypeName
consName (ConsRep (Maybe (FieldContent TRUE kind CONST))
 -> UnionMember IN CONST)
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> [UnionMember IN CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaryCons
    defineEnumEmpty :: SchemaT c ()
defineEnumEmpty
      | [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConsRep (Maybe (FieldContent TRUE kind CONST))]
nullaryCons = () -> SchemaT c ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = SchemaT c ()
forall (cat :: TypeCategory). SchemaT cat ()
defineEnumUnit
    typeMembers :: SchemaT c [UnionMember IN CONST]
typeMembers =
      ([UnionMember IN CONST]
-> [UnionMember IN CONST] -> [UnionMember IN CONST]
forall a. Semigroup a => a -> a -> a
<> [UnionMember IN CONST]
nullaryMembers) ([UnionMember IN CONST] -> [UnionMember IN CONST])
-> ([TypeName] -> [UnionMember IN CONST])
-> [TypeName]
-> [UnionMember IN CONST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> [UnionMember IN CONST]
withRefs
        ([TypeName] -> [UnionMember IN CONST])
-> SchemaT c [TypeName] -> SchemaT c [UnionMember IN CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( SchemaT c ()
defineEnumEmpty SchemaT c () -> SchemaT c [TypeName] -> SchemaT c [TypeName]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
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 = (TypeName -> UnionMember IN CONST)
-> [TypeName] -> [UnionMember IN CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeName -> UnionMember IN CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember ([TypeName] -> [UnionMember IN CONST])
-> ([TypeName] -> [TypeName])
-> [TypeName]
-> [UnionMember IN CONST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
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 =
  UnionTypeDefinition OUT CONST -> TypeContent TRUE kind CONST
forall (s :: Stage) (a :: TypeCategory).
UnionTypeDefinition OUT s -> TypeContent (OUT <=? a) a s
DataUnion (UnionTypeDefinition OUT CONST -> TypeContent TRUE kind CONST)
-> SchemaT c (UnionTypeDefinition OUT CONST)
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c [TypeName]
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 SchemaT c [TypeName]
-> ([TypeName] -> SchemaT c (UnionTypeDefinition OUT CONST))
-> SchemaT c (UnionTypeDefinition OUT CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [UnionMember OUT CONST]
-> SchemaT c (UnionTypeDefinition OUT CONST)
forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems ([UnionMember OUT CONST]
 -> SchemaT c (UnionTypeDefinition OUT CONST))
-> ([TypeName] -> [UnionMember OUT CONST])
-> [TypeName]
-> SchemaT c (UnionTypeDefinition OUT CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeName -> UnionMember OUT CONST)
-> [TypeName] -> [UnionMember OUT CONST]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> UnionMember OUT CONST
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember ([TypeName] -> [UnionMember OUT CONST])
-> ([TypeName] -> [TypeName])
-> [TypeName]
-> [UnionMember OUT CONST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeName]
unionRef [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<>))

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