Compare commits
8 Commits
Author | SHA1 | Date | |
---|---|---|---|
a0566900c1 | |||
470580affd | |||
16bcdca066 | |||
aa28bdd7fe | |||
cf029961e8 | |||
11ab7e18e1 | |||
6590cfaae8 | |||
a2c626870a |
31
.gitea/workflows/build.yml
Normal file
31
.gitea/workflows/build.yml
Normal file
@ -0,0 +1,31 @@
|
|||||||
|
name: Build
|
||||||
|
|
||||||
|
on:
|
||||||
|
push:
|
||||||
|
pull_request:
|
||||||
|
branches: [master]
|
||||||
|
|
||||||
|
jobs:
|
||||||
|
audit:
|
||||||
|
runs-on: buildenv
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
- run: hlint -- src tests
|
||||||
|
|
||||||
|
test:
|
||||||
|
runs-on: buildenv
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
- name: Install dependencies
|
||||||
|
run: cabal update
|
||||||
|
- name: Prepare system
|
||||||
|
run: cabal build graphql-test
|
||||||
|
- run: cabal test --test-show-details=streaming
|
||||||
|
|
||||||
|
doc:
|
||||||
|
runs-on: buildenv
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
- name: Install dependencies
|
||||||
|
run: cabal update
|
||||||
|
- run: cabal haddock --enable-documentation
|
@ -6,6 +6,11 @@ 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/).
|
||||||
|
|
||||||
|
## [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
|
## [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 +31,6 @@ and this project adheres to
|
|||||||
- JSON serialization.
|
- JSON serialization.
|
||||||
- Test helpers.
|
- 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.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
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
cabal-version: 2.4
|
cabal-version: 2.4
|
||||||
|
|
||||||
name: graphql-spice
|
name: graphql-spice
|
||||||
version: 1.0.2.0
|
version: 1.0.3.0
|
||||||
synopsis: GraphQL with batteries
|
synopsis: GraphQL with batteries
|
||||||
description: Various extensions and convenience functions for the core
|
description: Various extensions and convenience functions for the core
|
||||||
graphql package.
|
graphql package.
|
||||||
@ -16,7 +16,7 @@ license-files: LICENSE
|
|||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files: CHANGELOG.md
|
extra-source-files: CHANGELOG.md
|
||||||
tested-with:
|
tested-with:
|
||||||
GHC == 9.2.8
|
GHC == 9.4.8
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
@ -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,
|
||||||
@ -70,4 +71,6 @@ test-suite graphql-test
|
|||||||
text,
|
text,
|
||||||
time,
|
time,
|
||||||
unordered-containers
|
unordered-containers
|
||||||
|
build-tool-depends:
|
||||||
|
hspec-discover:hspec-discover
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -3,22 +3,24 @@
|
|||||||
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(..)
|
||||||
|
, deriveFromGraphQL
|
||||||
|
, 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 +40,42 @@ 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
|
||||||
|
, 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 :: Integral a => Type.Value -> Maybe a
|
||||||
fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
|
fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
|
||||||
@ -269,3 +307,134 @@ instance FromGraphQL TimeOfDay
|
|||||||
instance FromGraphQL LocalTime
|
instance FromGraphQL LocalTime
|
||||||
where
|
where
|
||||||
fromGraphQL = fromGraphQLToISO8601
|
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)|]
|
||||||
|
]
|
||||||
|
@ -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,41 @@ 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(..)
|
||||||
|
, deriveFromGraphQL
|
||||||
|
, 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
|
||||||
|
} 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 :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
@ -65,3 +99,63 @@ 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 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
|
||||||
|
Loading…
Reference in New Issue
Block a user