Add deriveFromGraphQL

For deriving FromGraphQL instances automatically.

1 files changed, 56 insertions, 0 deletions

diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs
index 2f5d6ff..45159d1 100644
--- a/src/Language/GraphQL/Class.hs
+++ b/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