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