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,6 +6,21 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [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`,
@@ -26,5 +41,8 @@ and this project adheres to
 - 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

graphql-spice.cabal

@@ -1,7 +1,7 @@
-cabal-version:      2.4
+cabal-version:      3.0
 
 name:               graphql-spice
-version:            1.0.2.0
+version:            1.0.5.0
 synopsis:           GraphQL with batteries
 description:        Various extensions and convenience functions for the core
                     graphql package.
@@ -10,13 +10,13 @@ homepage:           https://git.caraus.tech/OSS/graphql-spice
 bug-reports:        https://git.caraus.tech/OSS/graphql-spice/issues
 author:             Eugen Wissner <belka@caraus.de>
 maintainer:         belka@caraus.de
-copyright:          (c) 2021-2023 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 == 9.2.8
+  GHC == 9.8.2
 
 source-repository head
   type: git
@@ -35,14 +35,15 @@ library
       aeson >= 2.0.3 && < 2.3,
       base >= 4.7 && < 5,
       conduit ^>= 1.3.4,
-      containers ^>= 0.6.2,
+      containers >= 0.6 && < 0.8,
       exceptions ^>= 0.10.4,
       hspec-expectations >= 0.8.2 && < 0.9,
-      graphql >= 1.2,
+      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.11.1,
+      time >= 1.12.2 && < 1.15,
       transformers >= 0.5.6 && < 0.7,
       vector >= 0.12 && < 0.14,
       unordered-containers ^>= 0.2.16
@@ -70,4 +71,6 @@ test-suite graphql-test
     text,
     time,
     unordered-containers
+  build-tool-depends:
+    hspec-discover:hspec-discover
   default-language: Haskell2010

src/Language/GraphQL/Class.hs

@@ -3,22 +3,26 @@
    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.Foldable (toList)
 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 qualified Language.GraphQL.Type as Type
 import Data.Scientific (Scientific, toRealFloat)
 import qualified Data.Text as Text
 import Data.Time
@@ -38,6 +42,44 @@ import Data.Time.Format.ISO8601
     , 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
@@ -60,6 +102,10 @@ class ToGraphQL a
   where
     toGraphQL :: a -> Type.Value
 
+instance ToGraphQL Type.Value
+  where
+    toGraphQL a = a
+
 instance ToGraphQL Text
   where
     toGraphQL = Type.String
@@ -157,12 +203,20 @@ 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
@@ -269,3 +323,175 @@ instance FromGraphQL TimeOfDay
 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)"
+    }

tests/Language/GraphQL/ClassSpec.hs

@@ -3,6 +3,8 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Language.GraphQL.ClassSpec
     ( spec
     ) where
@@ -11,8 +13,42 @@ 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(..))
+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
@@ -65,3 +101,74 @@ spec = do
                     }
                 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