{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.AST.Union ( constraintInputUnion, mkUnionMember, mkNullaryMember, UnionTypeDefinition, UnionMember (..), mkInputUnionFields, getInputUnionValue, ) where import Control.Monad.Except (throwError) import Data.Mergeable (NameCollision (..), OrdMap) import Data.Morpheus.Internal.Utils ( Empty (empty), KeyOf (..), selectBy, ) import Data.Morpheus.Rendering.RenderGQL ( RenderGQL (..), ) import Data.Morpheus.Types.Internal.AST.Error ( GQLError, Msg (..), msg, ) import Data.Morpheus.Types.Internal.AST.Fields ( FieldDefinition (..), FieldsDefinition, unsafeFromFields, ) import Data.Morpheus.Types.Internal.AST.Name ( TypeName, unitTypeName, ) import Data.Morpheus.Types.Internal.AST.Stage ( Stage, ) import Data.Morpheus.Types.Internal.AST.Type ( TypeRef (..), mkMaybeType, ) import Data.Morpheus.Types.Internal.AST.TypeCategory ( IN, TypeCategory, ) import Data.Morpheus.Types.Internal.AST.Value ( Object, ObjectEntry (..), Value (..), ) import Language.Haskell.TH.Syntax (Lift (..)) import Relude hiding (empty) mkUnionMember :: TypeName -> UnionMember cat s mkUnionMember :: forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember TypeName name = forall (cat :: TypeCategory) (s :: Stage). TypeName -> Bool -> UnionMember cat s UnionMember TypeName name Bool False mkNullaryMember :: TypeName -> UnionMember cat s mkNullaryMember :: forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkNullaryMember TypeName name = forall (cat :: TypeCategory) (s :: Stage). TypeName -> Bool -> UnionMember cat s UnionMember TypeName name Bool True data UnionMember (cat :: TypeCategory) (s :: Stage) = UnionMember { forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName :: TypeName, forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> Bool nullary :: Bool } deriving (Int -> UnionMember cat s -> ShowS 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, forall t. (forall (m :: * -> *). Quote m => t -> m Exp) -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t forall (cat :: TypeCategory) (s :: Stage) (m :: * -> *). Quote m => UnionMember cat s -> m Exp forall (cat :: TypeCategory) (s :: Stage) (m :: * -> *). Quote m => UnionMember cat s -> Code m (UnionMember cat s) forall (m :: * -> *). Quote m => UnionMember cat s -> m Exp forall (m :: * -> *). Quote m => UnionMember cat s -> Code m (UnionMember cat s) liftTyped :: forall (m :: * -> *). Quote m => UnionMember cat s -> Code m (UnionMember cat s) $cliftTyped :: forall (cat :: TypeCategory) (s :: Stage) (m :: * -> *). Quote m => UnionMember cat s -> Code m (UnionMember cat s) lift :: forall (m :: * -> *). Quote m => UnionMember cat s -> m Exp $clift :: forall (cat :: TypeCategory) (s :: Stage) (m :: * -> *). Quote m => UnionMember cat s -> m Exp Lift, UnionMember cat s -> UnionMember cat s -> Bool 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) instance NameCollision GQLError (UnionMember c s) where nameCollision :: UnionMember c s -> GQLError nameCollision UnionMember {TypeName memberName :: TypeName memberName :: forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName} = GQLError "There can Be only one union variant named " forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg TypeName memberName type UnionTypeDefinition k s = OrdMap TypeName (UnionMember k s) instance RenderGQL (UnionMember cat s) where renderGQL :: UnionMember cat s -> Rendering renderGQL = forall a. RenderGQL a => a -> Rendering renderGQL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName instance Msg (UnionMember cat s) where msg :: UnionMember cat s -> GQLError msg = forall a. Msg a => a -> GQLError msg forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName instance KeyOf TypeName (UnionMember cat s) where keyOf :: UnionMember cat s -> TypeName keyOf = forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName getInputUnionValue :: forall stage. Object stage -> Either GQLError (TypeName, Value stage) getInputUnionValue :: forall (stage :: Stage). Object stage -> Either GQLError (TypeName, Value stage) getInputUnionValue Object stage hm = case forall (t :: * -> *) a. Foldable t => t a -> [a] toList Object stage hm of [] -> forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "Exclusive input objects must provide a value for at least one field." [ObjectEntry FieldName name Value stage value] -> forall (f :: * -> *) a. Applicative f => a -> f a pure (coerce :: forall a b. Coercible a b => a -> b coerce FieldName name, Value stage value) [ObjectEntry stage] _ -> forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "Exclusive input objects are not allowed to provide values for multiple fields." constraintInputUnion :: forall stage schemaStage. UnionTypeDefinition IN schemaStage -> Object stage -> Either GQLError (UnionMember IN schemaStage, Value stage) constraintInputUnion :: forall (stage :: Stage) (schemaStage :: Stage). UnionTypeDefinition IN schemaStage -> Object stage -> Either GQLError (UnionMember IN schemaStage, Value stage) constraintInputUnion UnionTypeDefinition IN schemaStage tags Object stage hm = do (TypeName name, Value stage value) <- forall (stage :: Stage). Object stage -> Either GQLError (TypeName, Value stage) getInputUnionValue Object stage hm (,Value stage value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (s :: Stage). UnionTypeDefinition IN s -> TypeName -> Either GQLError (UnionMember IN s) isPossibleInputUnion UnionTypeDefinition IN schemaStage tags TypeName name isPossibleInputUnion :: UnionTypeDefinition IN s -> TypeName -> Either GQLError (UnionMember IN s) isPossibleInputUnion :: forall (s :: Stage). UnionTypeDefinition IN s -> TypeName -> Either GQLError (UnionMember IN s) isPossibleInputUnion UnionTypeDefinition IN s tags TypeName name = forall e (m :: * -> *) k (c :: * -> *) a. (MonadError e m, IsMap k c, Monad m) => e -> k -> c a -> m a selectBy (forall a. Msg a => a -> GQLError msg TypeName name forall a. Semigroup a => a -> a -> a <> GQLError " is not possible union type") TypeName name UnionTypeDefinition IN s tags mkInputUnionFields :: Foldable t => t (UnionMember IN s) -> FieldsDefinition IN s mkInputUnionFields :: forall (t :: * -> *) (s :: Stage). Foldable t => t (UnionMember IN s) -> FieldsDefinition IN s mkInputUnionFields = forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (s :: Stage). UnionMember IN s -> FieldDefinition IN s mkInputUnionField forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> [a] toList mkInputUnionField :: UnionMember IN s -> FieldDefinition IN s mkInputUnionField :: forall (s :: Stage). 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 { fieldName :: FieldName fieldName = coerce :: forall a b. Coercible a b => a -> b coerce TypeName memberName, fieldDescription :: Maybe Description fieldDescription = forall a. Maybe a Nothing, fieldContent :: Maybe (FieldContent TRUE IN s) fieldContent = forall a. Maybe a Nothing, fieldType :: TypeRef fieldType = TypeRef { TypeName typeConName :: TypeName typeConName :: TypeName typeConName, typeWrappers :: TypeWrapper typeWrappers = TypeWrapper mkMaybeType }, fieldDirectives :: Directives s fieldDirectives = forall coll. Empty coll => coll empty } where typeConName :: TypeName typeConName | Bool nullary = TypeName unitTypeName | Bool otherwise = TypeName memberName