{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}

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

import Data.List (partition)
import Data.Morpheus.Internal.Utils (fromElems)
import Data.Morpheus.Server.Deriving.Internal.Schema.Enum
  ( defineEnumUnit,
  )
import Data.Morpheus.Server.Deriving.Internal.Schema.Object
  ( defineObjectType,
  )
import Data.Morpheus.Server.Deriving.Utils.GRep
  ( ConsRep (..),
    FieldRep (fieldTypeRef),
    isEmptyConstraint,
    isUnionRef,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useTypename)
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
  )
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition,
    CONST,
    IN,
    TRUE,
    TypeContent (..),
    TypeName,
    TypeRef (..),
    UnionMember (..),
    mkNullaryMember,
    mkUnionMember,
  )
import Relude

buildUnionTypeContent ::
  (gql a) =>
  UseGQLType gql ->
  CatType kind a ->
  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->
  SchemaT k (TypeContent TRUE kind CONST)
buildUnionTypeContent :: forall (gql :: * -> Constraint) a (kind :: TypeCategory)
       (k :: TypeCategory).
gql a =>
UseGQLType gql
-> CatType kind a
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT k (TypeContent TRUE kind CONST)
buildUnionTypeContent UseGQLType gql
gql CatType kind a
scope [ConsRep (Maybe (ArgumentsDefinition CONST))]
cons = forall (kind :: TypeCategory) a (c :: TypeCategory).
CatType kind a
-> [TypeName]
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType CatType kind a
scope [TypeName]
unionRef [ConsRep (Maybe (ArgumentsDefinition CONST))]
unionCons
  where
    unionRef :: [TypeName]
unionRef = TypeRef -> TypeName
typeConName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FieldRep a -> TypeRef
fieldTypeRef 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 (ArgumentsDefinition CONST))]
unionRefRep
    ([ConsRep (Maybe (ArgumentsDefinition CONST))]
unionRefRep, [ConsRep (Maybe (ArgumentsDefinition CONST))]
unionCons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall k. TypeName -> ConsRep k -> Bool
isUnionRef (forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName
useTypename UseGQLType gql
gql CatType kind a
scope)) [ConsRep (Maybe (ArgumentsDefinition CONST))]
cons

mkUnionType ::
  CatType kind a ->
  [TypeName] ->
  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->
  SchemaT c (TypeContent TRUE kind CONST)
mkUnionType :: forall (kind :: TypeCategory) a (c :: TypeCategory).
CatType kind a
-> [TypeName]
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
mkUnionType p :: CatType kind a
p@CatType kind a
InputType [TypeName]
unionRef [ConsRep (Maybe (ArgumentsDefinition 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 (ArgumentsDefinition CONST))]
nullaryCons, [ConsRep (Maybe (ArgumentsDefinition CONST))]
cons) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (Maybe (ArgumentsDefinition 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 (ArgumentsDefinition CONST))]
nullaryCons
    defineEnumEmpty :: SchemaT c ()
defineEnumEmpty
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConsRep (Maybe (ArgumentsDefinition 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).
CatType kind a
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT c [TypeName]
buildUnions CatType kind a
p [ConsRep (Maybe (ArgumentsDefinition 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 :: CatType kind a
p@CatType kind a
OutputType [TypeName]
unionRef [ConsRep (Maybe (ArgumentsDefinition 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).
CatType kind a
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT c [TypeName]
buildUnions CatType kind a
p [ConsRep (Maybe (ArgumentsDefinition 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 ::
  CatType kind a ->
  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->
  SchemaT c [TypeName]
buildUnions :: forall (kind :: TypeCategory) a (c :: TypeCategory).
CatType kind a
-> [ConsRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT c [TypeName]
buildUnions CatType kind a
proxy [ConsRep (Maybe (ArgumentsDefinition CONST))]
cons =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (kind :: TypeCategory) a (cat :: TypeCategory).
CatType kind a
-> ConsRep (Maybe (ArgumentsDefinition CONST)) -> SchemaT cat ()
defineObjectType CatType kind a
proxy) [ConsRep (Maybe (ArgumentsDefinition 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 (ArgumentsDefinition CONST))]
cons