{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}

-- | Types that can be used as both input and output types.
module Language.GraphQL.Type.Definition
    ( Arguments(..)
    , Directive(..)
    , EnumType(..)
    , EnumValue(..)
    , ScalarType(..)
    , Subs
    , Value(..)
    , boolean
    , float
    , id
    , int
    , selection
    , string
    ) where

import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (intercalate)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST (Name, escape)
import Numeric (showFloat)
import Prelude hiding (id)

-- | Represents accordingly typed GraphQL values.
data Value
    = Int Int32
    | Float Double -- ^ GraphQL Float is double precision.
    | String Text
    | Boolean Bool
    | Null
    | Enum Name
    | List [Value] -- ^ Arbitrary nested list.
    | Object (HashMap Name Value)
    deriving Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq

instance Show Value where
    showList :: [Value] -> ShowS
showList = String -> ShowS
forall a. Monoid a => a -> a -> a
mappend (String -> ShowS) -> ([Value] -> String) -> [Value] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> String
forall a. Show a => [a] -> String
showList'
      where
        showList' :: [a] -> String
showList' [a]
list = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (a -> String
forall a. Show a => a -> String
show (a -> String) -> [a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
list) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    show :: Value -> String
show (Int Int32
integer) = Int32 -> String
forall a. Show a => a -> String
show Int32
integer
    show (Float Double
float') = Double -> ShowS
forall a. RealFloat a => a -> ShowS
showFloat Double
float' String
forall a. Monoid a => a
mempty
    show (String Text
text) = String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> ShowS) -> String -> Text -> String
forall a. (Char -> a -> a) -> a -> Text -> a
Text.foldr (String -> ShowS
forall a. Monoid a => a -> a -> a
mappend (String -> ShowS) -> (Char -> String) -> Char -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
escape) String
"\"" Text
text
    show (Boolean Bool
boolean') = Bool -> String
forall a. Show a => a -> String
show Bool
boolean'
    show Value
Null = String
"null"
    show (Enum Text
name) = Text -> String
Text.unpack Text
name
    show (List [Value]
list) = [Value] -> String
forall a. Show a => a -> String
show [Value]
list
    show (Object HashMap Text Value
fields) = [String] -> String
unwords
        [ String
"{"
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Text -> Value -> [String] -> [String])
-> [String] -> HashMap Text Value -> [String]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Text -> Value -> [String] -> [String]
forall a. Show a => Text -> a -> [String] -> [String]
showObject [] HashMap Text Value
fields)
        , String
"}"
        ]
      where
        showObject :: Text -> a -> [String] -> [String]
showObject Text
key a
value [String]
accumulator =
            [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Text -> String
Text.unpack Text
key, String
": ", a -> String
forall a. Show a => a -> String
show a
value] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
accumulator

instance IsString Value where
    fromString :: String -> Value
fromString = Text -> Value
String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

-- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value.
type Subs = HashMap Name Value

-- | Argument list.
newtype Arguments = Arguments (HashMap Name Value)
    deriving (Arguments -> Arguments -> Bool
(Arguments -> Arguments -> Bool)
-> (Arguments -> Arguments -> Bool) -> Eq Arguments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arguments -> Arguments -> Bool
$c/= :: Arguments -> Arguments -> Bool
== :: Arguments -> Arguments -> Bool
$c== :: Arguments -> Arguments -> Bool
Eq, Int -> Arguments -> ShowS
[Arguments] -> ShowS
Arguments -> String
(Int -> Arguments -> ShowS)
-> (Arguments -> String)
-> ([Arguments] -> ShowS)
-> Show Arguments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arguments] -> ShowS
$cshowList :: [Arguments] -> ShowS
show :: Arguments -> String
$cshow :: Arguments -> String
showsPrec :: Int -> Arguments -> ShowS
$cshowsPrec :: Int -> Arguments -> ShowS
Show)

instance Semigroup Arguments where
    (Arguments HashMap Text Value
x) <> :: Arguments -> Arguments -> Arguments
<> (Arguments HashMap Text Value
y) = HashMap Text Value -> Arguments
Arguments (HashMap Text Value -> Arguments)
-> HashMap Text Value -> Arguments
forall a b. (a -> b) -> a -> b
$ HashMap Text Value
x HashMap Text Value -> HashMap Text Value -> HashMap Text Value
forall a. Semigroup a => a -> a -> a
<> HashMap Text Value
y

instance Monoid Arguments where
    mempty :: Arguments
mempty = HashMap Text Value -> Arguments
Arguments HashMap Text Value
forall a. Monoid a => a
mempty

-- | Scalar type definition.
--
-- The leaf values of any request and input values to arguments are Scalars (or
-- Enums) .
data ScalarType = ScalarType Name (Maybe Text)

instance Eq ScalarType where
    (ScalarType Text
this Maybe Text
_) == :: ScalarType -> ScalarType -> Bool
== (ScalarType Text
that Maybe Text
_) = Text
this Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
that

instance Show ScalarType where
    show :: ScalarType -> String
show (ScalarType Text
typeName Maybe Text
_) = Text -> String
Text.unpack Text
typeName

-- | Enum type definition.
--
-- Some leaf values of requests and input values are Enums. GraphQL serializes
-- Enum values as strings, however internally Enums can be represented by any
-- kind of type, often integers.
data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)

instance Eq EnumType where
    (EnumType Text
this Maybe Text
_ HashMap Text EnumValue
_) == :: EnumType -> EnumType -> Bool
== (EnumType Text
that Maybe Text
_ HashMap Text EnumValue
_) = Text
this Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
that

instance Show EnumType where
    show :: EnumType -> String
show (EnumType Text
typeName Maybe Text
_ HashMap Text EnumValue
_) = Text -> String
Text.unpack Text
typeName

-- | Enum value is a single member of an 'EnumType'.
newtype EnumValue = EnumValue (Maybe Text)

-- | The @String@ scalar type represents textual data, represented as UTF-8
-- character sequences. The String type is most often used by GraphQL to
-- represent free-form human-readable text.
string :: ScalarType
string :: ScalarType
string = Text -> Maybe Text -> ScalarType
ScalarType Text
"String" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
  where
    description :: Text
description =
        Text
"The `String` scalar type represents textual data, represented as \
        \UTF-8 character sequences. The String type is most often used by \
        \GraphQL to represent free-form human-readable text."

-- | The @Boolean@ scalar type represents @true@ or @false@.
boolean :: ScalarType
boolean :: ScalarType
boolean = Text -> Maybe Text -> ScalarType
ScalarType Text
"Boolean" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
  where
    description :: Text
description = Text
"The `Boolean` scalar type represents `true` or `false`."

-- | The @Int@ scalar type represents non-fractional signed whole numeric
-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).
int :: ScalarType
int :: ScalarType
int = Text -> Maybe Text -> ScalarType
ScalarType Text
"Int" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
  where
    description :: Text
description =
        Text
"The `Int` scalar type represents non-fractional signed whole numeric \
        \values. Int can represent values between -(2^31) and 2^31 - 1."

-- | The @Float@ scalar type represents signed double-precision fractional
-- values as specified by
-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).
float :: ScalarType
float :: ScalarType
float = Text -> Maybe Text -> ScalarType
ScalarType Text
"Float" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
  where
    description :: Text
description =
        Text
"The `Float` scalar type represents signed double-precision fractional \
        \values as specified by \
        \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."

-- | The @ID@ scalar type represents a unique identifier, often used to refetch
-- an object or as key for a cache. The ID type appears in a JSON response as a
-- String; however, it is not intended to be human-readable. When expected as an
-- input type, any string (such as @"4"@) or integer (such as @4@) input value
-- will be accepted as an ID.
id :: ScalarType
id :: ScalarType
id = Text -> Maybe Text -> ScalarType
ScalarType Text
"ID" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
  where
    description :: Text
description =
        Text
"The `ID` scalar type represents a unique identifier, often used to \
        \refetch an object or as key for a cache. The ID type appears in a \
        \JSON response as a String; however, it is not intended to be \
        \human-readable. When expected as an input type, any string (such as \
        \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."

-- | Directive.
data Directive = Directive Name Arguments
    deriving (Directive -> Directive -> Bool
(Directive -> Directive -> Bool)
-> (Directive -> Directive -> Bool) -> Eq Directive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directive -> Directive -> Bool
$c/= :: Directive -> Directive -> Bool
== :: Directive -> Directive -> Bool
$c== :: Directive -> Directive -> Bool
Eq, Int -> Directive -> ShowS
[Directive] -> ShowS
Directive -> String
(Int -> Directive -> ShowS)
-> (Directive -> String)
-> ([Directive] -> ShowS)
-> Show Directive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Directive] -> ShowS
$cshowList :: [Directive] -> ShowS
show :: Directive -> String
$cshow :: Directive -> String
showsPrec :: Int -> Directive -> ShowS
$cshowsPrec :: Int -> Directive -> ShowS
Show)

-- | Directive processing status.
data Status
    = Skip -- ^ Skip the selection and stop directive processing
    | Include Directive -- ^ The directive was processed, try other handlers
    | Continue Directive -- ^ Directive handler mismatch, try other handlers

-- | Takes a list of directives, handles supported directives and excludes them
--   from the result. If the selection should be skipped, returns 'Nothing'.
selection :: [Directive] -> Maybe [Directive]
selection :: [Directive] -> Maybe [Directive]
selection = (Directive -> Maybe [Directive] -> Maybe [Directive])
-> Maybe [Directive] -> [Directive] -> Maybe [Directive]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Directive -> Maybe [Directive] -> Maybe [Directive]
go ([Directive] -> Maybe [Directive]
forall a. a -> Maybe a
Just [])
  where
    go :: Directive -> Maybe [Directive] -> Maybe [Directive]
go Directive
directive' Maybe [Directive]
directives' =
        case (Status -> Status
skip (Status -> Status) -> (Status -> Status) -> Status -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Status
include) (Directive -> Status
Continue Directive
directive') of
            (Include Directive
_) -> Maybe [Directive]
directives'
            Status
Skip -> Maybe [Directive]
forall a. Maybe a
Nothing
            (Continue Directive
x) -> (Directive
x Directive -> [Directive] -> [Directive]
forall a. a -> [a] -> [a]
:) ([Directive] -> [Directive])
-> Maybe [Directive] -> Maybe [Directive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Directive]
directives'

handle :: (Directive -> Status) -> Status -> Status
handle :: (Directive -> Status) -> Status -> Status
handle Directive -> Status
_ Status
Skip = Status
Skip
handle Directive -> Status
handler (Continue Directive
directive) = Directive -> Status
handler Directive
directive
handle Directive -> Status
handler (Include Directive
directive) = Directive -> Status
handler Directive
directive

-- * Directive implementations

skip :: Status -> Status
skip :: Status -> Status
skip = (Directive -> Status) -> Status -> Status
handle Directive -> Status
skip'
  where
    skip' :: Directive -> Status
skip' directive' :: Directive
directive'@(Directive Text
"skip" (Arguments HashMap Text Value
arguments)) =
        case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"if" HashMap Text Value
arguments of
            (Just (Boolean Bool
True)) -> Status
Skip
            Maybe Value
_ -> Directive -> Status
Include Directive
directive'
    skip' Directive
directive' = Directive -> Status
Continue Directive
directive'

include :: Status -> Status
include :: Status -> Status
include = (Directive -> Status) -> Status -> Status
handle Directive -> Status
include'
  where
    include' :: Directive -> Status
include' directive' :: Directive
directive'@(Directive Text
"include" (Arguments HashMap Text Value
arguments)) =
        case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"if" HashMap Text Value
arguments of
            (Just (Boolean Bool
True)) -> Directive -> Status
Include Directive
directive'
            Maybe Value
_ -> Status
Skip
    include' Directive
directive' = Directive -> Status
Continue Directive
directive'