Add deriveFromGraphQL

For deriving FromGraphQL instances automatically.

.gitea/workflows/build.yml

@@ -7,28 +7,14 @@ on:
 
 jobs:
   audit:
-    runs-on: haskell
+    runs-on: buildenv
     steps:
-      - name: Set up environment
-        run: |
-          apt-get update -y
-          apt-get upgrade -y
-          apt-get install -y nodejs pkg-config
       - uses: actions/checkout@v4
-      - name: Install dependencies
+      - run: hlint -- src tests
-        run: |
-          cabal update
-          cabal install hlint "--constraint=hlint ==3.8"
-      - run: cabal exec hlint -- src tests
 
   test:
-    runs-on: haskell
+    runs-on: buildenv
     steps:
-      - name: Set up environment
-        run: |
-          apt-get update -y
-          apt-get upgrade -y
-          apt-get install -y nodejs pkg-config
       - uses: actions/checkout@v4
       - name: Install dependencies
         run: cabal update
@@ -37,13 +23,8 @@ jobs:
       - run: cabal test --test-show-details=streaming
 
   doc:
-    runs-on: haskell
+    runs-on: buildenv
     steps:
-      - name: Set up environment
-        run: |
-          apt-get update -y
-          apt-get upgrade -y
-          apt-get install -y nodejs pkg-config
       - uses: actions/checkout@v4
       - name: Install dependencies
         run: cabal update

CHANGELOG.md

@@ -9,6 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically.
+- Add `deriveFromGraphQL`for deriving `FromGraphQL` instances automatically.
 
 ## [1.0.2.0] - 2023-07-07
 ### Added

src/Language/GraphQL/Class.hs

@@ -11,6 +11,7 @@
 module Language.GraphQL.Class
     ( FromGraphQL(..)
     , ToGraphQL(..)
+    , deriveFromGraphQL
     , deriveToGraphQL
     ) where
 
@@ -66,6 +67,10 @@ import Language.Haskell.TH
     , normalB
     , appE
     , mkName
+    , conE
+    , integerL
+    , litP
+    , wildP
     )
 import Data.Foldable (Foldable(..))
 import qualified Data.HashMap.Strict as HashMap
@@ -306,6 +311,57 @@ instance FromGraphQL LocalTime
 stringLE :: Name -> Q Exp
 stringLE = litE . stringL . nameBase
 
+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 records with a single data constructor are supported"
+  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
+
 deriveToGraphQL :: Name -> Q [Dec]
 deriveToGraphQL typeName = do
     TyConI plainConstructor <- reify typeName

tests/Language/GraphQL/ClassSpec.hs

@@ -12,16 +12,22 @@ 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(..), deriveToGraphQL)
+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)
 
 spec :: Spec
 spec = do
@@ -76,7 +82,7 @@ spec = do
              in actual `shouldBe` expected
 
     describe "deriveToGraphQL" $ do
-        it "derives ToGraphQL for a record" $ do
+        it "derives ToGraphQL for a record with multiple fields" $ do
             let expected = Type.Object $ HashMap.fromList
                     [ ("x", Type.Int 1)
                     , ("y", Type.Boolean True)
@@ -87,3 +93,15 @@ spec = do
                     , y = True
                     }
              in toGraphQL given `shouldBe` expected
+
+    describe "deriveFromGraphQL" $ do
+        it "derives FromGraphQL for a record with multiple fields" $ do
+            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