Add deriveToGraphQL

… for deriving `ToGraphQL` instances automatically.

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)|]
+        ]