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

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

import qualified Data.Aeson as A
import Data.Morpheus.Types.Internal.AST
  ( ScalarDefinition (..),
    ScalarValue (..),
    ValidValue,
    Value (..),
    replaceValue,
  )
import Data.Text (unpack)
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
""

-- | GraphQL Scalar
--
-- 'parseValue' and 'serialize' should be provided for every instances manually
class GQLScalar a 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 :
  --
  -- @
  --   parseValue String _ = Left "" -- without error message
  --   -- or
  --   parseValue String _ = Left "Error Message"
  -- @
  parseValue :: ScalarValue -> Either Text a

  -- | serialization of haskell type into scalar value
  serialize :: a -> ScalarValue

  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. GQLScalar a => ScalarValue -> Either Text a
parseValue ScalarValue
scalarValue'
        ValidValue -> Either Text ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value

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

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

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

instance GQLScalar Float where
  parseValue :: ScalarValue -> Either Text Float
parseValue (Float Float
x) = Float -> Either Text Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
x
  parseValue (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
  parseValue ScalarValue
_ = Text -> Either Text Float
forall a b. a -> Either a b
Left Text
""
  serialize :: Float -> ScalarValue
serialize = Float -> ScalarValue
Float

scalarToJSON :: GQLScalar 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. GQLScalar a => a -> ScalarValue
serialize

scalarFromJSON :: (Monad m, MonadFail m) => GQLScalar 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. GQLScalar a => ScalarValue -> Either Text a
parseValue ScalarValue
value)
  Value Any
_ -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"input must be scalar value"