{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Language.GraphQL.Execute.Coerce
( Output(..)
, Serialize(..)
, VariableValue(..)
, coerceInputLiteral
, matchFieldValues
) where
import qualified Data.Aeson as Aeson
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map.Strict (Map)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
class VariableValue a where
coerceVariableValue
:: In.Type
-> a
-> Maybe Type.Value
instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just Type.Null
coerceVariableValue (In.ScalarBaseType scalarType) value
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
| (Aeson.Number numberValue) <- value
, (Type.ScalarType "Float" _) <- scalarType =
Just $ Type.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value =
Type.Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value
| (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
then Just $ Type.Object resultMap
else Nothing
where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
$ Just (objectValue, HashMap.empty)
matchFieldValues' _ _ Nothing = Nothing
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
let (In.InputField _ fieldType _) = inputField
insert = flip (HashMap.insert fieldName) resultMap
newObjectValue = HashMap.delete fieldName objectValue
in case HashMap.lookup fieldName objectValue of
Just variableValue -> do
coerced <- coerceVariableValue fieldType variableValue
pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) value
| (Aeson.Array arrayValue) <- value =
Type.List <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value
where
foldVector _ Nothing = Nothing
foldVector variableValue (Just list) = do
coerced <- coerceVariableValue listType variableValue
pure $ coerced : list
coerceVariableValue _ _ = Nothing
matchFieldValues :: forall a
. (In.Type -> a -> Maybe Type.Value)
-> HashMap Name a
-> Name
-> In.Type
-> Maybe Type.Value
-> Maybe (HashMap Name Type.Value)
-> Maybe (HashMap Name Type.Value)
matchFieldValues coerce values' fieldName type' defaultValue resultMap =
case HashMap.lookup fieldName values' of
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
Nothing
| Just value <- defaultValue ->
HashMap.insert fieldName value <$> resultMap
| Nothing <- defaultValue
, In.isNonNullType type' -> Nothing
| otherwise -> resultMap
where
coerceRuntimeValue (Just Type.Null)
| In.isNonNullType type' = Nothing
coerceRuntimeValue coercedValue =
HashMap.insert fieldName <$> coercedValue <*> resultMap
coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null
coerceInputLiteral (In.ScalarBaseType type') value
| (Type.String stringValue) <- value
, (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue
| (Type.Boolean booleanValue) <- value
, (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue
| (Type.Int intValue) <- value
, (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue
| (Type.Float floatValue) <- value
, (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue
| (Type.Int intValue) <- value
, (Type.ScalarType "Float" _) <- type' =
Just $ Type.Float $ fromIntegral intValue
| (Type.String stringValue) <- value
, (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue
| (Type.Int intValue) <- value
, (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue
where
decimal = Type.String
. Text.Lazy.toStrict
. Text.Builder.toLazyText
. Text.Builder.decimal
coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
| member enumValue type' = Just $ Type.Enum enumValue
where
member value (Type.EnumType _ _ members) = HashMap.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
let (In.InputObjectType _ _ inputFields) = type'
in Type.Object
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
where
matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
coerceInputLiteral (In.ListBaseType listType) (Type.List list) =
Type.List <$> traverse (coerceInputLiteral listType) list
coerceInputLiteral (In.ListBaseType listType) singleton =
wrapSingleton listType singleton
where
wrapSingleton (In.ListBaseType listType') singleton' =
Type.List <$> sequence [wrapSingleton listType' singleton']
wrapSingleton listType' singleton' =
Type.List <$> sequence [coerceInputLiteral listType' singleton']
coerceInputLiteral _ _ = Nothing
class Serialize a where
serialize :: forall m
. Out.Type m
-> Output a
-> Maybe a
null :: a
data Output a
= Int Int32
| Float Double
| String Text
| Boolean Bool
| Enum Name
| List [a]
| Object (Map Name a)
deriving (Eq, Show)
instance forall a. IsString (Output a) where
fromString = String . fromString
instance Serialize Aeson.Value where
serialize (Out.ScalarBaseType scalarType) value
| Type.ScalarType "Int" _ <- scalarType
, Int int <- value = Just $ Aeson.toJSON int
| Type.ScalarType "Float" _ <- scalarType
, Float float <- value = Just $ Aeson.toJSON float
| Type.ScalarType "String" _ <- scalarType
, String string <- value = Just $ Aeson.String string
| Type.ScalarType "ID" _ <- scalarType
, String string <- value = Just $ Aeson.String string
| Type.ScalarType "Boolean" _ <- scalarType
, Boolean boolean <- value = Just $ Aeson.Bool boolean
serialize _ (Enum enum) = Just $ Aeson.String enum
serialize _ (List list) = Just $ Aeson.toJSON list
serialize _ (Object object) = Just $ Aeson.toJSON object
serialize _ _ = Nothing
null = Aeson.Null