Allow graphql 1.4.0.0

For deriving FromGraphQL instances automatically.

.gitea/deploy.awk

@@ -0,0 +1,3 @@
+END {
+    system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0)
+}

.gitea/workflows/build.yml

@@ -0,0 +1,33 @@
+name: Build
+
+on:
+  push:
+    branches:
+      - '**'
+  pull_request:
+    branches: [master]
+
+jobs:
+  audit:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - run: hlint -- src tests
+
+  test:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Install dependencies
+        run: cabal update
+      - name: Prepare system
+        run: cabal build graphql-test
+      - run: cabal test --test-show-details=streaming
+
+  doc:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Install dependencies
+        run: cabal update
+      - run: cabal haddock --enable-documentation

.gitea/workflows/release.yml

@@ -0,0 +1,17 @@
+name: Release
+
+on:
+  push:
+    tags:
+      - '**'
+
+jobs:
+  release:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Upload a candidate
+        env:
+          HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
+        run: |
+          cabal sdist | awk -f .gitea/deploy.awk

CHANGELOG.md

@@ -6,4 +6,43 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
-## [Unreleased]
+## [1.0.5.0] - 2024-11-21
+### Added
+- Add `ToGraphQL` and `FromGraphQL` instances for `Value` and `HashMap`.
+
+## [1.0.4.0] - 2024-10-24
+### Added
+- `gql` quasi quoter which generates a string literal with the first line
+  starting at the first column and all following lines indented relative to the
+  first line.
+
+## [1.0.3.0] - 2024-07-20
+### Added
+- Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically.
+- Add `deriveFromGraphQL`for deriving `FromGraphQL` instances automatically.
+
+## [1.0.2.0] - 2023-07-07
+### Added
+- `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`,
+  and `Scientific`.
+- `ToGraphQL` and `FromGraphQL` instances for `Day`, `DiffTime`,
+  `NominalDiffTime`, `UTCTime`, `LocalTime` and `TimeOfDay`.
+- `Resolver`: Export `ServerException`.
+- `Resolver.defaultResolver`: Throw `FieldNotResolvedException` if the requested
+  field is not in the parent object.
+
+## [1.0.1.0] - 2023-02-17
+### Added
+- `ToGraphQL` and `FromGraphQL` typeclasses with instances for basic types.
+- `Resolver` module with `argument` and `defaultResolver` helper functions.
+
+## 1.0.0.0 - 2022-03-29
+### Added
+- JSON serialization.
+- Test helpers.
+
+[1.0.5.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.4.0...v1.0.5.0
+[1.0.4.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.3.0...v1.0.4.0
+[1.0.3.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.2.0...v1.0.3.0
+[1.0.2.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.1.0...v1.0.2.0
+[1.0.1.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.0.0...v1.0.1.0

cabal.project

@@ -1,4 +0,0 @@
-packages: .
-
-constraints: graphql -json
-tests: False

graphql-spice.cabal

@@ -1,44 +1,60 @@
-cabal-version:      2.4
+cabal-version:      3.0
 
 name:               graphql-spice
-version:            0.1.0.0
+version:            1.0.5.0
 synopsis:           GraphQL with batteries
-description:        Various extensions and convenience functions  for the core
+description:        Various extensions and convenience functions for the core
                     graphql package.
 category:           Language
-homepage:           https://www.caraus.tech/projects/pub-graphql-spice
+homepage:           https://git.caraus.tech/OSS/graphql-spice
-bug-reports:        https://www.caraus.tech/projects/pub-graphql-spice/issues
+bug-reports:        https://git.caraus.tech/OSS/graphql-spice/issues
 author:             Eugen Wissner <belka@caraus.de>
 maintainer:         belka@caraus.de
-copyright:          (c) 2021 Eugen Wissner
+copyright:          (c) 2021-2024 Eugen Wissner
 license:            MPL-2.0
 license-files:      LICENSE
 build-type:         Simple
 extra-source-files: CHANGELOG.md
 tested-with:
-  GHC == 8.10.7
+  GHC == 9.8.2
 
 source-repository head
   type: git
-  location: git://caraus.tech/pub/graphql-spice.git
+  location: https://git.caraus.tech/OSS/graphql-spice.git
 
 library
     exposed-modules:
-      Language.GraphQL.Foundation,
+      Language.GraphQL.Class
-      Language.GraphQL.Serialize
+      Language.GraphQL.JSON
+      Language.GraphQL.Resolver
+      Test.Hspec.GraphQL
     other-modules:
     hs-source-dirs:   src
     ghc-options: -Wall
     build-depends:
-      aeson ^>= 2.0.3,
+      aeson >= 2.0.3 && < 2.3,
-      base ^>=4.14.3.0,
+      base >= 4.7 && < 5,
-      graphql ^>= 1.0.2
+      conduit ^>= 1.3.4,
+      containers >= 0.6 && < 0.8,
+      exceptions ^>= 0.10.4,
+      hspec-expectations >= 0.8.2 && < 0.9,
+      graphql >= 1.3.0 && < 1.5.0,
+      megaparsec >= 9.0 && < 10,
+      scientific ^>= 0.3.7,
+      template-haskell >= 2.16 && < 3,
+      text >= 1.2 && < 3,
+      time >= 1.12.2 && < 1.15,
+      transformers >= 0.5.6 && < 0.7,
+      vector >= 0.12 && < 0.14,
+      unordered-containers ^>= 0.2.16
     default-language: Haskell2010
 
 test-suite graphql-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+    Language.GraphQL.ClassSpec
+    Language.GraphQL.CoerceSpec
     Language.GraphQL.DirectiveSpec
     Language.GraphQL.FragmentSpec
     Language.GraphQL.RootOperationSpec
@@ -47,10 +63,14 @@ test-suite graphql-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:
     aeson,
-    base >= 4.8 && < 5,
+    base,
     graphql,
     graphql-spice,
     hspec >= 2.9.1 && < 3,
+    scientific,
     text,
+    time,
     unordered-containers
+  build-tool-depends:
+    hspec-discover:hspec-discover
   default-language: Haskell2010

src/Language/GraphQL/Class.hs

@@ -0,0 +1,497 @@
+{- 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 TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | ToGraphQL and FromGraphQL typeclasses used for user-defined type
+-- conversion.
+module Language.GraphQL.Class
+    ( FromGraphQL(..)
+    , ToGraphQL(..)
+    , deriveFromGraphQL
+    , deriveToGraphQL
+    , gql
+    ) where
+
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Text (Text)
+import Data.Word (Word8, Word16, Word32, Word64)
+import qualified Data.Text.Read as Text.Read
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Data.Scientific (Scientific, toRealFloat)
+import qualified Data.Text as Text
+import Data.Time
+    ( Day
+    , DiffTime
+    , LocalTime(..)
+    , NominalDiffTime
+    , TimeOfDay(..)
+    , UTCTime(..)
+    , showGregorian
+    , secondsToNominalDiffTime
+    , secondsToDiffTime
+    )
+import Data.Time.Format.ISO8601
+    ( ISO8601(..)
+    , formatParseM
+    , iso8601Format
+    , iso8601Show
+    )
+import Language.Haskell.TH
+    ( Con(..)
+    , Dec(..)
+    , Exp(..)
+    , Info(..)
+    , Lit(..)
+    , Quote(..)
+    , Name
+    , Q
+    , VarBangType
+    , appT
+    , conP
+    , conT
+    , instanceD
+    , recP
+    , reify
+    , nameBase
+    , listE
+    , stringL
+    , tupE
+    , litE
+    , varE
+    , varP
+    , funD
+    , clause
+    , normalB
+    , appE
+    , mkName
+    , conE
+    , integerL
+    , litP
+    , wildP
+    )
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Data.Foldable (Foldable(..))
+import qualified Data.HashMap.Strict as HashMap
+import qualified Language.GraphQL.Type as Type
+import Prelude hiding (id)
+
+fromGraphQLToIntegral :: Integral a => Type.Value -> Maybe a
+fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
+fromGraphQLToIntegral (Type.String value) =
+    case Text.Read.decimal value of
+        Right (converted, "") -> Just converted
+        _conversionError -> Nothing
+fromGraphQLToIntegral _ = Nothing
+
+iso8601ToGraphQL :: ISO8601 t => t -> Type.Value
+iso8601ToGraphQL = Type.String . Text.pack . iso8601Show
+
+fromGraphQLToISO8601 :: ISO8601 t => Type.Value -> Maybe t
+fromGraphQLToISO8601 (Type.String value') = formatParseM iso8601Format $ Text.unpack value'
+fromGraphQLToISO8601 _ = Nothing
+
+-- | Instances of this typeclass can be converted to GraphQL internal
+-- representation.
+class ToGraphQL a
+  where
+    toGraphQL :: a -> Type.Value
+
+instance ToGraphQL Type.Value
+  where
+    toGraphQL a = a
+
+instance ToGraphQL Text
+  where
+    toGraphQL = Type.String
+
+instance ToGraphQL Int
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Int8
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Int16
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Int32
+  where
+    toGraphQL = Type.Int
+
+instance ToGraphQL Int64
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Word
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Word8
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Word16
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Word32
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL Word64
+  where
+    toGraphQL = Type.Int . fromIntegral
+
+instance ToGraphQL a => ToGraphQL [a]
+  where
+    toGraphQL = Type.List . fmap toGraphQL
+
+instance ToGraphQL a => ToGraphQL (Vector a)
+  where
+    toGraphQL = Type.List . toList . fmap toGraphQL
+
+instance ToGraphQL a => ToGraphQL (Maybe a)
+  where
+    toGraphQL (Just justValue) = toGraphQL justValue
+    toGraphQL Nothing = Type.Null
+
+instance ToGraphQL Bool
+  where
+    toGraphQL = Type.Boolean
+
+instance ToGraphQL Float
+  where
+    toGraphQL = Type.Float . realToFrac
+
+instance ToGraphQL Double
+  where
+    toGraphQL = Type.Float
+
+instance ToGraphQL Scientific
+  where
+    toGraphQL = Type.Float . toRealFloat
+
+instance ToGraphQL Day
+  where
+    toGraphQL = Type.String . Text.pack . showGregorian
+
+instance ToGraphQL DiffTime
+  where
+    toGraphQL = Type.Int . truncate . (realToFrac :: DiffTime -> Double)
+
+instance ToGraphQL NominalDiffTime
+  where
+    toGraphQL = Type.Int . truncate . (realToFrac :: NominalDiffTime -> Double)
+
+instance ToGraphQL UTCTime
+  where
+    toGraphQL = iso8601ToGraphQL
+
+instance ToGraphQL TimeOfDay
+  where
+    toGraphQL = iso8601ToGraphQL
+
+instance ToGraphQL LocalTime
+  where
+    toGraphQL = iso8601ToGraphQL
+
+instance ToGraphQL a => ToGraphQL (HashMap.HashMap Text a)
+  where
+    toGraphQL = Type.Object . fmap toGraphQL
+
+-- | Instances of this typeclass can be used to convert GraphQL internal
+-- representation to user-defined type.
+class FromGraphQL a
+  where
+    fromGraphQL :: Type.Value -> Maybe a
+
+instance FromGraphQL Type.Value
+  where
+    fromGraphQL = Just
+
+instance FromGraphQL Text
+  where
+    fromGraphQL (Type.String value) = Just value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL Int
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Int8
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Int16
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Int32
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Int64
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Word
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Word8
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Word16
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Word32
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL Word64
+  where
+    fromGraphQL = fromGraphQLToIntegral
+
+instance FromGraphQL a => FromGraphQL [a]
+  where
+    fromGraphQL (Type.List value) = traverse fromGraphQL value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL a => FromGraphQL (Vector a)
+  where
+    fromGraphQL (Type.List value) = Vector.fromList
+        <$> traverse fromGraphQL value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL a => FromGraphQL (Maybe a)
+  where
+    fromGraphQL Type.Null = Just Nothing
+    fromGraphQL value = Just <$> fromGraphQL value
+
+instance FromGraphQL Bool
+  where
+    fromGraphQL (Type.Boolean value) = Just value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL Float
+  where
+    fromGraphQL (Type.Float value) = Just $ realToFrac value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL Double
+  where
+    fromGraphQL (Type.Float value) = Just value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL Scientific
+  where
+    fromGraphQL (Type.Float value) = Just $ realToFrac value
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL Day
+  where
+    fromGraphQL = fromGraphQLToISO8601
+
+instance FromGraphQL DiffTime
+  where
+    fromGraphQL (Type.Int value') = Just $ secondsToDiffTime $ fromIntegral value'
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL NominalDiffTime
+  where
+    fromGraphQL (Type.Int value') = Just $ secondsToNominalDiffTime $ fromIntegral value'
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL UTCTime
+  where
+    fromGraphQL = fromGraphQLToISO8601
+
+instance FromGraphQL TimeOfDay
+  where
+    fromGraphQL = fromGraphQLToISO8601
+
+instance FromGraphQL LocalTime
+  where
+    fromGraphQL = fromGraphQLToISO8601
+
+instance FromGraphQL a => FromGraphQL (HashMap.HashMap Text a)
+  where
+    fromGraphQL (Type.Object hm) = traverse fromGraphQL hm
+    fromGraphQL _ = Nothing
+
+stringLE :: Name -> Q Exp
+stringLE = litE . stringL . nameBase
+
+-- | Given a type derives a 'FromGraphQL' instance for it.
+--
+-- The derivation can only work when all nested types already have 'FromGraphQL'
+-- instances.
+--
+-- The following cases are supported:
+--
+-- * Records encode input objects.
+-- * Sum types with all data constructors without parameters encode Enums.
+deriveFromGraphQL :: Name -> Q [Dec]
+deriveFromGraphQL typeName = do
+    TyConI plainConstructor <- reify typeName
+    case plainConstructor of
+        DataD _ _ _ _ [cons'] _
+            | RecC dataConName varBangTypes <- cons' ->
+                withRecordConstructor dataConName varBangTypes
+        DataD _ _ _ _ cons' _ -> pure <$> generateEnumInstance cons'
+        NewtypeD _ _ _ _ cons' _
+            | RecC dataConName varBangTypes <- cons' ->
+                withRecordConstructor dataConName varBangTypes
+        _ -> error "Only input objects and enums are supported if all member types have a FromGraphQL instance"
+  where
+    enumMemberPattern (NormalC normalName []) =
+        let fromGraphQLF = conP (mkName "Type.Enum") [litP $ stringL $ nameBase normalName]
+         in flip (clause [fromGraphQLF]) []
+            $ normalB [|Just $(conE normalName)|]
+    enumMemberPattern _ =
+        error "Enum member should be a normal constructor without parameters"
+    generateEnumInstance :: [Con] -> Q Dec
+    generateEnumInstance cons'
+        = instanceD mempty (appT (conT ''FromGraphQL) conTName)
+        $ pure $ funD 'fromGraphQL
+        $ (enumMemberPattern <$> cons')
+        <> [clause [wildP] (normalB [|Nothing|]) []]
+    hashMapLookup fieldName objectName =
+        [|HashMap.lookup $(stringLE fieldName) $objectName >>= fromGraphQL|]
+    addRecordField objectName accumulator (name', _, _)
+        = appE (appE (varE $ mkName "<*>") accumulator)
+        $ hashMapLookup name' objectName
+    withRecordConstructor dataConName varBangTypes = do
+        valueName <- newName "value"
+        let objectName = varE valueName
+            toGraphQLF = conP (mkName "Type.Object") [varP valueName]
+            fBody = makeRecordBody (conE dataConName) objectName varBangTypes
+            recordSize = litE $ integerL $ fromIntegral $ length varBangTypes
+        [d|
+            instance FromGraphQL $conTName
+              where
+                fromGraphQL $toGraphQLF
+                    | HashMap.size $objectName == $recordSize = $fBody
+                    | otherwise = Nothing
+                fromGraphQL _ = Nothing
+         |]
+    makeRecordBody dataConE objectName ((headName, _, _) : varBangTypes') =
+        let initialExpression = appE (appE (varE $ mkName "<$>") dataConE)
+                $ hashMapLookup headName objectName
+         in foldl' (addRecordField objectName) initialExpression varBangTypes'
+    makeRecordBody dataConE _ [] = dataConE
+    conTName = conT typeName
+
+-- | Given a type derives a 'ToGraphQL' instance for it.
+--
+-- The derivation can only work when all nested types already have 'ToGraphQL'
+-- instances.
+--
+-- The following cases are supported:
+--
+-- * Records are decoded as objects.
+-- * Sum types with all data constructors without parameters are decoded as Enums.
+-- * Sum types whose data constructors have exactly one parameter are decoded as Unions.
+deriveToGraphQL :: Name -> Q [Dec]
+deriveToGraphQL typeName = do
+    TyConI plainConstructor <- reify typeName
+    case plainConstructor of
+        DataD _ _ _ _ [cons'] _
+            | RecC dataConName varBangTypes <- cons' ->
+                withRecordConstructor dataConName varBangTypes
+        DataD _ _ _ _ cons' _ -> fmap pure
+            $ instanceD mempty (appT (conT ''ToGraphQL) conTName)
+            $ pure $ funD 'toGraphQL
+            $ generateSumTypeInstance cons'
+        NewtypeD _ _ _ _ cons' _
+            | RecC dataConName varBangTypes <- cons' ->
+                withRecordConstructor dataConName varBangTypes
+        _ -> error "Only objects, unions and enums are supported if all member types have a ToGraphQL instance"
+  where
+    conTName = conT typeName
+    collectEnumMemberNames (NormalC normalName []) = Just normalName
+    collectEnumMemberNames _ = Nothing
+    collectUnionMembers (NormalC normalName [_]) = Just normalName
+    collectUnionMembers _ = Nothing
+    enumMemberPattern normalName
+        = flip (clause [conP normalName mempty]) []
+        $ normalB [|Type.Enum $(stringLE normalName)|]
+    unionMemberPattern normalName = do
+        dataName <- newName "member"
+        flip (clause [conP normalName [varP dataName]]) []
+            $ normalB
+            $ appE (varE $ mkName "toGraphQL")
+            $ varE dataName
+    generateSumTypeInstance cons'
+        | Just enumMemberNames <- traverse collectEnumMemberNames cons' =
+            enumMemberPattern <$> enumMemberNames
+        | Just unionMembers <- traverse collectUnionMembers cons' =
+            unionMemberPattern <$> unionMembers
+        | otherwise =  error "All data constructors should have either no parameters (Enum) or one parameter (Union)"
+    withRecordConstructor dataConName varBangTypes = do
+        fieldAliases <- traverse newFieldAliases varBangTypes
+        let fBody =
+                [| Type.Object
+                    $ HashMap.insert "__typename" $(stringLE typeName)
+                    $ HashMap.fromList $(listE $ resultObjectPairs <$> fieldAliases)
+                |]
+            toGraphQLF = recP dataConName (newFieldPatterns <$> fieldAliases)
+        [d|
+            instance ToGraphQL $conTName
+              where
+                toGraphQL $toGraphQLF = $fBody
+         |]
+    newFieldAliases :: VarBangType -> Q (Name, Name)
+    newFieldAliases (name', _, _) = (name',) <$> newName (nameBase name')
+    newFieldPatterns (name', alias) = (name',) <$> varP alias
+    resultObjectPairs :: (Name, Name) -> Q Exp
+    resultObjectPairs (name', alias) = tupE
+        [ litE (stringL $ nameBase name')
+        , [|toGraphQL $(varE alias)|]
+        ]
+
+stripIndentation :: String -> String
+stripIndentation code = reverse
+    $ dropWhile isLineBreak
+    $ reverse
+    $ unlines
+    $ indent spaces <$> lines' withoutLeadingNewlines
+  where
+    indent 0 xs = xs
+    indent count (' ' : xs) = indent (count - 1) xs
+    indent _ xs = xs
+    withoutLeadingNewlines = dropWhile isLineBreak code
+    spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
+    lines' "" = []
+    lines' string =
+        let (line, rest) = break isLineBreak string
+            reminder =
+                case rest of
+                    [] -> []
+                    '\r' : '\n' : strippedString -> lines' strippedString
+                    _ : strippedString -> lines' strippedString
+         in line : reminder
+    isLineBreak = flip any ['\n', '\r'] . (==)
+
+-- | Removes leading and trailing newlines. Indentation of the first line is
+-- removed from each line of the string.
+gql :: QuasiQuoter
+gql = QuasiQuoter
+    { quoteExp = pure . LitE . StringL . stripIndentation
+    , quotePat = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
+    , quoteType = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
+    , quoteDec = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
+    }

src/Language/GraphQL/Foundation.hs

@@ -1,5 +0,0 @@
-module Language.GraphQL.Foundation
-    ( module Language.GraphQL.Serialize
-    ) where
-
-import Language.GraphQL.Serialize

src/Language/GraphQL/JSON.hs

@@ -0,0 +1,159 @@
+{- 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 NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | JSON serialization.
+module Language.GraphQL.JSON
+    ( JSON(..)
+    , graphql
+    ) where
+
+import Control.Monad.Catch (MonadCatch)
+import qualified Data.Aeson.Types as Aeson
+import Data.Maybe (catMaybes)
+import qualified Data.Sequence as Seq
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import qualified Language.GraphQL as GraphQL
+import Language.GraphQL.AST (Location(..), Name)
+import Language.GraphQL.Error
+import Language.GraphQL.Type.Schema (Schema)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Conduit
+import qualified Data.Aeson.Key as Aeson.Key
+import qualified Data.Aeson.KeyMap as KeyMap
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Scientific (toBoundedInteger, toRealFloat)
+import Data.Text (Text)
+import Language.GraphQL.Execute.Coerce
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import qualified Language.GraphQL.Type as Type
+
+-- | Wraps an aeson value.
+newtype JSON = JSON Aeson.Value
+
+instance Aeson.ToJSON JSON where
+    toJSON (JSON value) = value
+
+instance Aeson.FromJSON JSON where
+    parseJSON = pure . JSON
+
+instance Serialize JSON where
+    serialize (Out.ScalarBaseType scalarType) value
+        | Type.ScalarType "Int" _ <- scalarType
+        , Int int <- value = Just $ JSON $ Aeson.Number $ fromIntegral int
+        | Type.ScalarType "Float" _ <- scalarType
+        , Float float <- value = Just $ JSON $ Aeson.toJSON float
+        | Type.ScalarType "String" _ <- scalarType
+        , String string <- value = Just $ JSON $ Aeson.String string
+        | Type.ScalarType "ID" _ <- scalarType
+        , String string <- value = Just $ JSON $ Aeson.String string
+        | Type.ScalarType "Boolean" _ <- scalarType
+        , Boolean boolean <- value = Just $ JSON $ Aeson.Bool boolean
+    serialize _ (Enum enum) = Just $ JSON $ Aeson.String enum
+    serialize _ (List list) = Just $ JSON $ Aeson.toJSON list
+    serialize _ (Object object) = Just
+        $ JSON
+        $ Aeson.object
+        $ toJSONKeyValue <$> OrderedMap.toList object
+      where
+        toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value)
+    serialize _ _ = Nothing
+    null = JSON Aeson.Null
+
+instance VariableValue JSON where
+    coerceVariableValue _ (JSON Aeson.Null) = Just Type.Null
+    coerceVariableValue (In.ScalarBaseType scalarType) (JSON 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 = -- ID or Int
+            Type.Int <$> toBoundedInteger numberValue
+    coerceVariableValue (In.EnumBaseType _) (JSON (Aeson.String stringValue)) =
+        Just $ Type.Enum stringValue
+    coerceVariableValue (In.InputObjectBaseType objectType) (JSON value)
+        | (Aeson.Object objectValue) <- value = do
+            let (In.InputObjectType _ _ inputFields) = objectType
+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+            if KeyMap.null newObjectValue
+                then Just $ Type.Object resultMap
+                else Nothing
+      where
+        foldWithKey :: Aeson.Object
+            -> HashMap Name In.InputField
+            -> Maybe (Aeson.Object, HashMap Name Type.Value)
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
+            $ Just (objectValue, HashMap.empty)
+        matchFieldValues' :: Text
+            -> In.InputField
+            -> Maybe (Aeson.Object, HashMap Name Type.Value)
+            -> Maybe (Aeson.Object, HashMap Name Type.Value)
+        matchFieldValues' _ _ Nothing = Nothing
+        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
+            let fieldKey = Aeson.Key.fromText fieldName
+                In.InputField _ fieldType _ = inputField
+                insert = flip (HashMap.insert fieldName) resultMap
+                newObjectValue = KeyMap.delete fieldKey objectValue
+             in case KeyMap.lookup fieldKey objectValue of
+                    Just variableValue -> do
+                        coerced <- coerceVariableValue fieldType
+                            $ JSON variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (In.ListBaseType listType) (JSON value)
+        | (Aeson.Array arrayValue) <- value =
+            Type.List <$> foldr foldVector (Just []) arrayValue
+        | otherwise = coerceVariableValue listType $ JSON value
+      where
+        foldVector _ Nothing = Nothing
+        foldVector variableValue (Just list) = do
+            coerced <- coerceVariableValue listType $ JSON variableValue
+            pure $ coerced : list
+    coerceVariableValue _ _ = Nothing
+
+-- | If the text parses correctly as a @GraphQL@ query the query is
+-- executed using the given 'Schema'.
+graphql :: MonadCatch m
+    => Schema m -- ^ Resolvers.
+    -> Maybe Text -- ^ Operation name.
+    -> Aeson.Object -- ^ Variables.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
+graphql schema operationName variableValues = fmap (bimap stream formatResponse)
+    . GraphQL.graphql schema operationName jsonVariables
+  where
+    jsonVariables = JSON <$> KeyMap.toHashMapText variableValues
+    -- stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value
+    stream = Conduit.mapOutput mapResponse
+    mapResponse response@Response{ data' = JSON json } =
+        response{ data' = json }
+    formatResponse :: Response JSON -> Aeson.Object
+    formatResponse Response{ errors, data' = JSON json } =
+        let dataResponse = KeyMap.singleton "data" json
+         in case errors of
+              Seq.Empty -> dataResponse
+              _ -> flip (KeyMap.insert "errors") dataResponse
+                  $ Aeson.Array $ foldr fromError mempty errors
+    fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value
+    fromError Error{..} = Vector.cons $ Aeson.object $ catMaybes
+        [ Just ("message", Aeson.String message)
+        , toMaybe fromLocation "locations" locations
+        , toMaybe fromPath "path" path
+        ]
+    fromPath (Segment segment) = Aeson.String segment
+    fromPath (Index index) = Aeson.toJSON index
+    fromLocation Location{..} = Aeson.object
+        [ ("line", Aeson.toJSON line)
+        , ("column", Aeson.toJSON column)
+        ]
+    toMaybe _ _ [] = Nothing
+    toMaybe f key xs = Just (key, Aeson.listValue f xs)

src/Language/GraphQL/Resolver.hs

@@ -0,0 +1,63 @@
+{- 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 #-}
+
+-- | Helper functions and exceptions to write resolvers.
+module Language.GraphQL.Resolver
+    ( ServerException(..)
+    , argument
+    , defaultResolver
+    ) where
+
+import Control.Monad.Catch (Exception(..), MonadCatch(..), MonadThrow(..))
+import Control.Monad.Trans.Reader (ReaderT, asks)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Typeable (cast)
+import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.Error
+import qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Class (FromGraphQL(..))
+
+-- | Exceptions thrown by the functions in this module.
+data ServerException
+    = FieldNotResolvedException !Text
+    | ErroneousArgumentTypeException !Text
+
+instance Show ServerException where
+    show (FieldNotResolvedException fieldName) =
+        Text.unpack $ Text.unwords ["Field", fieldName, "not resolved."]
+    show (ErroneousArgumentTypeException argumentName) =
+        Text.unpack $ Text.unwords
+            [ "Unable to convert the argument"
+            , argumentName
+            , "to a user-defined type."
+            ]
+
+instance Exception ServerException where
+    toException = toException . ResolverException
+    fromException x = do
+        ResolverException a <- fromException x
+        cast a
+
+-- | Default resolver expects that the field value is returned by the parent
+-- object. If the parent is not an object or it doesn't contain the requested
+-- field name, an error is thrown.
+defaultResolver :: MonadCatch m => Name -> Type.Resolve m
+defaultResolver fieldName = do
+    values' <- asks Type.values
+    case values' of
+        Type.Object objectValue
+            | Just result <- HashMap.lookup fieldName objectValue -> pure result
+        _nonObject -> throwM $ FieldNotResolvedException fieldName
+
+-- | Takes an argument name, validates that the argument exists, and optionally
+-- converts it to a user-defined type.
+argument :: (MonadCatch m, FromGraphQL a) => Name -> ReaderT Type.Context m a
+argument argumentName =
+    Type.argument argumentName >>= maybe throwError pure . fromGraphQL
+  where
+    throwError = throwM $ ErroneousArgumentTypeException argumentName

src/Language/GraphQL/Serialize.hs

@@ -1,7 +0,0 @@
-module Language.GraphQL.Serialize
-    ( JSON(..)
-    ) where
-
-import qualified Data.Aeson as Aeson
-
-newtype JSON = JSON Aeson.Value

src/Test/Hspec/GraphQL.hs

@@ -0,0 +1,48 @@
+{- 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 ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+-- | Test helpers.
+module Test.Hspec.GraphQL
+    ( shouldResolve
+    , shouldResolveTo
+    ) where
+
+import Control.Monad.Catch (MonadCatch)
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
+import Language.GraphQL.Error
+import Language.GraphQL.Execute
+import Test.Hspec.Expectations
+    ( Expectation
+    , expectationFailure
+    , shouldBe
+    , shouldSatisfy
+    )
+
+-- | Asserts that a query resolves to some value.
+shouldResolveTo :: (MonadCatch m, Serialize b, Eq b, Show b)
+    => Either (ResponseEventStream m b) (Response b)
+    -> b
+    -> Expectation
+shouldResolveTo (Right Response{ errors = Seq.Empty, data' }) expected =
+    data' `shouldBe` expected
+shouldResolveTo _ _ = expectationFailure
+    "the query is expected to resolve to a value, but it resolved to an event stream"
+
+-- | Asserts that the response doesn't contain any errors.
+shouldResolve :: (MonadCatch m, Serialize b)
+    => (Text -> IO (Either (ResponseEventStream m b) (Response b)))
+    -> Text
+    -> Expectation
+shouldResolve executor query = do
+    actual <- executor query
+    case actual of
+        Right Response{ errors } -> errors `shouldSatisfy` Seq.null
+        _ -> expectationFailure
+            "the query is expected to resolve to a value, but it resolved to an event stream"

tests/Language/GraphQL/ClassSpec.hs

@@ -0,0 +1,174 @@
+{- 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 QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Language.GraphQL.ClassSpec
+    ( spec
+    ) where
+
+import Data.Text (Text)
+import Data.Time (UTCTime(..))
+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
+import qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Class
+    ( FromGraphQL(..)
+    , ToGraphQL(..)
+    , deriveFromGraphQL
+    , deriveToGraphQL
+    , gql
+    )
+import Test.Hspec (Spec, describe, it, shouldBe)
+import qualified Data.HashMap.Strict as HashMap
+
+data TwoFieldRecord = TwoFieldRecord
+    { x :: Int
+    , y :: Bool
+    } deriving (Eq, Show)
+
+$(deriveToGraphQL ''TwoFieldRecord)
+$(deriveFromGraphQL ''TwoFieldRecord)
+
+data TwoVariantUnion
+    = FirstVariantUnion TwoFieldRecord
+    | SecondVariantUnion TwoFieldRecord
+    deriving (Eq, Show)
+
+$(deriveToGraphQL ''TwoVariantUnion)
+
+newtype NewTypeRecord = NewTypeRecord { newTypeField :: Int }
+    deriving (Eq, Show)
+
+$(deriveToGraphQL ''NewTypeRecord)
+$(deriveFromGraphQL ''NewTypeRecord)
+
+data TwoFieldEnum = TWO_FIELD_ENUM_1 | TWO_FIELD_ENUM_2
+    deriving (Eq, Show)
+
+$(deriveToGraphQL ''TwoFieldEnum)
+$(deriveFromGraphQL ''TwoFieldEnum)
+
+spec :: Spec
+spec = do
+    describe "ToGraphQL" $ do
+        it "converts integers" $
+            toGraphQL (5 :: Int) `shouldBe` Type.Int 5
+
+        it "converts text" $
+            toGraphQL ("String" :: Text) `shouldBe` Type.String "String"
+
+        it "converts booleans" $
+            toGraphQL True `shouldBe` Type.Boolean True
+
+        it "converts Nothing to Null" $
+            toGraphQL (Nothing :: Maybe Int) `shouldBe` Type.Null
+
+        it "converts singleton lists" $
+            toGraphQL [True] `shouldBe` Type.List [Type.Boolean True]
+
+        it "converts UTCTime" $
+            let given = UTCTime
+                    { utctDay = fromOrdinalDate 2023 5
+                    , utctDayTime = 90
+                    }
+                actual = toGraphQL given
+                expected = Type.String "2023-01-05T00:01:30Z"
+             in actual `shouldBe` expected
+
+    describe "FromGraphQL" $ do
+        it "converts integers" $
+            fromGraphQL (Type.Int 5) `shouldBe` Just (5 :: Int)
+
+        it "converts text" $
+            fromGraphQL (Type.String "String") `shouldBe` Just ("String" :: Text)
+
+        it "converts booleans" $
+            fromGraphQL (Type.Boolean True) `shouldBe` Just True
+
+        it "converts Null to Nothing" $
+            fromGraphQL Type.Null `shouldBe` Just (Nothing :: Maybe Int)
+
+        it "converts singleton lists" $
+            fromGraphQL (Type.List [Type.Boolean True]) `shouldBe` Just [True]
+
+        it "converts UTCTime" $
+            let given = Type.String "2023-01-05T00:01:30Z"
+                expected = Just $ UTCTime
+                    { utctDay = fromOrdinalDate 2023 5
+                    , utctDayTime = 90
+                    }
+                actual = fromGraphQL given
+             in actual `shouldBe` expected
+
+    describe "deriveToGraphQL" $ do
+        it "derives ToGraphQL for a record with multiple fields" $
+            let expected = Type.Object $ HashMap.fromList
+                    [ ("x", Type.Int 1)
+                    , ("y", Type.Boolean True)
+                    , ("__typename", Type.String "TwoFieldRecord")
+                    ]
+                given = TwoFieldRecord
+                    { x = 1
+                    , y = True
+                    }
+             in toGraphQL given `shouldBe` expected
+
+        it "derives ToGraphQL for a union" $
+            let expected = Type.Object $ HashMap.fromList
+                    [ ("x", Type.Int 2)
+                    , ("y", Type.Boolean False)
+                    , ("__typename", Type.String "TwoFieldRecord")
+                    ]
+                given = SecondVariantUnion $ TwoFieldRecord
+                    { x = 2
+                    , y = False
+                    }
+             in toGraphQL given `shouldBe` expected
+
+        it "derives ToGraphQL for a newtype record" $
+            let expected = Type.Object $ HashMap.fromList
+                    [ ("newTypeField", Type.Int 3)
+                    , ("__typename", Type.String "NewTypeRecord")
+                    ]
+                given = NewTypeRecord 3
+             in toGraphQL given `shouldBe` expected
+
+        it "derives ToGraphQL for an enumeration" $
+            let expected = Type.Enum "TWO_FIELD_ENUM_2"
+                given = TWO_FIELD_ENUM_2
+             in toGraphQL given `shouldBe` expected
+
+    describe "deriveFromGraphQL" $ do
+        it "derives FromGraphQL for a record with multiple fields" $
+            let given = Type.Object $ HashMap.fromList
+                    [ ("x", Type.Int 1)
+                    , ("y", Type.Boolean True)
+                    ]
+                expected = TwoFieldRecord
+                    { x = 1
+                    , y = True
+                    }
+             in fromGraphQL given `shouldBe` Just expected
+
+        it "derives FromGraphQL for a newtype record" $
+            let given = Type.Object $ HashMap.singleton "newTypeField" (Type.Int 3)
+                expected = NewTypeRecord 3
+             in fromGraphQL given `shouldBe` Just expected
+
+        it "derives FromGraphQL for an enumeration" $
+            let given = Type.Enum "TWO_FIELD_ENUM_2"
+                expected = TWO_FIELD_ENUM_2
+             in fromGraphQL given `shouldBe` Just expected
+
+    describe "gql" $
+        it "replaces CRNL with NL" $
+            let expected :: Text
+                expected = "line1\nline2\nline3"
+                actual = [gql|
+                  line1
+                  line2
+                  line3
+                |]
+             in actual `shouldBe` expected

tests/Language/GraphQL/CoerceSpec.hs

@@ -0,0 +1,98 @@
+{- 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 #-}
+module Language.GraphQL.CoerceSpec
+    ( spec
+    ) where
+
+import Data.Aeson as Aeson ((.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (isNothing)
+import Data.Scientific (scientific)
+import qualified Language.GraphQL.Execute.Coerce as Coerce
+import Language.GraphQL.JSON (JSON(..))
+import qualified Language.GraphQL.Type.In as In
+import Language.GraphQL.Type
+import Prelude hiding (id)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
+
+singletonInputObject :: In.Type
+singletonInputObject = In.NamedInputObjectType type'
+  where
+    type' = In.InputObjectType "ObjectName" Nothing inputFields
+    inputFields = HashMap.singleton "field" field
+    field = In.InputField Nothing (In.NamedScalarType string) Nothing
+
+namedIdType :: In.Type
+namedIdType = In.NamedScalarType id
+
+spec :: Spec
+spec =
+    describe "VariableValue Aeson" $ do
+        it "coerces strings" $
+            let expected = Just (String "asdf")
+                actual = Coerce.coerceVariableValue (In.NamedScalarType string)
+                    $ JSON $ Aeson.String "asdf"
+             in actual `shouldBe` expected
+        it "coerces non-null strings" $
+            let expected = Just (String "asdf")
+                actual = Coerce.coerceVariableValue (In.NonNullScalarType string)
+                    $ JSON $ Aeson.String "asdf"
+             in actual `shouldBe` expected
+        it "coerces booleans" $
+            let expected = Just (Boolean True)
+                actual = Coerce.coerceVariableValue (In.NamedScalarType boolean)
+                    $ JSON $ Aeson.Bool True
+             in actual `shouldBe` expected
+        it "coerces zero to an integer" $
+            let expected = Just (Int 0)
+                actual = Coerce.coerceVariableValue (In.NamedScalarType int)
+                    $ JSON $ Aeson.Number 0
+             in actual `shouldBe` expected
+        it "rejects fractional if an integer is expected" $
+            let actual = Coerce.coerceVariableValue (In.NamedScalarType int)
+                    $ JSON $ Aeson.Number $ scientific 14 (-1)
+             in actual `shouldSatisfy` isNothing
+        it "coerces float numbers" $
+            let expected = Just (Float 1.4)
+                actual = Coerce.coerceVariableValue (In.NamedScalarType float)
+                    $ JSON $ Aeson.Number $ scientific 14 (-1)
+             in actual `shouldBe` expected
+        it "coerces IDs" $
+            let expected = Just (String "1234")
+                json = JSON $ Aeson.String "1234"
+                actual = Coerce.coerceVariableValue namedIdType json
+             in actual `shouldBe` expected
+        it "coerces input objects" $
+            let actual = Coerce.coerceVariableValue singletonInputObject
+                    $ JSON
+                    $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
+                expected = Just $ Object $ HashMap.singleton "field" "asdf"
+             in actual `shouldBe` expected
+        it "skips the field if it is missing in the variables" $
+            let actual = Coerce.coerceVariableValue singletonInputObject
+                    $ JSON Aeson.emptyObject
+                expected = Just $ Object HashMap.empty
+             in actual `shouldBe` expected
+        it "fails if input object value contains extra fields" $
+            let actual = Coerce.coerceVariableValue singletonInputObject
+                    $ JSON $ Aeson.object variableFields
+                variableFields =
+                    [ "field" .= ("asdf" :: Aeson.Value)
+                    , "extra" .= ("qwer" :: Aeson.Value)
+                    ]
+             in actual `shouldSatisfy` isNothing
+        it "preserves null" $
+            let actual = Coerce.coerceVariableValue namedIdType
+                    $ JSON Aeson.Null
+             in actual `shouldBe` Just Null
+        it "preserves list order" $
+            let list = JSON $ Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
+                listType = (In.ListType $ In.NamedScalarType string)
+                actual = Coerce.coerceVariableValue listType list
+                expected = Just $ List [String "asdf", String "qwer"]
+             in actual `shouldBe` expected

tests/Language/GraphQL/DirectiveSpec.hs

@@ -4,19 +4,21 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 module Language.GraphQL.DirectiveSpec
     ( spec
     ) where
 
-import Data.Aeson (object, (.=))
+import Language.GraphQL.AST.Document (Name)
-import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.Foundation
+import qualified Language.GraphQL as GraphQL
 import Language.GraphQL.TH
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
 import Test.Hspec (Spec, describe, it)
-import Test.Hspec.GraphQL
+import "graphql-spice" Test.Hspec.GraphQL
 
 experimentalResolver :: Schema IO
 experimentalResolver = schema queryType Nothing Nothing mempty
@@ -26,9 +28,6 @@ experimentalResolver = schema queryType Nothing Nothing mempty
         $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 5
 
-emptyObject :: Aeson.Object
-emptyObject = HashMap.singleton "data" $ object []
-
 spec :: Spec
 spec =
     describe "Directive executor" $ do
@@ -39,8 +38,8 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver sourceQuery
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual `shouldResolveTo` Object mempty
 
         it "should not skip fields if @skip is false" $ do
             let sourceQuery = [gql|
@@ -48,11 +47,8 @@ spec =
                 experimentalField @skip(if: false)
               }
             |]
-                expected = HashMap.singleton "data"
+                expected = Object $ HashMap.singleton "experimentalField" (Int 5)
-                    $ object
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
-                        [ "experimentalField" .= (5 :: Int)
-                        ]
-            actual <- graphql experimentalResolver sourceQuery
             actual `shouldResolveTo` expected
 
         it "should skip fields if @include is false" $ do
@@ -62,8 +58,8 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver sourceQuery
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual `shouldResolveTo` Object mempty
 
         it "should be able to @skip a fragment spread" $ do
             let sourceQuery = [gql|
@@ -76,8 +72,8 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver sourceQuery
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual `shouldResolveTo` Object mempty
 
         it "should be able to @skip an inline fragment" $ do
             let sourceQuery = [gql|
@@ -88,5 +84,5 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver sourceQuery
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual `shouldResolveTo` Object mempty

tests/Language/GraphQL/FragmentSpec.hs

@@ -4,20 +4,23 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 module Language.GraphQL.FragmentSpec
     ( spec
     ) where
 
-import Data.Aeson ((.=))
-import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
-import Language.GraphQL.Foundation
+import Language.GraphQL.AST (Name)
+import Data.HashMap.Strict (HashMap)
 import Language.GraphQL.Type
+import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.TH
+import qualified Language.GraphQL as GraphQL
 import Test.Hspec (Spec, describe, it)
-import Test.Hspec.GraphQL
+import "graphql-spice" Test.Hspec.GraphQL
 
 size :: (Text, Value)
 size = ("size", String "L")
@@ -88,23 +91,23 @@ spec :: Spec
 spec = do
     describe "Inline fragment executor" $ do
         it "chooses the first selection if the type matches" $ do
-            actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
+            let localSchema = toSchema "Hat" $ garment "Hat"
-            let expected = HashMap.singleton "data"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) inlineQuery
-                    $ Aeson.object
+            let expected = Object
-                        [ "garment" .= Aeson.object
+                    $ HashMap.singleton "garment"
-                            [ "circumference" .= (60 :: Int)
+                    $ Object
-                            ]
+                    $ HashMap.singleton  "circumference"
-                        ]
+                    $ Int 60
              in actual `shouldResolveTo` expected
 
         it "chooses the last selection if the type matches" $ do
-            actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
+            let localSchema = toSchema "Shirt" $ garment "Shirt"
-            let expected = HashMap.singleton "data"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) inlineQuery
-                    $ Aeson.object
+            let expected = Object
-                        [ "garment" .= Aeson.object
+                    $ HashMap.singleton "garment"
-                            [ "size" .= ("L" :: Text)
+                    $ Object
-                            ]
+                    $ HashMap.singleton "size"
-                        ]
+                    $ String "L"
              in actual `shouldResolveTo` expected
 
         it "embeds inline fragments without type" $ do
@@ -116,12 +119,12 @@ spec = do
                 }
               }
             |]
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
+            let localSchema = toSchema "circumference" circumference
-            let expected = HashMap.singleton "data"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
-                    $ Aeson.object
+            let expected = Object $ HashMap.fromList
-                        [ "circumference" .= (60 :: Int)
+                    [ ("circumference", Int 60)
-                        , "size" .= ("L" :: Text)
+                    , ("size", String  "L")
-                        ]
+                    ]
              in actual `shouldResolveTo` expected
 
         it "evaluates fragments on Query" $ do
@@ -132,7 +135,10 @@ spec = do
                 }
               }
             |]
-             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
+                localSchema = toSchema "size" size
+                actual :: Text -> IO (Either (ResponseEventStream IO Value) (Response Value))
+                actual = GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value)
+             in actual `shouldResolve` sourceQuery
 
     describe "Fragment spread executor" $ do
         it "evaluates fragment spreads" $ do
@@ -145,12 +151,11 @@ spec = do
                 circumference
               }
             |]
-
+            let localSchema = toSchema "circumference" circumference
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
-            let expected = HashMap.singleton "data"
+            let expected = Object
-                    $ Aeson.object
+                    $ HashMap.singleton "circumference"
-                        [ "circumference" .= (60 :: Int)
+                    $ Int 60
-                        ]
              in actual `shouldResolveTo` expected
 
         it "evaluates nested fragments" $ do
@@ -169,14 +174,13 @@ spec = do
                 circumference
               }
             |]
-
+            let localSchema = toSchema "Hat" $ garment "Hat"
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
-            let expected = HashMap.singleton "data"
+            let expected = Object
-                    $ Aeson.object
+                    $ HashMap.singleton "garment"
-                        [ "garment" .= Aeson.object
+                    $ Object
-                            [ "circumference" .= (60 :: Int)
+                    $ HashMap.singleton "circumference"
-                            ]
+                    $ Int 60
-                        ]
              in actual `shouldResolveTo` expected
 
         it "considers type condition" $ do
@@ -194,11 +198,11 @@ spec = do
                 size
               }
             |]
-                expected = HashMap.singleton "data"
+                expected = Object
-                    $ Aeson.object
+                    $ HashMap.singleton "garment"
-                        [ "garment" .= Aeson.object
+                    $ Object
-                            [ "circumference" .= (60 :: Int)
+                    $ HashMap.singleton "circumference"
-                            ]
+                    $ Int 60
-                        ]
+            let localSchema = toSchema "Hat" $ garment "Hat"
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
             actual `shouldResolveTo` expected

tests/Language/GraphQL/RootOperationSpec.hs

@@ -4,18 +4,21 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 module Language.GraphQL.RootOperationSpec
     ( spec
     ) where
 
-import Data.Aeson ((.=), object)
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.Foundation
+import Language.GraphQL
+import Language.GraphQL.AST (Name)
 import Test.Hspec (Spec, describe, it)
 import Language.GraphQL.TH
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec.GraphQL
+import "graphql-spice" Test.Hspec.GraphQL
 
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
@@ -49,13 +52,12 @@ spec =
                 }
               }
             |]
-                expected = HashMap.singleton "data"
+                expected = Object
-                    $ object
+                    $ HashMap.singleton "garment"
-                        [ "garment" .= object
+                    $ Object
-                            [ "circumference" .= (60 :: Int)
+                    $ HashMap.singleton "circumference"
-                            ]
+                    $ Int 60
-                        ]
+            actual <- graphql garmentSchema Nothing (mempty :: HashMap Name Value) querySource
-            actual <- graphql garmentSchema querySource
             actual `shouldResolveTo` expected
 
         it "chooses Mutation" $ do
@@ -64,9 +66,8 @@ spec =
                 incrementCircumference
               }
             |]
-                expected = HashMap.singleton "data"
+                expected = Object
-                    $ object
+                    $ HashMap.singleton "incrementCircumference"
-                        [ "incrementCircumference" .= (61 :: Int)
+                    $ Int 61
-                        ]
+            actual <- graphql garmentSchema Nothing (mempty :: HashMap Name Value) querySource
-            actual <- graphql garmentSchema querySource
             actual `shouldResolveTo` expected