{-# 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 :: 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)

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 "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
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 = 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 -> GQLError
msg = TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeName -> GQLError)
-> (UnionMember cat s -> TypeName) -> UnionMember cat s -> GQLError
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 GQLError (TypeName, Value stage)
getInputUnionValue :: Object stage -> Either GQLError (TypeName, Value stage)
getInputUnionValue Object stage
hm =
  case Object stage -> [ObjectEntry stage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object stage
hm of
    [] -> GQLError -> Either GQLError (TypeName, Value stage)
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] -> (TypeName, Value stage) -> Either GQLError (TypeName, Value stage)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> TypeName
coerce FieldName
name, Value stage
value)
    [ObjectEntry stage]
_ -> GQLError -> Either GQLError (TypeName, Value 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 :: 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) <- Object stage -> Either GQLError (TypeName, Value stage)
forall (stage :: Stage).
Object stage -> Either GQLError (TypeName, Value stage)
getInputUnionValue Object stage
hm
  (,Value stage
value) (UnionMember IN schemaStage
 -> (UnionMember IN schemaStage, Value stage))
-> Either GQLError (UnionMember IN schemaStage)
-> Either GQLError (UnionMember IN schemaStage, Value stage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnionTypeDefinition IN schemaStage
-> TypeName -> Either GQLError (UnionMember IN schemaStage)
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 :: UnionTypeDefinition IN s
-> TypeName -> Either GQLError (UnionMember IN s)
isPossibleInputUnion UnionTypeDefinition IN s
tags TypeName
name =
  GQLError
-> TypeName
-> UnionTypeDefinition IN s
-> Either GQLError (UnionMember IN s)
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
    (TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
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 :: t (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)
-> (t (UnionMember IN s) -> [FieldDefinition IN s])
-> t (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 ([UnionMember IN s] -> [FieldDefinition IN s])
-> (t (UnionMember IN s) -> [UnionMember IN s])
-> t (UnionMember IN s)
-> [FieldDefinition IN s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (UnionMember IN s) -> [UnionMember IN s]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

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 Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> Directives s
-> FieldDefinition cat s
FieldDefinition
    { fieldName :: FieldName
fieldName = TypeName -> FieldName
coerce TypeName
memberName,
      fieldDescription :: Maybe Description
fieldDescription = Maybe Description
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
mkMaybeType
          },
      fieldDirectives :: Directives s
fieldDirectives = Directives s
forall coll. Empty coll => coll
empty
    }
  where
    typeConName :: TypeName
typeConName
      | Bool
nullary = TypeName
unitTypeName
      | Bool
otherwise = TypeName
memberName