Release 1.0.3.0

For deriving FromGraphQL instances automatically.

.gitea/workflows/build.yml

@@ -0,0 +1,31 @@
+name: Build
+
+on:
+  push:
+  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

CHANGELOG.md

@@ -6,6 +6,11 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [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 +31,6 @@ and this project adheres to
 - JSON serialization.
 - Test helpers.
 
+[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
 
 name:               graphql-spice
-version:            1.0.2.0
+version:            1.0.3.0
 synopsis:           GraphQL with batteries
 description:        Various extensions and convenience functions for the core
                     graphql package.
@@ -16,7 +16,7 @@ license-files:      LICENSE
 build-type:         Simple
 extra-source-files: CHANGELOG.md
 tested-with:
-  GHC == 9.2.8
+  GHC == 9.4.8
 
 source-repository head
   type: git
@@ -41,6 +41,7 @@ library
       graphql >= 1.2,
       megaparsec >= 9.0 && < 10,
       scientific ^>= 0.3.7,
+      template-haskell >= 2.16 && < 3,
       text >= 1.2 && < 3,
       time >= 1.11.1,
       transformers >= 0.5.6 && < 0.7,
@@ -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,24 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | ToGraphQL and FromGraphQL typeclasses used for user-defined type
 -- conversion.
 module Language.GraphQL.Class
     ( FromGraphQL(..)
     , ToGraphQL(..)
+    , deriveFromGraphQL
+    , deriveToGraphQL
     ) 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 +40,42 @@ import Data.Time.Format.ISO8601
     , iso8601Format
     , iso8601Show
     )
+import Language.Haskell.TH
+    ( Con(..)
+    , Dec(..)
+    , Exp(..)
+    , Info(..)
+    , 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 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
@@ -269,3 +307,134 @@ instance FromGraphQL TimeOfDay
 instance FromGraphQL LocalTime
   where
     fromGraphQL = fromGraphQLToISO8601
+
+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)|]
+        ]

tests/Language/GraphQL/ClassSpec.hs

@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Language.GraphQL.ClassSpec
     ( spec
     ) where
@@ -11,8 +12,41 @@ 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
+    )
 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 +99,63 @@ 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