{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.AST.Union ( constraintInputUnion, mkUnionMember, mkNullaryMember, DataUnion, DataInputUnion, UnionMember (..), mkInputUnionFields, getInputUnionValue, ) where import Data.Morpheus.Internal.Utils ( Failure (..), KeyOf (..), elems, selectBy, ) import Data.Morpheus.Rendering.RenderGQL ( RenderGQL (..), ) import Data.Morpheus.Types.Internal.AST.Base ( FieldName (..), Message (..), Msg (..), TypeName (..), toFieldName, unitTypeName, ) import Data.Morpheus.Types.Internal.AST.Fields ( FieldDefinition (..), FieldsDefinition, unsafeFromFields, ) import Data.Morpheus.Types.Internal.AST.Stage ( Stage, ) import Data.Morpheus.Types.Internal.AST.Type ( TypeRef (..), TypeWrapper (..), ) import Data.Morpheus.Types.Internal.AST.TypeCategory ( IN, OUT, TypeCategory, ) import Data.Morpheus.Types.Internal.AST.Value ( Object, ObjectEntry (..), Value (..), ) import Language.Haskell.TH.Syntax (Lift (..)) import Relude mkUnionMember :: TypeName -> UnionMember cat s mkUnionMember :: TypeName -> UnionMember cat s mkUnionMember TypeName name = TypeName -> Bool -> UnionMember cat s forall (cat :: TypeCategory) (s :: Stage). TypeName -> Bool -> UnionMember cat s UnionMember TypeName name Bool False mkNullaryMember :: TypeName -> UnionMember cat s mkNullaryMember :: TypeName -> UnionMember cat s mkNullaryMember TypeName name = TypeName -> Bool -> UnionMember cat s forall (cat :: TypeCategory) (s :: Stage). TypeName -> Bool -> UnionMember cat s UnionMember TypeName name Bool True data UnionMember (cat :: TypeCategory) (s :: Stage) = UnionMember { UnionMember cat s -> TypeName memberName :: TypeName, UnionMember cat s -> Bool nullary :: Bool } deriving (Int -> UnionMember cat s -> ShowS [UnionMember cat s] -> ShowS UnionMember cat s -> String (Int -> UnionMember cat s -> ShowS) -> (UnionMember cat s -> String) -> ([UnionMember cat s] -> ShowS) -> Show (UnionMember cat s) forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a forall (cat :: TypeCategory) (s :: Stage). Int -> UnionMember cat s -> ShowS forall (cat :: TypeCategory) (s :: Stage). [UnionMember cat s] -> ShowS forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> String showList :: [UnionMember cat s] -> ShowS $cshowList :: forall (cat :: TypeCategory) (s :: Stage). [UnionMember cat s] -> ShowS show :: UnionMember cat s -> String $cshow :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> String showsPrec :: Int -> UnionMember cat s -> ShowS $cshowsPrec :: forall (cat :: TypeCategory) (s :: Stage). Int -> UnionMember cat s -> ShowS Show, UnionMember cat s -> Q Exp UnionMember cat s -> Q (TExp (UnionMember cat s)) (UnionMember cat s -> Q Exp) -> (UnionMember cat s -> Q (TExp (UnionMember cat s))) -> Lift (UnionMember cat s) forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Q Exp forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Q (TExp (UnionMember cat s)) liftTyped :: UnionMember cat s -> Q (TExp (UnionMember cat s)) $cliftTyped :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Q (TExp (UnionMember cat s)) lift :: UnionMember cat s -> Q Exp $clift :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Q Exp Lift, UnionMember cat s -> UnionMember cat s -> Bool (UnionMember cat s -> UnionMember cat s -> Bool) -> (UnionMember cat s -> UnionMember cat s -> Bool) -> Eq (UnionMember cat s) forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> UnionMember cat s -> Bool /= :: UnionMember cat s -> UnionMember cat s -> Bool $c/= :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> UnionMember cat s -> Bool == :: UnionMember cat s -> UnionMember cat s -> Bool $c== :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> UnionMember cat s -> Bool Eq) type DataUnion s = [UnionMember OUT s] type DataInputUnion s = [UnionMember IN s] instance RenderGQL (UnionMember cat s) where renderGQL :: UnionMember cat s -> Rendering renderGQL = TypeName -> Rendering forall a. RenderGQL a => a -> Rendering renderGQL (TypeName -> Rendering) -> (UnionMember cat s -> TypeName) -> UnionMember cat s -> Rendering forall b c a. (b -> c) -> (a -> b) -> a -> c . UnionMember cat s -> TypeName forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName instance Msg (UnionMember cat s) where msg :: UnionMember cat s -> Message msg = TypeName -> Message forall a. Msg a => a -> Message msg (TypeName -> Message) -> (UnionMember cat s -> TypeName) -> UnionMember cat s -> Message forall b c a. (b -> c) -> (a -> b) -> a -> c . UnionMember cat s -> TypeName forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName instance KeyOf TypeName (UnionMember cat s) where keyOf :: UnionMember cat s -> TypeName keyOf = UnionMember cat s -> TypeName forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName getInputUnionValue :: forall stage. Object stage -> Either Message (TypeName, Value stage) getInputUnionValue :: Object stage -> Either Message (TypeName, Value stage) getInputUnionValue Object stage hm = case Object stage -> [ObjectEntry stage] forall a coll. Elems a coll => coll -> [a] elems Object stage hm of [] -> Message -> Either Message (TypeName, Value stage) forall error (f :: * -> *) v. Failure error f => error -> f v failure (Message "Exclusive input objects must provide a value for at least one field." :: Message) [ObjectEntry (FieldName Text name) Value stage value] -> (TypeName, Value stage) -> Either Message (TypeName, Value stage) forall (f :: * -> *) a. Applicative f => a -> f a pure (Text -> TypeName TypeName Text name, Value stage value) [ObjectEntry stage] _ -> Message -> Either Message (TypeName, Value stage) forall error (f :: * -> *) v. Failure error f => error -> f v failure (Message "Exclusive input objects are not allowed to provide values for multiple fields." :: Message) constraintInputUnion :: forall stage schemaStage. [UnionMember IN schemaStage] -> Object stage -> Either Message (UnionMember IN schemaStage, Value stage) constraintInputUnion :: [UnionMember IN schemaStage] -> Object stage -> Either Message (UnionMember IN schemaStage, Value stage) constraintInputUnion [UnionMember IN schemaStage] tags Object stage hm = do (TypeName name, Value stage value) <- Object stage -> Either Message (TypeName, Value stage) forall (stage :: Stage). Object stage -> Either Message (TypeName, Value stage) getInputUnionValue Object stage hm (,Value stage value) (UnionMember IN schemaStage -> (UnionMember IN schemaStage, Value stage)) -> Either Message (UnionMember IN schemaStage) -> Either Message (UnionMember IN schemaStage, Value stage) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [UnionMember IN schemaStage] -> TypeName -> Either Message (UnionMember IN schemaStage) forall (s :: Stage). [UnionMember IN s] -> TypeName -> Either Message (UnionMember IN s) isPossibleInputUnion [UnionMember IN schemaStage] tags TypeName name isPossibleInputUnion :: [UnionMember IN s] -> TypeName -> Either Message (UnionMember IN s) isPossibleInputUnion :: [UnionMember IN s] -> TypeName -> Either Message (UnionMember IN s) isPossibleInputUnion [UnionMember IN s] tags TypeName name = Message -> TypeName -> [UnionMember IN s] -> Either Message (UnionMember IN s) forall e (m :: * -> *) k a c. (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a selectBy (TypeName -> Message forall a. Msg a => a -> Message msg TypeName name Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> Message " is not possible union type") TypeName name [UnionMember IN s] tags mkInputUnionFields :: [UnionMember IN s] -> FieldsDefinition IN s mkInputUnionFields :: [UnionMember IN s] -> FieldsDefinition IN s mkInputUnionFields = [FieldDefinition IN s] -> FieldsDefinition IN s forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields ([FieldDefinition IN s] -> FieldsDefinition IN s) -> ([UnionMember IN s] -> [FieldDefinition IN s]) -> [UnionMember IN s] -> FieldsDefinition IN s forall b c a. (b -> c) -> (a -> b) -> a -> c . (UnionMember IN s -> FieldDefinition IN s) -> [UnionMember IN s] -> [FieldDefinition IN s] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap UnionMember IN s -> FieldDefinition IN s forall (s :: Stage). UnionMember IN s -> FieldDefinition IN s mkInputUnionField mkInputUnionField :: UnionMember IN s -> FieldDefinition IN s mkInputUnionField :: UnionMember IN s -> FieldDefinition IN s mkInputUnionField UnionMember {TypeName memberName :: TypeName memberName :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName, Bool nullary :: Bool nullary :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Bool nullary} = FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage). Maybe Text -> FieldName -> TypeRef -> Maybe (FieldContent TRUE cat s) -> [Directive s] -> FieldDefinition cat s FieldDefinition { fieldName :: FieldName fieldName = TypeName -> FieldName toFieldName TypeName memberName, fieldDescription :: Maybe Text fieldDescription = Maybe Text forall a. Maybe a Nothing, fieldContent :: Maybe (FieldContent TRUE IN s) fieldContent = Maybe (FieldContent TRUE IN s) forall a. Maybe a Nothing, fieldType :: TypeRef fieldType = TypeRef :: TypeName -> [TypeWrapper] -> TypeRef TypeRef { TypeName typeConName :: TypeName typeConName :: TypeName typeConName, typeWrappers :: [TypeWrapper] typeWrappers = [TypeWrapper TypeMaybe] }, fieldDirectives :: [Directive s] fieldDirectives = [] } where typeConName :: TypeName typeConName | Bool nullary = TypeName unitTypeName | Bool otherwise = TypeName memberName