Add deriveToGraphQL
Some checks failed
Build / audit (push) Failing after 23s
Build / test (push) Failing after 22s
Build / doc (push) Failing after 24s

… for deriving `ToGraphQL` instances automatically.
This commit is contained in:
Eugen Wissner 2024-07-07 12:55:42 +02:00
parent 6590cfaae8
commit 11ab7e18e1
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
4 changed files with 125 additions and 3 deletions

View File

@ -6,6 +6,10 @@ The format is based on
and this project adheres to and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/). [Haskell Package Versioning Policy](https://pvp.haskell.org/).
## [Unreleased]
### Added
- Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically.
## [1.0.2.0] - 2023-07-07 ## [1.0.2.0] - 2023-07-07
### Added ### Added
- `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`, - `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`,
@ -26,5 +30,6 @@ and this project adheres to
- JSON serialization. - JSON serialization.
- Test helpers. - 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.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 [1.0.1.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.0.0...v1.0.1.0

View File

@ -41,6 +41,7 @@ library
graphql >= 1.2, graphql >= 1.2,
megaparsec >= 9.0 && < 10, megaparsec >= 9.0 && < 10,
scientific ^>= 0.3.7, scientific ^>= 0.3.7,
template-haskell >= 2.16 && < 3,
text >= 1.2 && < 3, text >= 1.2 && < 3,
time >= 1.11.1, time >= 1.11.1,
transformers >= 0.5.6 && < 0.7, transformers >= 0.5.6 && < 0.7,

View File

@ -3,22 +3,23 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
-- | ToGraphQL and FromGraphQL typeclasses used for user-defined type -- | ToGraphQL and FromGraphQL typeclasses used for user-defined type
-- conversion. -- conversion.
module Language.GraphQL.Class module Language.GraphQL.Class
( FromGraphQL(..) ( FromGraphQL(..)
, ToGraphQL(..) , ToGraphQL(..)
, deriveToGraphQL
) where ) where
import Data.Foldable (toList)
import Data.Int (Int8, Int16, Int32, Int64) import Data.Int (Int8, Int16, Int32, Int64)
import Data.Text (Text) import Data.Text (Text)
import Data.Word (Word8, Word16, Word32, Word64) import Data.Word (Word8, Word16, Word32, Word64)
import qualified Data.Text.Read as Text.Read import qualified Data.Text.Read as Text.Read
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import qualified Language.GraphQL.Type as Type
import Data.Scientific (Scientific, toRealFloat) import Data.Scientific (Scientific, toRealFloat)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Time import Data.Time
@ -38,6 +39,38 @@ import Data.Time.Format.ISO8601
, iso8601Format , iso8601Format
, iso8601Show , 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 :: Integral a => Type.Value -> Maybe a
fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
@ -269,3 +302,64 @@ instance FromGraphQL TimeOfDay
instance FromGraphQL LocalTime instance FromGraphQL LocalTime
where where
fromGraphQL = fromGraphQLToISO8601 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)|]
]

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.GraphQL.ClassSpec module Language.GraphQL.ClassSpec
( spec ( spec
) where ) where
@ -11,8 +12,16 @@ import Data.Text (Text)
import Data.Time (UTCTime(..)) import Data.Time (UTCTime(..))
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
import qualified Language.GraphQL.Type as Type 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 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 :: Spec
spec = do spec = do
@ -65,3 +74,16 @@ spec = do
} }
actual = fromGraphQL given actual = fromGraphQL given
in actual `shouldBe` expected 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