Add `deriveToGraphQL`

… for deriving `ToGraphQL` instances automatically.

4 files changed, 125 insertions, 3 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 563c304..656fe5a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,10 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [Unreleased]
+### Added
+- Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically.
+
 ## [1.0.2.0] - 2023-07-07
 ### Added
 - `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`,
@@ -26,5 +30,6 @@ and this project adheres to
 - JSON serialization.
 - Test helpers.
 
+[Unreleased]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.2.0...master
 [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
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index 61d02ab..adcfe28 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -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,
diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs
index 8062277..2f5d6ff 100644
--- a/src/Language/GraphQL/Class.hs
+++ b/src/Language/GraphQL/Class.hs
@@ -3,22 +3,23 @@
    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(..)
+    , 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 +39,38 @@ 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
+    )
+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 +302,64 @@ instance FromGraphQL TimeOfDay
 instance FromGraphQL LocalTime
   where
     fromGraphQL = fromGraphQLToISO8601
+
+stringLE :: Name -> Q Exp
+stringLE = litE . stringL . nameBase
+
+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 records with a single data constructor are supported"
+  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 "Enum member should be a normal constructor without parameters"
+    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)|]
+        ]
diff --git a/tests/Language/GraphQL/ClassSpec.hs b/tests/Language/GraphQL/ClassSpec.hs
index a5ed41f..9e98905 100644
--- a/tests/Language/GraphQL/ClassSpec.hs
+++ b/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,16 @@ 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(..), deriveToGraphQL)
 import Test.Hspec (Spec, describe, it, shouldBe)
+import qualified Data.HashMap.Strict as HashMap
+
+data TwoFieldRecord = TwoFieldRecord
+    { x :: Int
+    , y :: Bool
+    }
+
+$(deriveToGraphQL ''TwoFieldRecord)
 
 spec :: Spec
 spec = do
@@ -65,3 +74,16 @@ spec = do
                     }
                 actual = fromGraphQL given
              in actual `shouldBe` expected
+
+    describe "deriveToGraphQL" $ do
+        it "derives ToGraphQL for a record" $ do
+            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