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