{-# 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 Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.Client.Internal.Types
  ( ClientTypeDefinition (..),
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( camelCaseTypeName,
  )
import Data.Morpheus.Error
  ( deprecatedField,
  )
import Data.Morpheus.Internal.Ext
  ( GQLResult,
    Result (..),
  )
import Data.Morpheus.Internal.Utils
  ( selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    Directives,
    FieldName,
    GQLError,
    RAW,
    Ref (..),
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    VALID,
    VariableDefinitions,
    internal,
    isNotSystemTypeName,
    lookupDeprecated,
    lookupDeprecatedReason,
    msg,
    typeDefinitions,
  )
import Relude

type Env = (Schema VALID, VariableDefinitions RAW)

newtype Converter a = Converter
  { Converter a -> ReaderT Env GQLResult a
runConverter ::
      ReaderT
        Env
        GQLResult
        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,
      MonadError GQLError
    )

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 :: GQLError -> GQLError
compileError :: GQLError -> GQLError
compileError GQLError
x = GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Unhandled Compile Time Error: \"" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
x GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\" ;"

getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType :: TypeName -> Converter (TypeDefinition ANY VALID)
getType TypeName
typename =
  (Env -> HashMap TypeName (TypeDefinition ANY VALID))
-> Converter (HashMap TypeName (TypeDefinition ANY VALID))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID)
forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions (Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID))
-> (Env -> Schema VALID)
-> Env
-> HashMap TypeName (TypeDefinition ANY VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Schema VALID
forall a b. (a, b) -> a
fst)
    Converter (HashMap TypeName (TypeDefinition ANY VALID))
-> (HashMap TypeName (TypeDefinition ANY VALID)
    -> Converter (TypeDefinition ANY VALID))
-> Converter (TypeDefinition ANY VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GQLError
-> TypeName
-> HashMap TypeName (TypeDefinition ANY VALID)
-> Converter (TypeDefinition ANY VALID)
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (GQLError -> GQLError
compileError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
" can't find Type" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
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
_ = GQLError -> Converter ([ClientTypeDefinition], [TypeName])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Converter ([ClientTypeDefinition], [TypeName]))
-> GQLError -> Converter ([ClientTypeDefinition], [TypeName])
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
compileError GQLError
"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 DataObject {} = [FieldName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
path TypeName
typeName
    __typeFrom DataInterface {} = [FieldName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
path TypeName
typeName
    __typeFrom DataUnion {} = [FieldName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [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). Directives s -> Maybe (Directive s)
lookupDeprecated Directives VALID
dirs of
  Just Directive VALID
deprecation -> ReaderT Env GQLResult () -> Converter ()
forall a. ReaderT Env GQLResult a -> Converter a
Converter (ReaderT Env GQLResult () -> Converter ())
-> ReaderT Env GQLResult () -> Converter ()
forall a b. (a -> b) -> a -> b
$ Result GQLError () -> ReaderT Env GQLResult ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result GQLError () -> ReaderT Env GQLResult ())
-> Result GQLError () -> ReaderT Env GQLResult ()
forall a b. (a -> b) -> a -> b
$ Success :: forall err a. a -> [err] -> Result err a
Success {result :: ()
result = (), [GQLError]
warnings :: [GQLError]
warnings :: [GQLError]
warnings}
    where
      warnings :: [GQLError]
warnings =
        [ FieldName -> Ref FieldName -> Maybe Description -> GQLError
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 ()