{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.Transform.Core
  ( Converter (..),
    compileError,
    getType,
    leafType,
    typeFrom,
    deprecationWarning,
    customScalarTypes,
    UpdateT (..),
    resolveUpdates,
  )
where

import Data.Morpheus.Client.Internal.Types
  ( ClientTypeDefinition (..),
  )
import Data.Morpheus.Error
  ( deprecatedField,
    globalErrorMessage,
  )
import Data.Morpheus.Internal.Ext
  ( Eventless,
    Result (..),
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    nameSpaceType,
    selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    Directives,
    FieldName,
    GQLErrors,
    Message,
    RAW,
    Ref (..),
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    VALID,
    ValidationError,
    VariableDefinitions,
    hsTypeName,
    isNotSystemTypeName,
    lookupDeprecated,
    lookupDeprecatedReason,
    msg,
    toGQLError,
  )
import Relude

type Env = (Schema VALID, VariableDefinitions RAW)

newtype Converter a = Converter
  { Converter a -> ReaderT Env Eventless a
runConverter ::
      ReaderT
        Env
        Eventless
        a
  }
  deriving
    ( a -> Converter b -> Converter a
(a -> b) -> Converter a -> Converter b
(forall a b. (a -> b) -> Converter a -> Converter b)
-> (forall a b. a -> Converter b -> Converter a)
-> Functor Converter
forall a b. a -> Converter b -> Converter a
forall a b. (a -> b) -> Converter a -> Converter b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Converter b -> Converter a
$c<$ :: forall a b. a -> Converter b -> Converter a
fmap :: (a -> b) -> Converter a -> Converter b
$cfmap :: forall a b. (a -> b) -> Converter a -> Converter b
Functor,
      Functor Converter
a -> Converter a
Functor Converter
-> (forall a. a -> Converter a)
-> (forall a b. Converter (a -> b) -> Converter a -> Converter b)
-> (forall a b c.
    (a -> b -> c) -> Converter a -> Converter b -> Converter c)
-> (forall a b. Converter a -> Converter b -> Converter b)
-> (forall a b. Converter a -> Converter b -> Converter a)
-> Applicative Converter
Converter a -> Converter b -> Converter b
Converter a -> Converter b -> Converter a
Converter (a -> b) -> Converter a -> Converter b
(a -> b -> c) -> Converter a -> Converter b -> Converter c
forall a. a -> Converter a
forall a b. Converter a -> Converter b -> Converter a
forall a b. Converter a -> Converter b -> Converter b
forall a b. Converter (a -> b) -> Converter a -> Converter b
forall a b c.
(a -> b -> c) -> Converter a -> Converter b -> Converter c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Converter a -> Converter b -> Converter a
$c<* :: forall a b. Converter a -> Converter b -> Converter a
*> :: Converter a -> Converter b -> Converter b
$c*> :: forall a b. Converter a -> Converter b -> Converter b
liftA2 :: (a -> b -> c) -> Converter a -> Converter b -> Converter c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Converter a -> Converter b -> Converter c
<*> :: Converter (a -> b) -> Converter a -> Converter b
$c<*> :: forall a b. Converter (a -> b) -> Converter a -> Converter b
pure :: a -> Converter a
$cpure :: forall a. a -> Converter a
$cp1Applicative :: Functor Converter
Applicative,
      Applicative Converter
a -> Converter a
Applicative Converter
-> (forall a b. Converter a -> (a -> Converter b) -> Converter b)
-> (forall a b. Converter a -> Converter b -> Converter b)
-> (forall a. a -> Converter a)
-> Monad Converter
Converter a -> (a -> Converter b) -> Converter b
Converter a -> Converter b -> Converter b
forall a. a -> Converter a
forall a b. Converter a -> Converter b -> Converter b
forall a b. Converter a -> (a -> Converter b) -> Converter b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Converter a
$creturn :: forall a. a -> Converter a
>> :: Converter a -> Converter b -> Converter b
$c>> :: forall a b. Converter a -> Converter b -> Converter b
>>= :: Converter a -> (a -> Converter b) -> Converter b
$c>>= :: forall a b. Converter a -> (a -> Converter b) -> Converter b
$cp1Monad :: Applicative Converter
Monad,
      MonadReader Env,
      Failure GQLErrors
    )

instance Failure ValidationError Converter where
  failure :: ValidationError -> Converter v
failure ValidationError
err = GQLErrors -> Converter v
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [ValidationError -> GQLError
toGQLError ValidationError
err]

newtype UpdateT m a = UpdateT {UpdateT m a -> a -> m a
updateTState :: a -> m a}

resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a
resolveUpdates :: a -> [UpdateT m a] -> m a
resolveUpdates a
a = (a -> (a -> m a) -> m a) -> a -> [a -> m a] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM a -> (a -> m a) -> m a
forall a b. a -> (a -> b) -> b
(&) a
a ([a -> m a] -> m a)
-> ([UpdateT m a] -> [a -> m a]) -> [UpdateT m a] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UpdateT m a -> a -> m a) -> [UpdateT m a] -> [a -> m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UpdateT m a -> a -> m a
forall (m :: * -> *) a. UpdateT m a -> a -> m a
updateTState

compileError :: Message -> GQLErrors
compileError :: Message -> GQLErrors
compileError Message
x =
  Message -> GQLErrors
globalErrorMessage (Message -> GQLErrors) -> Message -> GQLErrors
forall a b. (a -> b) -> a -> b
$ Message
"Unhandled Compile Time Error: \"" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
x Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"\" ;"

getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType TypeName
typename = (Env -> Schema VALID) -> Converter (Schema VALID)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Schema VALID
forall a b. (a, b) -> a
fst Converter (Schema VALID)
-> (Schema VALID -> Converter (TypeDefinition ANY VALID))
-> Converter (TypeDefinition ANY VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GQLErrors
-> TypeName -> Schema VALID -> Converter (TypeDefinition ANY VALID)
forall e (m :: * -> *) k a c.
(Failure e m, Selectable k a c, Monad m) =>
e -> k -> c -> m a
selectBy (Message -> GQLErrors
compileError (Message -> GQLErrors) -> Message -> GQLErrors
forall a b. (a -> b) -> a -> b
$ Message
" can't find Type" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
typename) TypeName
typename

customScalarTypes :: TypeName -> [TypeName]
customScalarTypes :: TypeName -> [TypeName]
customScalarTypes TypeName
typeName
  | TypeName -> Bool
isNotSystemTypeName TypeName
typeName = [TypeName
typeName]
  | Bool
otherwise = []

leafType :: TypeDefinition a VALID -> Converter ([ClientTypeDefinition], [TypeName])
leafType :: TypeDefinition a VALID
-> Converter ([ClientTypeDefinition], [TypeName])
leafType TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName, TypeContent TRUE a VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE a VALID
typeContent} = TypeContent TRUE a VALID
-> Converter ([ClientTypeDefinition], [TypeName])
forall (a :: TypeCategory).
TypeContent TRUE a VALID
-> Converter ([ClientTypeDefinition], [TypeName])
fromKind TypeContent TRUE a VALID
typeContent
  where
    fromKind :: TypeContent TRUE a VALID -> Converter ([ClientTypeDefinition], [TypeName])
    fromKind :: TypeContent TRUE a VALID
-> Converter ([ClientTypeDefinition], [TypeName])
fromKind DataEnum {} = ([ClientTypeDefinition], [TypeName])
-> Converter ([ClientTypeDefinition], [TypeName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [TypeName
typeName])
    fromKind DataScalar {} = ([ClientTypeDefinition], [TypeName])
-> Converter ([ClientTypeDefinition], [TypeName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], TypeName -> [TypeName]
customScalarTypes TypeName
typeName)
    fromKind TypeContent TRUE a VALID
_ = GQLErrors -> Converter ([ClientTypeDefinition], [TypeName])
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (GQLErrors -> Converter ([ClientTypeDefinition], [TypeName]))
-> GQLErrors -> Converter ([ClientTypeDefinition], [TypeName])
forall a b. (a -> b) -> a -> b
$ Message -> GQLErrors
compileError Message
"Invalid schema Expected scalar"

typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName
typeFrom [FieldName]
path TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, TypeContent TRUE a VALID
typeContent :: TypeContent TRUE a VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} = TypeContent TRUE a VALID -> TypeName
__typeFrom TypeContent TRUE a VALID
typeContent
  where
    __typeFrom :: TypeContent TRUE a VALID -> TypeName
__typeFrom DataScalar {} = TypeName -> TypeName
hsTypeName TypeName
typeName
    __typeFrom DataObject {} = [FieldName] -> TypeName -> TypeName
nameSpaceType [FieldName]
path TypeName
typeName
    __typeFrom DataInterface {} = [FieldName] -> TypeName -> TypeName
nameSpaceType [FieldName]
path TypeName
typeName
    __typeFrom DataUnion {} = [FieldName] -> TypeName -> TypeName
nameSpaceType [FieldName]
path TypeName
typeName
    __typeFrom TypeContent TRUE a VALID
_ = TypeName
typeName

deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter ()
deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter ()
deprecationWarning Directives VALID
dirs (FieldName
typename, Ref FieldName
ref) = case Directives VALID -> Maybe (Directive VALID)
forall (s :: Stage). [Directive s] -> Maybe (Directive s)
lookupDeprecated Directives VALID
dirs of
  Just Directive VALID
deprecation -> ReaderT Env Eventless () -> Converter ()
forall a. ReaderT Env Eventless a -> Converter a
Converter (ReaderT Env Eventless () -> Converter ())
-> ReaderT Env Eventless () -> Converter ()
forall a b. (a -> b) -> a -> b
$ Result () () -> ReaderT Env Eventless ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result () () -> ReaderT Env Eventless ())
-> Result () () -> ReaderT Env Eventless ()
forall a b. (a -> b) -> a -> b
$ Success :: forall events a. a -> GQLErrors -> [events] -> Result events a
Success {result :: ()
result = (), GQLErrors
warnings :: GQLErrors
warnings :: GQLErrors
warnings, events :: [()]
events = []}
    where
      warnings :: GQLErrors
warnings =
        FieldName -> Ref FieldName -> Maybe Description -> GQLErrors
deprecatedField
          FieldName
typename
          Ref FieldName
ref
          (Directive VALID -> Maybe Description
forall (s :: Stage). Directive s -> Maybe Description
lookupDeprecatedReason Directive VALID
deprecation)
  Maybe (Directive VALID)
Nothing -> () -> Converter ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()