{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.NamedResolvers
  ( ResolveNamed (..),
    NamedResolverT (..),
    resolve,
    useBatched,
  )
where

import Control.Monad.Except
import Data.Aeson (ToJSON)
import Data.Morpheus.Types.ID (ID)
import Data.Morpheus.Types.Internal.AST (GQLError, internal)
import Relude

instance (Monad m) => ResolveNamed m ID where
  type Dep ID = ID
  resolveNamed :: Monad m => Dep ID -> m ID
resolveNamed = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Monad m => ResolveNamed m Text where
  type Dep Text = Text
  resolveNamed :: Monad m => Dep Text -> m Text
resolveNamed = forall (f :: * -> *) a. Applicative f => a -> f a
pure

useBatched :: (ResolveNamed m a, MonadError GQLError m) => Dep a -> m a
useBatched :: forall (m :: * -> *) a.
(ResolveNamed m a, MonadError GQLError m) =>
Dep a -> m a
useBatched Dep a
x = forall (m :: * -> *) a.
(ResolveNamed m a, Monad m) =>
[Dep a] -> m [Maybe a]
resolveBatched [Dep a
x] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {f :: * -> *} {a}. MonadError GQLError f => [Maybe a] -> f a
res
  where
    res :: [Maybe a] -> f a
res [Just a
v] = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
    res [Maybe a]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"named resolver should return single value for single argument")

class (ToJSON (Dep a)) => ResolveNamed (m :: Type -> Type) (a :: Type) where
  type Dep a :: Type
  resolveBatched :: Monad m => [Dep a] -> m [Maybe a]
  resolveBatched = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (ResolveNamed m a, Monad m) => Dep a -> m a
resolveNamed)

  resolveNamed :: Monad m => Dep a -> m a

instance (ResolveNamed m a, MonadError GQLError m) => ResolveNamed (m :: Type -> Type) [a] where
  type Dep [a] = [Dep a]
  resolveNamed :: Monad m => Dep [a] -> m [a]
resolveNamed Dep [a]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"named resolver instance [a] should not be called")

instance (ResolveNamed m a, MonadError GQLError m) => ResolveNamed (m :: Type -> Type) (Maybe a) where
  type Dep (Maybe a) = Maybe (Dep a)
  resolveNamed :: Monad m => Dep (Maybe a) -> m (Maybe a)
resolveNamed Dep (Maybe a)
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"named resolver instance Maybe should not be called")

data NamedResolverT (m :: Type -> Type) a where
  Ref :: ResolveNamed m a => m (Dep a) -> NamedResolverT m a
  Refs :: ResolveNamed m a => m [Dep a] -> NamedResolverT m [a]
  Value :: m a -> NamedResolverT m a

-- RESOLVER TYPES
data RES = VALUE | LIST | REF

type family RES_TYPE a b :: RES where
  RES_TYPE a a = 'VALUE
  RES_TYPE [a] [b] = 'LIST
  RES_TYPE a b = 'REF

resolve :: forall m a b. (ResolveByType (RES_TYPE a b) m a b) => Monad m => m a -> NamedResolverT m b
resolve :: forall (m :: * -> *) a b.
(ResolveByType (RES_TYPE a b) m a b, Monad m) =>
m a -> NamedResolverT m b
resolve = forall (k :: RES) (m :: * -> *) a b (f :: RES -> *).
(ResolveByType k m a b, Monad m) =>
f k -> m a -> NamedResolverT m b
resolveByType (forall {k} (t :: k). Proxy t
Proxy :: Proxy (RES_TYPE a b))

class Dep b ~ a => ResolveByType (k :: RES) m a b where
  resolveByType :: Monad m => f k -> m a -> NamedResolverT m b

instance (ResolveNamed m a, Dep a ~ a) => ResolveByType 'VALUE m a a where
  resolveByType :: forall (f :: RES -> *).
Monad m =>
f 'VALUE -> m a -> NamedResolverT m a
resolveByType f 'VALUE
_ = forall (m :: * -> *) a. m a -> NamedResolverT m a
Value

instance (ResolveNamed m b, Dep b ~ a) => ResolveByType 'LIST m [a] [b] where
  resolveByType :: forall (f :: RES -> *).
Monad m =>
f 'LIST -> m [a] -> NamedResolverT m [b]
resolveByType f 'LIST
_ = forall (m :: * -> *) a.
ResolveNamed m a =>
m [Dep a] -> NamedResolverT m [a]
Refs

instance (ResolveNamed m b, Dep b ~ a) => ResolveByType 'REF m a b where
  resolveByType :: forall (f :: RES -> *).
Monad m =>
f 'REF -> m a -> NamedResolverT m b
resolveByType f 'REF
_ = forall (m :: * -> *) a.
ResolveNamed m a =>
m (Dep a) -> NamedResolverT m a
Ref