content: {-# 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
  
  -- | GraphQL Wrapper Serializer
  class EncodeWrapper (wrapper :: Type -> Type) where
    encodeWrapper ::
      (Monad m) =>
      (a -> m (ResolverValue m)) ->
      wrapper a ->
      m (ResolverValue m)
  
  withList :: (Monad m, Foldable f) => (a -> m (ResolverValue m)) -> f a -> m (ResolverValue m)
  withList encodeValue = encodeWrapper encodeValue . toList
  
  instance EncodeWrapper Maybe where
    encodeWrapper = maybe (pure mkNull)
  
  instance EncodeWrapper [] where
    encodeWrapper encodeValue = fmap mkList . traverse encodeValue
  
  instance EncodeWrapper NonEmpty where
    encodeWrapper = withList
  
  instance EncodeWrapper Seq where
    encodeWrapper = withList
  
  instance EncodeWrapper Vector where
    encodeWrapper = withList
  
  instance EncodeWrapper Set where
    encodeWrapper = withList
  
  instance EncodeWrapper SubscriptionField where
    encodeWrapper encode (SubscriptionField _ res) = encode res
  
  type family DecodeWrapperConstraint (f :: Type -> Type) a :: Constraint where
    DecodeWrapperConstraint Set a = (Ord a)
    DecodeWrapperConstraint f a = ()
  
  -- | GraphQL Wrapper Deserializer
  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 _ Null = pure Nothing
    decodeWrapper decode x = Just <$> lift (decode x)
  
  instance DecodeWrapper [] where
    decodeWrapper decode (List li) = lift $ traverse decode li
    decodeWrapper _ isType = ExceptT $ pure $ Left (typeMismatch "List" isType)
  
  instance DecodeWrapper NonEmpty where
    decodeWrapper = withRefinedList (maybe (Left "Expected a NonEmpty list") Right . NonEmpty.nonEmpty)
  
  instance DecodeWrapper Seq where
    decodeWrapper decode = fmap Seq.fromList . decodeWrapper decode
  
  instance DecodeWrapper Vector where
    decodeWrapper decode = fmap Vector.fromList . decodeWrapper decode
  
  instance DecodeWrapper Set where
    decodeWrapper decode value = do
      listVal <- decodeWrapper decode value
      haveSameSize (Set.fromList listVal) listVal
  
  haveSameSize ::
    ( Foldable l,
      Monad m
    ) =>
    Set a ->
    l b ->
    ExceptT GQLError m (Set a)
  haveSameSize setVal listVal
    | length setVal == length listVal = pure setVal
    | otherwise = ExceptT $ pure $ Left (fromString ("Expected a List without duplicates, found " <> show (length listVal - length setVal) <> " duplicates"))
  
  withRefinedList ::
    (Monad m) =>
    ([a] -> Either GQLError (rList a)) ->
    (ValidValue -> m a) ->
    ValidValue ->
    ExceptT GQLError m (rList a)
  withRefinedList refiner decode (List li) = do
    listRes <- lift (traverse decode li)
    case refiner listRes of
      Left err -> ExceptT $ pure $ Left (typeMismatch err (List li))
      Right value -> pure value
  withRefinedList _ _ isType = ExceptT $ pure $ Left (typeMismatch "List" isType)
  
  -- if value is already validated but value has different type
  typeMismatch :: GQLError -> Value s -> GQLError
  typeMismatch text jsType =
    "Type mismatch! expected:"
      <> msg text
      <> ", got: "
      <> msg jsType
  
  class EncodeWrapperValue (f :: Type -> Type) where
    encodeWrapperValue :: (Monad m) => (a -> m (Value CONST)) -> f a -> m (Value CONST)
  
  instance EncodeWrapperValue Maybe where
    encodeWrapperValue = maybe (pure Null)
  
  instance EncodeWrapperValue [] where
    encodeWrapperValue f xs = List <$> traverse f xs
  
  instance EncodeWrapperValue Set where
    encodeWrapperValue f = encodeWrapperValue f . toList
  
  instance EncodeWrapperValue NonEmpty where
    encodeWrapperValue f = encodeWrapperValue f . toList
  
  instance EncodeWrapperValue Seq where
    encodeWrapperValue f = encodeWrapperValue f . toList
  
  instance EncodeWrapperValue Vector where
    encodeWrapperValue f = encodeWrapperValue f . toList
  