Put JSON support behind a flag

CHANGELOG.md

@@ -10,6 +10,8 @@ and this project adheres to
 ### Added
 - `Serialize` instance for `Type.Definition.Value`.
 - `VariableValue` instance for `Type.Definition.Value`.
+- `Json` build flag, enabled by default. JSON and Aeson support can be disabled
+  by disabling this flag.
 
 ## [1.0.1.0] - 2021-09-27
 ### Added

graphql.cabal

@@ -28,6 +28,11 @@ source-repository head
   type: git
   location: git://caraus.tech/pub/graphql.git
 
+flag Json
+  description: Whether to build against @aeson 1.x@
+  default: True
+  manual: True
+
 library
   exposed-modules:
     Language.GraphQL
@@ -57,8 +62,8 @@ library
   hs-source-dirs:
     src
   ghc-options: -Wall
+
   build-depends:
-    aeson >= 1.5.6 && < 1.6,
     base >= 4.7 && < 5,
     conduit >= 1.3.4 && < 1.4,
     containers >= 0.6.2 && < 0.7,
@@ -66,12 +71,17 @@ library
     hspec-expectations >= 0.8.2 && < 0.9,
     megaparsec >= 9.0.1 && < 9.1,
     parser-combinators >= 1.3.0 && < 1.4,
-    scientific >= 0.3.7 && < 0.4,
     template-haskell >= 2.16 && < 2.18,
     text >= 1.2.4 && < 1.3,
     transformers >= 0.5.6 && < 0.6,
     unordered-containers >= 0.2.14 && < 0.3,
     vector >= 0.12.3 && < 0.13
+  if flag(Json)
+    build-depends:
+      aeson >= 1.5.6 && < 1.6,
+      scientific >= 0.3.7 && < 0.4
+    cpp-options: -DWITH_JSON
+
   default-language: Haskell2010
 
 test-suite graphql-test
@@ -91,9 +101,9 @@ test-suite graphql-test
   hs-source-dirs:
     tests
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+
   build-depends:
     QuickCheck >= 2.14.1 && < 2.15,
-    aeson,
     base >= 4.8 && < 5,
     conduit,
     exceptions,
@@ -101,7 +111,6 @@ test-suite graphql-test
     hspec >= 2.9.1 && < 3,
     hspec-megaparsec >= 2.2.0 && < 2.3,
     megaparsec,
-    scientific,
     text,
     unordered-containers
   default-language: Haskell2010

src/Language/GraphQL.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE CPP #-}
+
+#ifdef WITH_JSON
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -73,3 +76,9 @@ graphqlSubs schema operationName variableValues document' =
         [ ("line", Aeson.toJSON line)
         , ("column", Aeson.toJSON column)
         ]
+#else
+-- | This module provides the functions to parse and execute @GraphQL@ queries.
+module Language.GraphQL
+    (
+    ) where
+#endif

src/Language/GraphQL/Execute/Coerce.hs

@@ -3,9 +3,9 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
 
 -- | Types and functions used for input and result coercion.
 module Language.GraphQL.Execute.Coerce
@@ -16,7 +16,10 @@ module Language.GraphQL.Execute.Coerce
     , matchFieldValues
     ) where
 
+#ifdef WITH_JSON
 import qualified Data.Aeson as Aeson
+import Data.Scientific (toBoundedInteger, toRealFloat)
+#endif
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -25,7 +28,6 @@ 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 Language.GraphQL.Execute.OrderedMap (OrderedMap)
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@@ -63,22 +65,12 @@ class VariableValue a where
         -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
 
 instance VariableValue Type.Value where
-    coerceVariableValue = const Just
+    coerceVariableValue _ Type.Null = Just Type.Null
-
+    coerceVariableValue (In.ScalarBaseType _) value = Just value
-instance VariableValue Aeson.Value where
+    coerceVariableValue (In.EnumBaseType _) (Type.Enum stringValue) =
-    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 = -- ID or Int
-            Type.Int <$> toBoundedInteger numberValue
-    coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
         Just $ Type.Enum stringValue
     coerceVariableValue (In.InputObjectBaseType objectType) value
-        | (Aeson.Object objectValue) <- value = do
+        | (Type.Object objectValue) <- value = do
             let (In.InputObjectType _ _ inputFields) = objectType
             (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
             if HashMap.null newObjectValue
@@ -98,14 +90,9 @@ instance VariableValue Aeson.Value where
                         pure (newObjectValue, insert coerced)
                     Nothing -> Just (objectValue, resultMap)
     coerceVariableValue (In.ListBaseType listType) value
-        | (Aeson.Array arrayValue) <- value =
+        | (Type.List arrayValue) <- value =
-            Type.List <$> foldr foldVector (Just []) arrayValue
+            Type.List <$> traverse (coerceVariableValue listType) arrayValue
         | otherwise = coerceVariableValue listType value
-      where
-        foldVector _ Nothing = Nothing
-        foldVector variableValue (Just list) = do
-            coerced <- coerceVariableValue listType variableValue
-            pure $ coerced : list 
     coerceVariableValue _ _ = Nothing
 
 -- | Looks up a value by name in the given map, coerces it and inserts into the
@@ -222,18 +209,26 @@ instance forall a. IsString (Output a) where
 
 instance Serialize Type.Value where
     null = Type.Null
-    serialize _ = \case
+    serialize (Out.ScalarBaseType scalarType) value
-        Int int -> Just $ Type.Int int
+        | Type.ScalarType "Int" _ <- scalarType
-        Float float -> Just $ Type.Float float
+        , Int int <- value = Just $ Type.Int int
-        String string -> Just $ Type.String string
+        | Type.ScalarType "Float" _ <- scalarType
-        Boolean boolean -> Just $ Type.Boolean boolean
+        , Float float <- value = Just $ Type.Float float
-        Enum enum -> Just $ Type.Enum enum
+        | Type.ScalarType "String" _ <- scalarType
-        List list -> Just $ Type.List list
+        , String string <- value = Just $ Type.String string
-        Object object -> Just
+        | Type.ScalarType "ID" _ <- scalarType
+        , String string <- value = Just $ Type.String string
+        | Type.ScalarType "Boolean" _ <- scalarType
+        , Boolean boolean <- value = Just $ Type.Boolean boolean
+    serialize _ (Enum enum) = Just $ Type.Enum enum
+    serialize _ (List list) = Just $ Type.List list
+    serialize _ (Object object) = Just
         $ Type.Object
         $ HashMap.fromList
         $ OrderedMap.toList object
+    serialize _ _ = Nothing
 
+#ifdef WITH_JSON
 instance Serialize Aeson.Value where
     serialize (Out.ScalarBaseType scalarType) value
         | Type.ScalarType "Int" _ <- scalarType
@@ -254,3 +249,47 @@ instance Serialize Aeson.Value where
         $ Aeson.toJSON <$> object
     serialize _ _ = Nothing
     null = Aeson.Null
+
+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 = -- ID or Int
+            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
+#endif

src/Test/Hspec/GraphQL.hs

@@ -2,6 +2,9 @@
    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 CPP #-}
+
+#ifdef WITH_JSON
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -39,3 +42,8 @@ shouldResolve executor query = do
             response `shouldNotSatisfy` HashMap.member "errors"
         _ -> expectationFailure
             "the query is expected to resolve to a value, but it resolved to an event stream"
+#else
+module Test.Hspec.GraphQL
+    (
+    ) where
+#endif

tests/Language/GraphQL/ErrorSpec.hs

@@ -7,9 +7,9 @@ module Language.GraphQL.ErrorSpec
     ( spec
     ) where
 
-import qualified Data.Aeson as Aeson
 import Data.List.NonEmpty (NonEmpty (..))
 import Language.GraphQL.Error
+import qualified Language.GraphQL.Type as Type
 import Test.Hspec
     ( Spec
     , describe
@@ -31,6 +31,6 @@ spec = describe "parseError" $
                 , pstateTabWidth = mkPos 1
                 , pstateLinePrefix = ""
                 }
-        Response Aeson.Null actual <-
+        Response Type.Null actual <-
             parseError (ParseErrorBundle parseErrors posState)
         length actual `shouldBe` 1

tests/Language/GraphQL/Execute/CoerceSpec.hs

@@ -7,12 +7,8 @@ module Language.GraphQL.Execute.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.Type
 import qualified Language.GraphQL.Type.In as In
@@ -27,81 +23,11 @@ direction = EnumType "Direction" Nothing  $ HashMap.fromList
     , ("WEST", EnumValue Nothing)
     ]
 
-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 = do
+spec =
-    describe "VariableValue Aeson" $ do
-        it "coerces strings" $
-            let expected = Just (String "asdf")
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType string) (Aeson.String "asdf")
-             in actual `shouldBe` expected
-        it "coerces non-null strings" $
-            let expected = Just (String "asdf")
-                actual = Coerce.coerceVariableValue
-                    (In.NonNullScalarType string) (Aeson.String "asdf")
-             in actual `shouldBe` expected
-        it "coerces booleans" $
-            let expected = Just (Boolean True)
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType boolean) (Aeson.Bool True)
-             in actual `shouldBe` expected
-        it "coerces zero to an integer" $
-            let expected = Just (Int 0)
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType int) (Aeson.Number 0)
-             in actual `shouldBe` expected
-        it "rejects fractional if an integer is expected" $
-            let actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType int) (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) (Aeson.Number $ scientific 14 (-1))
-             in actual `shouldBe` expected
-        it "coerces IDs" $
-            let expected = Just (String "1234")
-                json = Aeson.String "1234"
-                actual = Coerce.coerceVariableValue namedIdType json
-             in actual `shouldBe` expected
-        it "coerces input objects" $
-            let actual = Coerce.coerceVariableValue singletonInputObject
-                    $ 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 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
-                    $ Aeson.object variableFields
-                variableFields =
-                    [ "field" .= ("asdf" :: Aeson.Value)
-                    , "extra" .= ("qwer" :: Aeson.Value)
-                    ]
-             in actual `shouldSatisfy` isNothing
-        it "preserves null" $
-            let actual = Coerce.coerceVariableValue namedIdType Aeson.Null
-             in actual `shouldBe` Just Null
-        it "preserves list order" $
-            let list = 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
-
     describe "coerceInputLiteral" $ do
         it "coerces enums" $
             let expected = Just (Enum "NORTH")

tests/Language/GraphQL/ExecuteSpec.hs

@@ -10,9 +10,6 @@ module Language.GraphQL.ExecuteSpec
 
 import Control.Exception (Exception(..), SomeException)
 import Control.Monad.Catch (throwM)
-import Data.Aeson ((.=))
-import qualified Data.Aeson as Aeson
-import Data.Aeson.Types (emptyObject)
 import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -189,12 +186,12 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
     ]
 
 type EitherStreamOrValue = Either
-    (ResponseEventStream (Either SomeException) Aeson.Value)
+    (ResponseEventStream (Either SomeException) Value)
-    (Response Aeson.Value)
+    (Response Value)
 
 execute' :: Document -> Either SomeException EitherStreamOrValue
 execute' =
-    execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
+    execute philosopherSchema Nothing (mempty :: HashMap Name Value)
 
 spec :: Spec
 spec =
@@ -209,28 +206,29 @@ spec =
                 ...cyclicFragment
               }
             |]
-                expected = Response emptyObject mempty
+                expected = Response (Object mempty) mempty
                 Right (Right actual) = either (pure . parseError) execute'
                     $ parse document "" sourceQuery
              in actual `shouldBe` expected
 
         context "Query" $ do
             it "skips unknown fields" $
-                let data'' = Aeson.object
+                let data'' = Object
-                        [ "philosopher" .= Aeson.object
+                        $ HashMap.singleton "philosopher"
-                            [ "firstName" .= ("Friedrich" :: String)
+                        $ Object
-                            ]
+                        $ HashMap.singleton "firstName"
-                        ]
+                        $ String "Friedrich"
                     expected = Response data'' mempty
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ philosopher { firstName surname } }"
                 in actual `shouldBe` expected
             it "merges selections" $
-                let data'' = Aeson.object
+                let data'' = Object
-                        [ "philosopher" .= Aeson.object
+                        $ HashMap.singleton "philosopher"
-                            [ "firstName" .= ("Friedrich" :: String)
+                        $ Object
-                            , "lastName" .= ("Nietzsche" :: String)
+                        $ HashMap.fromList
-                            ]
+                            [ ("firstName", String "Friedrich")
+                            , ("lastName", String "Nietzsche")
                             ]
                     expected = Response data'' mempty
                     Right (Right actual) = either (pure . parseError) execute'
@@ -238,9 +236,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "errors on invalid output enum values" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message =
                             "Value completion error. Expected type !School, found: EXISTENTIALISM."
@@ -253,9 +249,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for non-null unions" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message =
                             "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."
@@ -268,9 +262,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for invalid interfaces" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message
                             = "Value completion error. Expected type !Work, found:\
@@ -284,9 +276,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for invalid scalar arguments" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message =
                             "Argument \"id\" has invalid type. Expected type ID, found: True."
@@ -299,9 +289,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for failed result coercion" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message = "Unable to coerce result to !Int."
                         , locations = [Location 1 26]
@@ -313,9 +301,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for failed result coercion" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "genres" Null
-                        [ "genres" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message = "PhilosopherException"
                         , locations = [Location 1 3]
@@ -332,15 +318,13 @@ spec =
                         , locations = [Location 1 3]
                         , path = [Segment "count"]
                         }
-                    expected = Response Aeson.Null executionErrors
+                    expected = Response Null executionErrors
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ count }"
                 in actual `shouldBe` expected
 
             it "detects nullability errors" $
-                let data'' = Aeson.object
+                let data'' = Object $ HashMap.singleton "philosopher" Null
-                        [ "philosopher" .= Aeson.Null
-                        ]
                     executionErrors = pure $ Error
                         { message = "Value completion error. Expected type !String, found: null."
                         , locations = [Location 1 26]
@@ -353,11 +337,11 @@ spec =
 
         context "Subscription" $
             it "subscribes" $
-                let data'' = Aeson.object
+                let data'' = Object
-                        [ "newQuote" .= Aeson.object
+                        $ HashMap.singleton "newQuote"
-                            [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String)
+                        $ Object
-                            ]
+                        $ HashMap.singleton "quote"
-                        ]
+                        $ String "Naturam expelles furca, tamen usque recurret."
                     expected = Response data'' mempty
                     Right (Left stream) = either (pure . parseError) execute'
                         $ parse document "" "subscription { newQuote { quote } }"