{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema.Directive
  ( deriveFieldDirectives,
    deriveTypeDirectives,
    deriveEnumDirectives,
  )
where

import Control.Monad.Except (throwError)
import qualified Data.HashMap.Lazy as HM
import qualified Data.Map as M
import Data.Morpheus.CodeGen.Internal.AST (CONST, TypeName)
import Data.Morpheus.Internal.Ext (resultOr, unsafeFromList)
import Data.Morpheus.Internal.Utils (Empty (..), (<:>))
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( KindedProxy (..),
  )
import Data.Morpheus.Server.Types.Directives
  ( GQLDirective (..),
    ToLocations,
    getLocations,
  )
import Data.Morpheus.Server.Types.GQLType
  ( DeriveArguments (..),
    DirectiveUsage (..),
    DirectiveUsages (..),
    GQLType (..),
    deriveFingerprint,
    deriveTypename,
    encodeArguments,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertDirectiveDefinition,
    outToAny,
  )
import Data.Morpheus.Types.Internal.AST
  ( Directive (..),
    DirectiveDefinition (..),
    Directives,
    FieldName,
    IN,
    Position (Position),
    unpackName,
  )
import GHC.Generics ()
import GHC.TypeLits ()
import Relude hiding (empty)

type DirectiveDefinitionConstraint a =
  ( GQLDirective a,
    GQLType a,
    DeriveArguments (KIND a) a,
    ToLocations (DIRECTIVE_LOCATIONS a)
  )

deriveDirectiveDefinition ::
  forall a b kind.
  (DirectiveDefinitionConstraint a) =>
  a ->
  b ->
  SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition :: forall a b (kind :: TypeCategory).
DirectiveDefinitionConstraint a =>
a -> b -> SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition a
_ b
_ = do
  ArgumentsDefinition CONST
directiveDefinitionArgs <- forall a (k' :: TypeCategory). SchemaT OUT a -> SchemaT k' a
outToAny (forall (k :: DerivingKind) a (f :: DerivingKind -> * -> *).
DeriveArguments k a =>
f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArgumentsDefinition (forall {k} {k1} (k2 :: k) (a :: k1). KindedProxy k2 a
KindedProxy :: KindedProxy (KIND a) a))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( DirectiveDefinition
        { directiveDefinitionName :: FieldName
directiveDefinitionName = forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName Proxy a
proxy,
          directiveDefinitionDescription :: Maybe Description
directiveDefinitionDescription = forall a (f :: * -> *). GQLType a => f a -> Maybe Description
description Proxy a
proxy,
          ArgumentsDefinition CONST
directiveDefinitionArgs :: ArgumentsDefinition CONST
directiveDefinitionArgs :: ArgumentsDefinition CONST
directiveDefinitionArgs,
          directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionLocations = forall (f :: * -> *) a.
ToLocations (DIRECTIVE_LOCATIONS a) =>
f a -> [DirectiveLocation]
getLocations Proxy a
proxy
        }
    )
  where
    proxy :: Proxy a
proxy = forall {k} (t :: k). Proxy t
Proxy @a

deriveTypeDirectives :: forall c f a. GQLType a => f a -> SchemaT c (Directives CONST)
deriveTypeDirectives :: forall (c :: TypeCategory) (f :: * -> *) a.
GQLType a =>
f a -> SchemaT c (Directives CONST)
deriveTypeDirectives f a
proxy = forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages (DirectiveUsages -> [DirectiveUsage]
typeDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy)

deriveDirectiveUsages :: [DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages :: forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (c :: TypeCategory).
DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple

deriveDirectiveName :: forall f a. GQLType a => f a -> FieldName
deriveDirectiveName :: forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName f a
_ = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k1} (k2 :: k) (a :: k1). KindedProxy k2 a
KindedProxy :: KindedProxy IN a)

toDirectiveTuple :: DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple :: forall (c :: TypeCategory).
DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple (DirectiveUsage a
x) = do
  forall a (c :: TypeCategory).
GQLType a =>
(KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST))
-> a -> SchemaT c ()
insertDirective (forall a b (kind :: TypeCategory).
DirectiveDefinitionConstraint a =>
a -> b -> SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition a
x) a
x
  let directiveName :: FieldName
directiveName = forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName (forall a. a -> Identity a
Identity a
x)
  Arguments CONST
directiveArgs <- forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"TODO: fix me") forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Decode a => a -> GQLResult (Arguments CONST)
encodeArguments a
x)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( FieldName
directiveName,
      Directive
        { directivePosition :: Position
directivePosition = Int -> Int -> Position
Position Int
0 Int
0,
          FieldName
directiveName :: FieldName
directiveName :: FieldName
directiveName,
          Arguments CONST
directiveArgs :: Arguments CONST
directiveArgs :: Arguments CONST
directiveArgs
        }
    )

insertDirective ::
  forall a c.
  (GQLType a) =>
  (KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)) ->
  a ->
  SchemaT c ()
insertDirective :: forall a (c :: TypeCategory).
GQLType a =>
(KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST))
-> a -> SchemaT c ()
insertDirective KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)
f a
_ = forall a (cat' :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (DirectiveDefinition CONST))
-> a
-> SchemaT cat' ()
insertDirectiveDefinition (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeFingerprint
deriveFingerprint KindedProxy IN a
proxy) KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)
f KindedProxy IN a
proxy
  where
    proxy :: KindedProxy IN a
proxy = forall {k} {k1} (k2 :: k) (a :: k1). KindedProxy k2 a
KindedProxy :: KindedProxy IN a

getDir :: (Ord k, Empty a) => k -> Map k a -> a
getDir :: forall k a. (Ord k, Empty a) => k -> Map k a -> a
getDir k
name Map k a
xs = forall a. a -> Maybe a -> a
fromMaybe forall coll. Empty coll => coll
empty forall a b. (a -> b) -> a -> b
$ k
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map k a
xs

getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM :: forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM k
name HashMap k a
xs = forall a. a -> Maybe a -> a
fromMaybe forall coll. Empty coll => coll
empty forall a b. (a -> b) -> a -> b
$ k
name forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap k a
xs

deriveFieldDirectives :: GQLType a => f a -> FieldName -> SchemaT c (Directives CONST)
deriveFieldDirectives :: forall a (f :: * -> *) (c :: TypeCategory).
GQLType a =>
f a -> FieldName -> SchemaT c (Directives CONST)
deriveFieldDirectives f a
proxy FieldName
name = do
  Directives CONST
dirs <- forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages forall a b. (a -> b) -> a -> b
$ forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM FieldName
name forall a b. (a -> b) -> a -> b
$ DirectiveUsages -> HashMap FieldName [DirectiveUsage]
fieldDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy
  forall k a. (Ord k, Empty a) => k -> Map k a -> a
getDir (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
name) (forall a (f :: * -> *).
GQLType a =>
f a -> Map Description (Directives CONST)
getDirectives f a
proxy) forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> Directives CONST
dirs

deriveEnumDirectives :: GQLType a => f a -> TypeName -> SchemaT c (Directives CONST)
deriveEnumDirectives :: forall a (f :: * -> *) (c :: TypeCategory).
GQLType a =>
f a -> TypeName -> SchemaT c (Directives CONST)
deriveEnumDirectives f a
proxy TypeName
name = do
  Directives CONST
dirs <- forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages forall a b. (a -> b) -> a -> b
$ forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM TypeName
name forall a b. (a -> b) -> a -> b
$ DirectiveUsages -> HashMap TypeName [DirectiveUsage]
enumValueDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy
  forall k a. (Ord k, Empty a) => k -> Map k a -> a
getDir (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name) (forall a (f :: * -> *).
GQLType a =>
f a -> Map Description (Directives CONST)
getDirectives f a
proxy) forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> Directives CONST
dirs