graphql-spice 1.0.2.0 → 1.0.3.0
raw patch · 4 files changed
+277/−5 lines, 4 filesdep +template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: template-haskell
API changes (from Hackage documentation)
+ Language.GraphQL.Class: deriveFromGraphQL :: Name -> Q [Dec]
+ Language.GraphQL.Class: deriveToGraphQL :: Name -> Q [Dec]
Files
- CHANGELOG.md +6/−0
- graphql-spice.cabal +5/−2
- src/Language/GraphQL/Class.hs +171/−2
- tests/Language/GraphQL/ClassSpec.hs +95/−1
CHANGELOG.md view
@@ -6,6 +6,11 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.3.0] - 2024-07-20+### Added+- Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically.+- Add `deriveFromGraphQL`for deriving `FromGraphQL` instances automatically.+ ## [1.0.2.0] - 2023-07-07 ### Added - `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`,@@ -26,5 +31,6 @@ - JSON serialization. - Test helpers. +[1.0.3.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.2.0...v1.0.3.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
graphql-spice.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: graphql-spice-version: 1.0.2.0+version: 1.0.3.0 synopsis: GraphQL with batteries description: Various extensions and convenience functions for the core graphql package.@@ -16,7 +16,7 @@ build-type: Simple extra-source-files: CHANGELOG.md tested-with:- GHC == 9.2.8+ GHC == 9.4.8 source-repository head type: git@@ -41,6 +41,7 @@ graphql >= 1.2, megaparsec >= 9.0 && < 10, scientific ^>= 0.3.7,+ template-haskell >= 2.16 && < 3, text >= 1.2 && < 3, time >= 1.11.1, transformers >= 0.5.6 && < 0.7,@@ -70,4 +71,6 @@ text, time, unordered-containers+ build-tool-depends:+ hspec-discover:hspec-discover default-language: Haskell2010
src/Language/GraphQL/Class.hs view
@@ -3,22 +3,24 @@ 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(..)+ , deriveFromGraphQL+ , 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 +40,42 @@ , 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+ , conE+ , integerL+ , litP+ , wildP+ )+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 +307,134 @@ instance FromGraphQL LocalTime where fromGraphQL = fromGraphQLToISO8601++stringLE :: Name -> Q Exp+stringLE = litE . stringL . nameBase++-- | Given a type derives a 'FromGraphQL' instance for it.+--+-- The derivation can only work when all nested types already have 'FromGraphQL'+-- instances.+--+-- The following cases are supported:+--+-- * Records encode input objects.+-- * Sum types with all data constructors without parameters encode Enums.+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 input objects and enums are supported if all member types have a FromGraphQL instance"+ 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++-- | Given a type derives a 'ToGraphQL' instance for it.+--+-- The derivation can only work when all nested types already have 'ToGraphQL'+-- instances.+--+-- The following cases are supported:+--+-- * Records are decoded as objects.+-- * Sum types with all data constructors without parameters are decoded as Enums.+-- * Sum types whose data constructors have exactly one parameter are decoded as Unions.+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 objects, unions and enums are supported if all member types have a ToGraphQL instance"+ 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 "All data constructors should have either no parameters (Enum) or one parameter (Union)"+ 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)|]+ ]
tests/Language/GraphQL/ClassSpec.hs view
@@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Language.GraphQL.ClassSpec ( spec ) where@@ -11,9 +12,42 @@ import Data.Time (UTCTime(..)) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import qualified Language.GraphQL.Type as Type-import Language.GraphQL.Class (FromGraphQL(..), ToGraphQL(..))+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)++data TwoVariantUnion+ = FirstVariantUnion TwoFieldRecord+ | SecondVariantUnion TwoFieldRecord+ deriving (Eq, Show)++$(deriveToGraphQL ''TwoVariantUnion)++newtype NewTypeRecord = NewTypeRecord { newTypeField :: Int }+ deriving (Eq, Show)++$(deriveToGraphQL ''NewTypeRecord)+$(deriveFromGraphQL ''NewTypeRecord)++data TwoFieldEnum = TWO_FIELD_ENUM_1 | TWO_FIELD_ENUM_2+ deriving (Eq, Show)++$(deriveToGraphQL ''TwoFieldEnum)+$(deriveFromGraphQL ''TwoFieldEnum)+ spec :: Spec spec = do describe "ToGraphQL" $ do@@ -65,3 +99,63 @@ } actual = fromGraphQL given in actual `shouldBe` expected++ describe "deriveToGraphQL" $ do+ it "derives ToGraphQL for a record with multiple fields" $+ 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++ it "derives ToGraphQL for a union" $+ let expected = Type.Object $ HashMap.fromList+ [ ("x", Type.Int 2)+ , ("y", Type.Boolean False)+ , ("__typename", Type.String "TwoFieldRecord")+ ]+ given = SecondVariantUnion $ TwoFieldRecord+ { x = 2+ , y = False+ }+ in toGraphQL given `shouldBe` expected++ it "derives ToGraphQL for a newtype record" $+ let expected = Type.Object $ HashMap.fromList+ [ ("newTypeField", Type.Int 3)+ , ("__typename", Type.String "NewTypeRecord")+ ]+ given = NewTypeRecord 3+ in toGraphQL given `shouldBe` expected++ it "derives ToGraphQL for an enumeration" $+ let expected = Type.Enum "TWO_FIELD_ENUM_2"+ given = TWO_FIELD_ENUM_2+ in toGraphQL given `shouldBe` expected++ describe "deriveFromGraphQL" $ do+ it "derives FromGraphQL for a record with multiple fields" $+ 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++ it "derives FromGraphQL for a newtype record" $+ let given = Type.Object $ HashMap.singleton "newTypeField" (Type.Int 3)+ expected = NewTypeRecord 3+ in fromGraphQL given `shouldBe` Just expected++ it "derives FromGraphQL for an enumeration" $+ let given = Type.Enum "TWO_FIELD_ENUM_2"+ expected = TWO_FIELD_ENUM_2+ in fromGraphQL given `shouldBe` Just expected