{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
    DecodeScalar (..),
    toScalar,
    scalarToJSON,
    scalarFromJSON,
    scalarValidator,
  )
where

import qualified Data.Aeson as A
import Data.Morpheus.Types.Internal.AST
  ( ScalarDefinition (..),
    ScalarValue (..),
    ValidValue,
    Value (..),
    replaceValue,
  )
import Data.Text (unpack)
import GHC.Float (double2Float, float2Double)
import Relude

toScalar :: ValidValue -> Either Text ScalarValue
toScalar :: ValidValue -> Either Text ScalarValue
toScalar (Scalar ScalarValue
x) = ScalarValue -> Either Text ScalarValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScalarValue
x
toScalar ValidValue
_ = Text -> Either Text ScalarValue
forall a b. a -> Either a b
Left Text
""

scalarValidator :: forall f a. DecodeScalar a => f a -> ScalarDefinition
scalarValidator :: f a -> ScalarDefinition
scalarValidator f a
_ = ScalarDefinition :: (ValidValue -> Either Text ValidValue) -> ScalarDefinition
ScalarDefinition {validateValue :: ValidValue -> Either Text ValidValue
validateValue = ValidValue -> Either Text ValidValue
validator}
  where
    validator :: ValidValue -> Either Text ValidValue
validator ValidValue
value = do
      ScalarValue
scalarValue' <- ValidValue -> Either Text ScalarValue
toScalar ValidValue
value
      (a
_ :: a) <- ScalarValue -> Either Text a
forall a. DecodeScalar a => ScalarValue -> Either Text a
decodeScalar ScalarValue
scalarValue'
      ValidValue -> Either Text ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value

-- | GraphQL Scalar Serializer
class EncodeScalar (a :: Type) where
  encodeScalar :: a -> ScalarValue

-- | GraphQL Scalar parser
class DecodeScalar (a :: Type) where
  -- value parsing and validating
  --
  -- for exhaustive pattern matching  should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'
  --
  -- invalid values can be reported with 'Left' constructor :
  --
  -- @
  --   decodeScalar String _ = Left "" -- without error message
  --   -- or
  --   decodeScalar String _ = Left "Error Message"
  -- @
  decodeScalar :: ScalarValue -> Either Text a

instance DecodeScalar Text where
  decodeScalar :: ScalarValue -> Either Text Text
decodeScalar (String Text
x) = Text -> Either Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
  decodeScalar ScalarValue
_ = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
""

instance EncodeScalar Text where
  encodeScalar :: Text -> ScalarValue
encodeScalar = Text -> ScalarValue
String

instance DecodeScalar Bool where
  decodeScalar :: ScalarValue -> Either Text Bool
decodeScalar (Boolean Bool
x) = Bool -> Either Text Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x
  decodeScalar ScalarValue
_ = Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
""

instance EncodeScalar Bool where
  encodeScalar :: Bool -> ScalarValue
encodeScalar = Bool -> ScalarValue
Boolean

instance DecodeScalar Int where
  decodeScalar :: ScalarValue -> Either Text Int
decodeScalar (Int Int
x) = Int -> Either Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x
  decodeScalar ScalarValue
_ = Text -> Either Text Int
forall a b. a -> Either a b
Left Text
""

instance EncodeScalar Int where
  encodeScalar :: Int -> ScalarValue
encodeScalar = Int -> ScalarValue
Int

instance DecodeScalar Float where
  decodeScalar :: ScalarValue -> Either Text Float
decodeScalar (Float Double
x) = Float -> Either Text Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Float
double2Float Double
x)
  decodeScalar (Int Int
x) = Float -> Either Text Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Either Text Float) -> Float -> Either Text Float
forall a b. (a -> b) -> a -> b
$ Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Integer -> Float) -> Integer -> Float
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
x
  decodeScalar ScalarValue
_ = Text -> Either Text Float
forall a b. a -> Either a b
Left Text
""

instance EncodeScalar Float where
  encodeScalar :: Float -> ScalarValue
encodeScalar = Double -> ScalarValue
Float (Double -> ScalarValue)
-> (Float -> Double) -> Float -> ScalarValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
float2Double

instance DecodeScalar Double where
  decodeScalar :: ScalarValue -> Either Text Double
decodeScalar (Float Double
x) = Double -> Either Text Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
x
  decodeScalar (Int Int
x) = Double -> Either Text Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Either Text Double) -> Double -> Either Text Double
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
x
  decodeScalar ScalarValue
_ = Text -> Either Text Double
forall a b. a -> Either a b
Left Text
""

instance EncodeScalar Double where
  encodeScalar :: Double -> ScalarValue
encodeScalar = Double -> ScalarValue
Float

scalarToJSON :: EncodeScalar a => a -> A.Value
scalarToJSON :: a -> Value
scalarToJSON = ScalarValue -> Value
forall a. ToJSON a => a -> Value
A.toJSON (ScalarValue -> Value) -> (a -> ScalarValue) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ScalarValue
forall a. EncodeScalar a => a -> ScalarValue
encodeScalar

scalarFromJSON :: (Monad m, MonadFail m) => DecodeScalar a => A.Value -> m a
scalarFromJSON :: Value -> m a
scalarFromJSON Value
x = case Value -> Value Any
forall (a :: Stage). Value -> Value a
replaceValue Value
x of
  Scalar ScalarValue
value -> (Text -> m a) -> (a -> m a) -> Either Text a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (Text -> String) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> Either Text a
forall a. DecodeScalar a => ScalarValue -> Either Text a
decodeScalar ScalarValue
value)
  Value Any
_ -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"input must be scalar value"