{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Types.GQLWrapper
( EncodeWrapper (..),
DecodeWrapper (..),
DecodeWrapperConstraint,
EncodeWrapperValue (..),
)
where
import qualified Data.List.NonEmpty as NonEmpty
import Data.Morpheus.App.Internal.Resolving
( ResolverValue,
SubscriptionField (..),
mkList,
mkNull,
)
import Data.Morpheus.Types.Internal.AST
( CONST,
GQLError,
ValidValue,
Value (..),
msg,
)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Relude
class EncodeWrapper (wrapper :: Type -> Type) where
encodeWrapper ::
(Monad m) =>
(a -> m (ResolverValue m)) ->
wrapper a ->
m (ResolverValue m)
withList ::
( EncodeWrapper f,
Monad m
) =>
(a -> f b) ->
(b -> m (ResolverValue m)) ->
a ->
m (ResolverValue m)
withList :: forall (f :: * -> *) (m :: * -> *) a b.
(EncodeWrapper f, Monad m) =>
(a -> f b)
-> (b -> m (ResolverValue m)) -> a -> m (ResolverValue m)
withList a -> f b
f b -> m (ResolverValue m)
encodeValue = forall (wrapper :: * -> *) (m :: * -> *) a.
(EncodeWrapper wrapper, Monad m) =>
(a -> m (ResolverValue m)) -> wrapper a -> m (ResolverValue m)
encodeWrapper b -> m (ResolverValue m)
encodeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f
instance EncodeWrapper Maybe where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> Maybe a -> m (ResolverValue m)
encodeWrapper = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull)
instance EncodeWrapper [] where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> [a] -> m (ResolverValue m)
encodeWrapper a -> m (ResolverValue m)
encodeValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList 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 a -> m (ResolverValue m)
encodeValue
instance EncodeWrapper NonEmpty where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> NonEmpty a -> m (ResolverValue m)
encodeWrapper = forall (f :: * -> *) (m :: * -> *) a b.
(EncodeWrapper f, Monad m) =>
(a -> f b)
-> (b -> m (ResolverValue m)) -> a -> m (ResolverValue m)
withList forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance EncodeWrapper Seq where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> Seq a -> m (ResolverValue m)
encodeWrapper = forall (f :: * -> *) (m :: * -> *) a b.
(EncodeWrapper f, Monad m) =>
(a -> f b)
-> (b -> m (ResolverValue m)) -> a -> m (ResolverValue m)
withList forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance EncodeWrapper Vector where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> Vector a -> m (ResolverValue m)
encodeWrapper = forall (f :: * -> *) (m :: * -> *) a b.
(EncodeWrapper f, Monad m) =>
(a -> f b)
-> (b -> m (ResolverValue m)) -> a -> m (ResolverValue m)
withList forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance EncodeWrapper Set where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m)) -> Set a -> m (ResolverValue m)
encodeWrapper = forall (f :: * -> *) (m :: * -> *) a b.
(EncodeWrapper f, Monad m) =>
(a -> f b)
-> (b -> m (ResolverValue m)) -> a -> m (ResolverValue m)
withList forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance EncodeWrapper SubscriptionField where
encodeWrapper :: forall (m :: * -> *) a.
Monad m =>
(a -> m (ResolverValue m))
-> SubscriptionField a -> m (ResolverValue m)
encodeWrapper a -> m (ResolverValue m)
encode (SubscriptionField forall e (m :: * -> *) v.
(a ~ Resolver SUBSCRIPTION e m v) =>
Channel e
_ a
res) = a -> m (ResolverValue m)
encode a
res
type family DecodeWrapperConstraint (f :: Type -> Type) a :: Constraint where
DecodeWrapperConstraint Set a = (Ord a)
DecodeWrapperConstraint f a = ()
class DecodeWrapper (f :: Type -> Type) where
decodeWrapper ::
(Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) ->
ValidValue ->
ExceptT GQLError m (f a)
instance DecodeWrapper Maybe where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint Maybe a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (Maybe a)
decodeWrapper ValidValue -> m a
_ ValidValue
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
decodeWrapper ValidValue -> m a
decode ValidValue
x = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidValue -> m a
decode ValidValue
x)
instance DecodeWrapper [] where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint [] a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m [a]
decodeWrapper ValidValue -> m a
decode (List [ValidValue]
li) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValidValue -> m a
decode [ValidValue]
li
decodeWrapper ValidValue -> m a
_ ValidValue
isType = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"List" ValidValue
isType)
instance DecodeWrapper NonEmpty where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint NonEmpty a) =>
(ValidValue -> m a)
-> ValidValue -> ExceptT GQLError m (NonEmpty a)
decodeWrapper = forall (m :: * -> *) a (rList :: * -> *).
Monad m =>
([a] -> Either GQLError (rList a))
-> (ValidValue -> m a)
-> ValidValue
-> ExceptT GQLError m (rList a)
withRefinedList (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left GQLError
"Expected a NonEmpty list") forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty)
instance DecodeWrapper Seq where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint Seq a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (Seq a)
decodeWrapper ValidValue -> m a
decode = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Seq a
Seq.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
(DecodeWrapper f, Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (f a)
decodeWrapper ValidValue -> m a
decode
instance DecodeWrapper Vector where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint Vector a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (Vector a)
decodeWrapper ValidValue -> m a
decode = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
(DecodeWrapper f, Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (f a)
decodeWrapper ValidValue -> m a
decode
instance DecodeWrapper Set where
decodeWrapper :: forall (m :: * -> *) a.
(Monad m, DecodeWrapperConstraint Set a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (Set a)
decodeWrapper ValidValue -> m a
decode ValidValue
value = do
[a]
listVal <- forall (f :: * -> *) (m :: * -> *) a.
(DecodeWrapper f, Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (f a)
decodeWrapper ValidValue -> m a
decode ValidValue
value
forall (l :: * -> *) (m :: * -> *) a b.
(Foldable l, Monad m) =>
Set a -> l b -> ExceptT GQLError m (Set a)
haveSameSize (forall a. Ord a => [a] -> Set a
Set.fromList [a]
listVal) [a]
listVal
haveSameSize ::
( Foldable l,
Monad m
) =>
Set a ->
l b ->
ExceptT GQLError m (Set a)
haveSameSize :: forall (l :: * -> *) (m :: * -> *) a b.
(Foldable l, Monad m) =>
Set a -> l b -> ExceptT GQLError m (Set a)
haveSameSize Set a
setVal l b
listVal
| forall (t :: * -> *) a. Foldable t => t a -> Int
length Set a
setVal forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length l b
listVal = forall (f :: * -> *) a. Applicative f => a -> f a
pure Set a
setVal
| Bool
otherwise = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. IsString a => String -> a
fromString (String
"Expected a List without duplicates, found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length l b
listVal forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length Set a
setVal) forall a. Semigroup a => a -> a -> a
<> String
" duplicates"))
withRefinedList ::
Monad m =>
([a] -> Either GQLError (rList a)) ->
(ValidValue -> m a) ->
ValidValue ->
ExceptT GQLError m (rList a)
withRefinedList :: forall (m :: * -> *) a (rList :: * -> *).
Monad m =>
([a] -> Either GQLError (rList a))
-> (ValidValue -> m a)
-> ValidValue
-> ExceptT GQLError m (rList a)
withRefinedList [a] -> Either GQLError (rList a)
refiner ValidValue -> m a
decode (List [ValidValue]
li) = do
[a]
listRes <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValidValue -> m a
decode [ValidValue]
li)
case [a] -> Either GQLError (rList a)
refiner [a]
listRes of
Left GQLError
err -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
err (forall (stage :: Stage). [Value stage] -> Value stage
List [ValidValue]
li))
Right rList a
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure rList a
value
withRefinedList [a] -> Either GQLError (rList a)
_ ValidValue -> m a
_ ValidValue
isType = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"List" ValidValue
isType)
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch :: forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
text Value s
jsType =
GQLError
"Type mismatch! expected:"
forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg GQLError
text
forall a. Semigroup a => a -> a -> a
<> GQLError
", got: "
forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Value s
jsType
class EncodeWrapperValue (f :: Type -> Type) where
encodeWrapperValue :: (Monad m) => (a -> m (Value CONST)) -> f a -> m (Value CONST)
instance EncodeWrapperValue Maybe where
encodeWrapperValue :: forall (m :: * -> *) a.
Monad m =>
(a -> m (Value CONST)) -> Maybe a -> m (Value CONST)
encodeWrapperValue = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null)