Add deriveFromGraphQL

For deriving FromGraphQL instances automatically.
This commit is contained in:
Eugen Wissner 2024-07-10 13:22:48 +02:00
parent 11ab7e18e1
commit cf029961e8
4 changed files with 82 additions and 26 deletions

View File

@ -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: |
cabal update
cabal install hlint "--constraint=hlint ==3.8"
- run: cabal exec hlint -- src tests
- run: 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

View File

@ -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

View File

@ -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

View File

@ -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