{-# 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 (Scalar x) = pure x
toScalar _ = Left ""

scalarValidator :: forall f a. DecodeScalar a => f a -> ScalarDefinition
scalarValidator _ = ScalarDefinition {validateValue = validator}
  where
    validator value = do
      scalarValue' <- toScalar value
      (_ :: a) <- decodeScalar scalarValue'
      pure 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 (String x) = pure x
  decodeScalar _ = Left ""

instance EncodeScalar Text where
  encodeScalar = String

instance DecodeScalar Bool where
  decodeScalar (Boolean x) = pure x
  decodeScalar _ = Left ""

instance EncodeScalar Bool where
  encodeScalar = Boolean

instance DecodeScalar Int where
  decodeScalar (Int x) = pure x
  decodeScalar _ = Left ""

instance EncodeScalar Int where
  encodeScalar = Int

instance DecodeScalar Float where
  decodeScalar (Float x) = pure (double2Float x)
  decodeScalar (Int x) = pure $ fromInteger $ toInteger x
  decodeScalar _ = Left ""

instance EncodeScalar Float where
  encodeScalar = Float . float2Double

instance DecodeScalar Double where
  decodeScalar (Float x) = pure x
  decodeScalar (Int x) = pure $ fromInteger $ toInteger x
  decodeScalar _ = Left ""

instance EncodeScalar Double where
  encodeScalar = Float

scalarToJSON :: EncodeScalar a => a -> A.Value
scalarToJSON = A.toJSON . encodeScalar

scalarFromJSON :: (Monad m, MonadFail m) => DecodeScalar a => A.Value -> m a
scalarFromJSON x = case replaceValue x of
  Scalar value -> either (fail . unpack) pure (decodeScalar value)
  _ -> fail "input must be scalar value"