{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    GQLTypeOptions (..),
    defaultTypeOptions,
    TypeData (..),
  )
where

-- MORPHEUS
import Data.Map (Map)
import Data.Morpheus.Kind
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    TypeFingerprint (..),
  )
import Data.Morpheus.Server.Types.Types
  ( MapKind,
    Pair,
    Undefined (..),
  )
import Data.Morpheus.Types.ID (ID)
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition,
    CONST,
    Description,
    Directives,
    FieldName,
    QUERY,
    TypeName (..),
    TypeWrapper (..),
    Value,
    toNullable,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Resolver,
    SubscriptionField,
  )
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Text
  ( Text,
    intercalate,
    pack,
  )
import Data.Typeable
  ( TyCon,
    TypeRep,
    Typeable,
    splitTyConApp,
    tyConFingerprint,
    tyConName,
    typeRep,
    typeRepTyCon,
  )
import Prelude
  ( ($),
    (.),
    Bool (..),
    Eq (..),
    Float,
    Int,
    Maybe (..),
    String,
    concatMap,
    fmap,
    id,
    mempty,
  )

data TypeData = TypeData
  { TypeData -> TypeName
gqlTypeName :: TypeName,
    TypeData -> [TypeWrapper]
gqlWrappers :: [TypeWrapper],
    TypeData -> TypeFingerprint
gqlFingerprint :: TypeFingerprint
  }

data GQLTypeOptions = GQLTypeOptions
  { GQLTypeOptions -> String -> String
fieldLabelModifier :: String -> String,
    GQLTypeOptions -> String -> String
constructorTagModifier :: String -> String
  }

defaultTypeOptions :: GQLTypeOptions
defaultTypeOptions :: GQLTypeOptions
defaultTypeOptions =
  GQLTypeOptions :: (String -> String) -> (String -> String) -> GQLTypeOptions
GQLTypeOptions
    { fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
forall a. a -> a
id,
      constructorTagModifier :: String -> String
constructorTagModifier = String -> String
forall a. a -> a
id
    }

getTypename :: Typeable a => f a -> TypeName
getTypename :: f a -> TypeName
getTypename = Text -> TypeName
TypeName (Text -> TypeName) -> (f a -> Text) -> f a -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"_" ([Text] -> Text) -> (f a -> [Text]) -> f a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [Text]
forall (proxy :: * -> *). proxy a -> [Text]
getName
  where
    getName :: proxy a -> [Text]
getName = ([TyCon] -> [Text]) -> (proxy a -> [TyCon]) -> proxy a -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TyCon -> Text) -> [TyCon] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack (String -> Text) -> (TyCon -> String) -> TyCon -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
tyConName)) ((TyCon -> TyCon) -> [TyCon] -> [TyCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> TyCon
replacePairCon ([TyCon] -> [TyCon]) -> (proxy a -> [TyCon]) -> proxy a -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver ((TyCon, [TypeRep]) -> [TyCon])
-> (proxy a -> (TyCon, [TypeRep])) -> proxy a -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp (TypeRep -> (TyCon, [TypeRep]))
-> (proxy a -> TypeRep) -> proxy a -> (TyCon, [TypeRep])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep)

getFingerprint :: Typeable a => f a -> TypeFingerprint
getFingerprint :: f a -> TypeFingerprint
getFingerprint = [Fingerprint] -> TypeFingerprint
TypeableFingerprint ([Fingerprint] -> TypeFingerprint)
-> (f a -> [Fingerprint]) -> f a -> TypeFingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [Fingerprint]
forall (proxy :: * -> *). proxy a -> [Fingerprint]
conFingerprints
  where
    conFingerprints :: proxy a -> [Fingerprint]
conFingerprints = ([TyCon] -> [Fingerprint])
-> (proxy a -> [TyCon]) -> proxy a -> [Fingerprint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TyCon -> Fingerprint) -> [TyCon] -> [Fingerprint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> Fingerprint
tyConFingerprint) ((TyCon, [TypeRep]) -> [TyCon]
ignoreResolver ((TyCon, [TypeRep]) -> [TyCon])
-> (proxy a -> (TyCon, [TypeRep])) -> proxy a -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp (TypeRep -> (TyCon, [TypeRep]))
-> (proxy a -> TypeRep) -> proxy a -> (TyCon, [TypeRep])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep)

deriveTypeData :: Typeable a => f a -> TypeData
deriveTypeData :: f a -> TypeData
deriveTypeData f a
proxy =
  TypeData :: TypeName -> [TypeWrapper] -> TypeFingerprint -> TypeData
TypeData
    { gqlTypeName :: TypeName
gqlTypeName = f a -> TypeName
forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename f a
proxy,
      gqlWrappers :: [TypeWrapper]
gqlWrappers = [],
      gqlFingerprint :: TypeFingerprint
gqlFingerprint = f a -> TypeFingerprint
forall a (f :: * -> *). Typeable a => f a -> TypeFingerprint
getFingerprint f a
proxy
    }

mkTypeData :: TypeName -> TypeData
mkTypeData :: TypeName -> TypeData
mkTypeData TypeName
name =
  TypeData :: TypeName -> [TypeWrapper] -> TypeFingerprint -> TypeData
TypeData
    { gqlTypeName :: TypeName
gqlTypeName = TypeName
name,
      gqlFingerprint :: TypeFingerprint
gqlFingerprint = TypeName -> TypeFingerprint
InternalFingerprint TypeName
name,
      gqlWrappers :: [TypeWrapper]
gqlWrappers = []
    }

list :: [TypeWrapper] -> [TypeWrapper]
list :: [TypeWrapper] -> [TypeWrapper]
list = (TypeWrapper
TypeList TypeWrapper -> [TypeWrapper] -> [TypeWrapper]
forall a. a -> [a] -> [a]
:)

wrapper :: ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData
wrapper :: ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData
wrapper [TypeWrapper] -> [TypeWrapper]
f TypeData {[TypeWrapper]
TypeName
TypeFingerprint
gqlFingerprint :: TypeFingerprint
gqlWrappers :: [TypeWrapper]
gqlTypeName :: TypeName
gqlFingerprint :: TypeData -> TypeFingerprint
gqlWrappers :: TypeData -> [TypeWrapper]
gqlTypeName :: TypeData -> TypeName
..} = TypeData :: TypeName -> [TypeWrapper] -> TypeFingerprint -> TypeData
TypeData {gqlWrappers :: [TypeWrapper]
gqlWrappers = [TypeWrapper] -> [TypeWrapper]
f [TypeWrapper]
gqlWrappers, TypeName
TypeFingerprint
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
..}

resolverCon :: TyCon
resolverCon :: TyCon
resolverCon = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy (Resolver QUERY () Maybe) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Resolver QUERY () Maybe) -> TypeRep)
-> Proxy (Resolver QUERY () Maybe) -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy (Resolver QUERY () Maybe)
forall k (t :: k). Proxy t
Proxy @(Resolver QUERY () Maybe)

-- | replaces typeName (A,B) with Pair_A_B
replacePairCon :: TyCon -> TyCon
replacePairCon :: TyCon -> TyCon
replacePairCon TyCon
x | TyCon
hsPair TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
x = TyCon
gqlPair
  where
    hsPair :: TyCon
hsPair = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy (Int, Int) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Int, Int) -> TypeRep) -> Proxy (Int, Int) -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy (Int, Int)
forall k (t :: k). Proxy t
Proxy @(Int, Int)
    gqlPair :: TyCon
gqlPair = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy (Pair Int Int) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Pair Int Int) -> TypeRep)
-> Proxy (Pair Int Int) -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy (Pair Int Int)
forall k (t :: k). Proxy t
Proxy @(Pair Int Int)
replacePairCon TyCon
x = TyCon
x

-- Ignores Resolver name  from typeName
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
resolverCon = []
ignoreResolver (TyCon
con, [TypeRep]
args) =
  TyCon
con TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: (TypeRep -> [TyCon]) -> [TypeRep] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((TyCon, [TypeRep]) -> [TyCon]
ignoreResolver ((TyCon, [TypeRep]) -> [TyCon])
-> (TypeRep -> (TyCon, [TypeRep])) -> TypeRep -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp) [TypeRep]
args

-- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.
--
--  @
--    ... deriving (Generic, GQLType)
--  @
--
-- if you want to add description
--
--  @
--       ... deriving (Generic)
--
--     instance GQLType ... where
--       description = const "your description ..."
--  @
class ToValue (KIND a) => GQLType a where
  type KIND a :: GQL_KIND
  type KIND a = OUTPUT

  implements :: f a -> [SchemaT TypeName]
  implements f a
_ = []

  isObjectKind :: f a -> Bool
  isObjectKind f a
_ = GQL_KIND -> Bool
isObject (GQL_KIND -> Bool) -> GQL_KIND -> Bool
forall a b. (a -> b) -> a -> b
$ Proxy (KIND a) -> GQL_KIND
forall (a :: GQL_KIND) (f :: GQL_KIND -> *).
ToValue a =>
f a -> GQL_KIND
toValue (Proxy (KIND a)
forall k (t :: k). Proxy t
Proxy @(KIND a))

  description :: f a -> Maybe Text
  description f a
_ = Maybe Text
forall a. Maybe a
Nothing

  getDescriptions :: f a -> Map Text Description
  getDescriptions f a
_ = Map Text Text
forall a. Monoid a => a
mempty

  typeOptions :: f a -> GQLTypeOptions
  typeOptions f a
_ = GQLTypeOptions
defaultTypeOptions

  getDirectives :: f a -> Map Text (Directives CONST)
  getDirectives f a
_ = Map Text (Directives CONST)
forall a. Monoid a => a
mempty

  getFieldContents ::
    f a ->
    Map
      FieldName
      ( Maybe (Value CONST),
        Maybe (ArgumentsDefinition CONST)
      )
  getFieldContents f a
_ = Map
  FieldName (Maybe (Value CONST), Maybe (ArgumentsDefinition CONST))
forall a. Monoid a => a
mempty

  isEmptyType :: f a -> Bool
  isEmptyType f a
_ = Bool
False

  __type :: f a -> TypeData
  default __type :: Typeable a => f a -> TypeData
  __type f a
_ = Proxy a -> TypeData
forall a (f :: * -> *). Typeable a => f a -> TypeData
deriveTypeData (Proxy a
forall k (t :: k). Proxy t
Proxy @a)

instance GQLType Int where
  type KIND Int = SCALAR
  __type :: f Int -> TypeData
__type f Int
_ = TypeName -> TypeData
mkTypeData TypeName
"Int"

instance GQLType Float where
  type KIND Float = SCALAR
  __type :: f Float -> TypeData
__type f Float
_ = TypeName -> TypeData
mkTypeData TypeName
"Float"

instance GQLType Text where
  type KIND Text = SCALAR
  __type :: f Text -> TypeData
__type f Text
_ = TypeName -> TypeData
mkTypeData TypeName
"String"

instance GQLType Bool where
  type KIND Bool = SCALAR
  __type :: f Bool -> TypeData
__type f Bool
_ = TypeName -> TypeData
mkTypeData TypeName
"Boolean"

instance GQLType ID where
  type KIND ID = SCALAR
  __type :: f ID -> TypeData
__type f ID
_ = TypeName -> TypeData
mkTypeData TypeName
"ID"

-- WRAPPERS
instance GQLType ()

instance Typeable m => GQLType (Undefined m) where
  type KIND (Undefined m) = WRAPPER
  isEmptyType :: f (Undefined m) -> Bool
isEmptyType f (Undefined m)
_ = Bool
True

instance GQLType a => GQLType (Maybe a) where
  type KIND (Maybe a) = WRAPPER
  __type :: f (Maybe a) -> TypeData
__type f (Maybe a)
_ = ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData
wrapper [TypeWrapper] -> [TypeWrapper]
forall a. Nullable a => a -> a
toNullable (TypeData -> TypeData) -> TypeData -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a -> TypeData) -> Proxy a -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a

instance GQLType a => GQLType [a] where
  type KIND [a] = WRAPPER
  __type :: f [a] -> TypeData
__type f [a]
_ = ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData
wrapper [TypeWrapper] -> [TypeWrapper]
list (TypeData -> TypeData) -> TypeData -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a -> TypeData) -> Proxy a -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a

instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where
  type KIND (a, b) = WRAPPER
  __type :: f (a, b) -> TypeData
__type f (a, b)
_ = Proxy (Pair a b) -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy (Pair a b) -> TypeData) -> Proxy (Pair a b) -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy (Pair a b)
forall k (t :: k). Proxy t
Proxy @(Pair a b)

instance GQLType a => GQLType (Set a) where
  type KIND (Set a) = WRAPPER
  __type :: f (Set a) -> TypeData
__type f (Set a)
_ = Proxy [a] -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy [a] -> TypeData) -> Proxy [a] -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy [a]
forall k (t :: k). Proxy t
Proxy @[a]

instance (Typeable k, Typeable v) => GQLType (Map k v) where
  type KIND (Map k v) = WRAPPER

instance GQLType a => GQLType (Resolver o e m a) where
  type KIND (Resolver o e m a) = WRAPPER
  __type :: f (Resolver o e m a) -> TypeData
__type f (Resolver o e m a)
_ = Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a -> TypeData) -> Proxy a -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a

instance GQLType a => GQLType (SubscriptionField a) where
  type KIND (SubscriptionField a) = WRAPPER
  __type :: f (SubscriptionField a) -> TypeData
__type f (SubscriptionField a)
_ = Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a -> TypeData) -> Proxy a -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a

instance GQLType b => GQLType (a -> b) where
  type KIND (a -> b) = WRAPPER
  __type :: f (a -> b) -> TypeData
__type f (a -> b)
_ = Proxy b -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy b -> TypeData) -> Proxy b -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy b
forall k (t :: k). Proxy t
Proxy @b

instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b)

instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where
  __type :: f (MapKind a b m) -> TypeData
__type f (MapKind a b m)
_ = Proxy (Map a b) -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy (Map a b) -> TypeData) -> Proxy (Map a b) -> TypeData
forall a b. (a -> b) -> a -> b
$ Proxy (Map a b)
forall k (t :: k). Proxy t
Proxy @(Map a b)