{- 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
    , showNonNullType
    , showNonNullListType
    , 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
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: 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 Name
text) = String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> ShowS) -> String -> Name -> String
forall a. (Char -> a -> a) -> a -> Name -> 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
"\"" Name
text
    show (Boolean Bool
boolean') = Bool -> String
forall a. Show a => a -> String
show Bool
boolean'
    show Value
Null = String
"null"
    show (Enum Name
name) = Name -> String
Text.unpack Name
name
    show (List [Value]
list) = [Value] -> String
forall a. Show a => a -> String
show [Value]
list
    show (Object HashMap Name Value
fields) = [String] -> String
unwords
        [ String
"{"
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Name -> Value -> [String] -> [String])
-> [String] -> HashMap Name Value -> [String]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Name -> Value -> [String] -> [String]
forall {a}. Show a => Name -> a -> [String] -> [String]
showObject [] HashMap Name Value
fields)
        , String
"}"
        ]
      where
        showObject :: Name -> a -> [String] -> [String]
showObject Name
key a
value [String]
accumulator =
            [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Name -> String
Text.unpack Name
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 = Name -> Value
String (Name -> Value) -> (String -> Name) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
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
$c== :: Arguments -> Arguments -> Bool
== :: Arguments -> Arguments -> Bool
$c/= :: Arguments -> Arguments -> Bool
/= :: 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
$cshowsPrec :: Int -> Arguments -> ShowS
showsPrec :: Int -> Arguments -> ShowS
$cshow :: Arguments -> String
show :: Arguments -> String
$cshowList :: [Arguments] -> ShowS
showList :: [Arguments] -> ShowS
Show)

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

instance Monoid Arguments where
    mempty :: Arguments
mempty = HashMap Name Value -> Arguments
Arguments HashMap Name 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 Name
this Maybe Name
_) == :: ScalarType -> ScalarType -> Bool
== (ScalarType Name
that Maybe Name
_) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

instance Show ScalarType where
    show :: ScalarType -> String
show (ScalarType Name
typeName Maybe Name
_) = Name -> String
Text.unpack Name
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 Name
this Maybe Name
_ HashMap Name EnumValue
_) == :: EnumType -> EnumType -> Bool
== (EnumType Name
that Maybe Name
_ HashMap Name EnumValue
_) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

instance Show EnumType where
    show :: EnumType -> String
show (EnumType Name
typeName Maybe Name
_ HashMap Name EnumValue
_) = Name -> String
Text.unpack Name
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 = Name -> Maybe Name -> ScalarType
ScalarType Name
"String" (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
description)
  where
    description :: Name
description =
        Name
"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 = Name -> Maybe Name -> ScalarType
ScalarType Name
"Boolean" (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
description)
  where
    description :: Name
description = Name
"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 = Name -> Maybe Name -> ScalarType
ScalarType Name
"Int" (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
description)
  where
    description :: Name
description =
        Name
"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 = Name -> Maybe Name -> ScalarType
ScalarType Name
"Float" (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
description)
  where
    description :: Name
description =
        Name
"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 = Name -> Maybe Name -> ScalarType
ScalarType Name
"ID" (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
description)
  where
    description :: Name
description =
        Name
"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
$c== :: Directive -> Directive -> Bool
== :: Directive -> Directive -> Bool
$c/= :: Directive -> Directive -> Bool
/= :: 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
$cshowsPrec :: Int -> Directive -> ShowS
showsPrec :: Int -> Directive -> ShowS
$cshow :: Directive -> String
show :: Directive -> String
$cshowList :: [Directive] -> ShowS
showList :: [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 a b. (a -> b -> b) -> b -> [a] -> b
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 Name
"skip" (Arguments HashMap Name Value
arguments)) =
        case Name -> HashMap Name Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"if" HashMap Name 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 Name
"include" (Arguments HashMap Name Value
arguments)) =
        case Name -> HashMap Name Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"if" HashMap Name Value
arguments of
            (Just (Boolean Bool
True)) -> Directive -> Status
Include Directive
directive'
            Maybe Value
_ -> Status
Skip
    include' Directive
directive' = Directive -> Status
Continue Directive
directive'

showNonNullType :: Show a => a -> String
showNonNullType :: forall a. Show a => a -> String
showNonNullType = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!") ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

showNonNullListType :: Show a => a -> String
showNonNullListType :: forall a. Show a => a -> String
showNonNullListType a
listType =
    let representation :: String
representation = a -> String
forall a. Show a => a -> String
show a
listType
     in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"[", String
representation, String
"]!"]