Compare commits
No commits in common. "master" and "v1.0.1.0" have entirely different histories.
@ -1,3 +0,0 @@
|
||||
END {
|
||||
system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0)
|
||||
}
|
||||
@ -1,33 +0,0 @@
|
||||
name: Build
|
||||
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- '**'
|
||||
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
|
||||
@ -1,17 +0,0 @@
|
||||
name: Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- '**'
|
||||
|
||||
jobs:
|
||||
release:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Upload a candidate
|
||||
env:
|
||||
HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
|
||||
run: |
|
||||
cabal sdist | awk -f .gitea/deploy.awk
|
||||
45
CHANGELOG.md
45
CHANGELOG.md
@ -6,43 +6,6 @@ The format is based on
|
||||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
### Removed
|
||||
- Deprecated `Language.GraphQL.Class.gql` (moved to `Language.GraphQL.TH`).
|
||||
|
||||
### Added
|
||||
- `String` instances from `ToGraphQL` and `FromGraphQL`.
|
||||
|
||||
## [1.0.6.0] - 2024-12-06
|
||||
### Added
|
||||
- `Language.GraphQL.Class.gql` is moved to `Language.GraphQL.TH` where it was
|
||||
before in `graphql`.
|
||||
|
||||
## [1.0.5.0] - 2024-11-21
|
||||
### Added
|
||||
- Add `ToGraphQL` and `FromGraphQL` instances for `Value` and `HashMap`.
|
||||
|
||||
## [1.0.4.0] - 2024-10-24
|
||||
### Added
|
||||
- `gql` quasi quoter which generates a string literal with the first line
|
||||
starting at the first column and all following lines indented relative to the
|
||||
first line.
|
||||
|
||||
## [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`,
|
||||
and `Scientific`.
|
||||
- `ToGraphQL` and `FromGraphQL` instances for `Day`, `DiffTime`,
|
||||
`NominalDiffTime`, `UTCTime`, `LocalTime` and `TimeOfDay`.
|
||||
- `Resolver`: Export `ServerException`.
|
||||
- `Resolver.defaultResolver`: Throw `FieldNotResolvedException` if the requested
|
||||
field is not in the parent object.
|
||||
|
||||
## [1.0.1.0] - 2023-02-17
|
||||
### Added
|
||||
- `ToGraphQL` and `FromGraphQL` typeclasses with instances for basic types.
|
||||
@ -53,10 +16,4 @@ and this project adheres to
|
||||
- JSON serialization.
|
||||
- Test helpers.
|
||||
|
||||
[Unreleased]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.6.0...master
|
||||
[1.0.6.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.5.0...v1.0.6.0
|
||||
[1.0.5.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.4.0...v1.0.5.0
|
||||
[1.0.4.0]: https://git.caraus.tech/OSS/graphql-spice/compare/v1.0.3.0...v1.0.4.0
|
||||
[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
|
||||
[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql-spice/repository/28/diff?rev=v1.0.1.0&rev_to=v1.0.0.0
|
||||
|
||||
4
cabal.project
Normal file
4
cabal.project
Normal file
@ -0,0 +1,4 @@
|
||||
packages:
|
||||
.
|
||||
|
||||
constraints: graphql -json
|
||||
@ -1,52 +1,49 @@
|
||||
cabal-version: 3.0
|
||||
cabal-version: 2.4
|
||||
|
||||
name: graphql-spice
|
||||
version: 1.0.6.0
|
||||
version: 1.0.1.0
|
||||
synopsis: GraphQL with batteries
|
||||
description: Various extensions and convenience functions for the core
|
||||
description: Various extensions and convenience functions for the core
|
||||
graphql package.
|
||||
category: Language
|
||||
homepage: https://git.caraus.tech/OSS/graphql-spice
|
||||
bug-reports: https://git.caraus.tech/OSS/graphql-spice/issues
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql-spice
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql-spice/issues
|
||||
author: Eugen Wissner <belka@caraus.de>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2021-2024 Eugen Wissner
|
||||
copyright: (c) 2021-2023 Eugen Wissner
|
||||
license: MPL-2.0
|
||||
license-files: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files: CHANGELOG.md
|
||||
tested-with:
|
||||
GHC == 9.8.2
|
||||
GHC == 9.2.5
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://git.caraus.tech/OSS/graphql-spice.git
|
||||
location: git://caraus.tech/pub/graphql-spice.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Language.GraphQL.Class
|
||||
Language.GraphQL.JSON
|
||||
Language.GraphQL.Resolver
|
||||
Language.GraphQL.TH
|
||||
Test.Hspec.GraphQL
|
||||
other-modules:
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
aeson >= 2.0.3 && < 2.3,
|
||||
aeson ^>= 2.0.3,
|
||||
base >= 4.7 && < 5,
|
||||
conduit ^>= 1.3.4,
|
||||
containers >= 0.6 && < 0.8,
|
||||
containers ^>= 0.6.2,
|
||||
exceptions ^>= 0.10.4,
|
||||
hspec-expectations >= 0.8.2 && < 0.9,
|
||||
graphql ^>= 1.5.0,
|
||||
graphql >= 1.0,
|
||||
megaparsec >= 9.0 && < 10,
|
||||
scientific ^>= 0.3.7,
|
||||
template-haskell >= 2.16 && < 3,
|
||||
text >= 1.2 && < 3,
|
||||
time >= 1.12.2 && < 1.15,
|
||||
transformers >= 0.5.6 && < 0.7,
|
||||
vector >= 0.12 && < 0.14,
|
||||
transformers ^>= 0.5.6,
|
||||
vector ^>= 0.12.3,
|
||||
unordered-containers ^>= 0.2.16
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -59,7 +56,6 @@ test-suite graphql-test
|
||||
Language.GraphQL.DirectiveSpec
|
||||
Language.GraphQL.FragmentSpec
|
||||
Language.GraphQL.RootOperationSpec
|
||||
Language.GraphQL.THSpec
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
@ -71,8 +67,5 @@ test-suite graphql-test
|
||||
hspec >= 2.9.1 && < 3,
|
||||
scientific,
|
||||
text,
|
||||
time,
|
||||
unordered-containers
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -3,80 +3,21 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
-- | 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 Data.Scientific (Scientific, toRealFloat)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Time
|
||||
( Day
|
||||
, DiffTime
|
||||
, LocalTime(..)
|
||||
, NominalDiffTime
|
||||
, TimeOfDay(..)
|
||||
, UTCTime(..)
|
||||
, showGregorian
|
||||
, secondsToNominalDiffTime
|
||||
, secondsToDiffTime
|
||||
)
|
||||
import Data.Time.Format.ISO8601
|
||||
( ISO8601(..)
|
||||
, formatParseM
|
||||
, 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
|
||||
@ -86,382 +27,79 @@ fromGraphQLToIntegral (Type.String value) =
|
||||
_conversionError -> Nothing
|
||||
fromGraphQLToIntegral _ = Nothing
|
||||
|
||||
iso8601ToGraphQL :: ISO8601 t => t -> Type.Value
|
||||
iso8601ToGraphQL = Type.String . Text.pack . iso8601Show
|
||||
|
||||
fromGraphQLToISO8601 :: ISO8601 t => Type.Value -> Maybe t
|
||||
fromGraphQLToISO8601 (Type.String value') = formatParseM iso8601Format $ Text.unpack value'
|
||||
fromGraphQLToISO8601 _ = Nothing
|
||||
|
||||
-- | Instances of this typeclass can be converted to GraphQL internal
|
||||
-- representation.
|
||||
class ToGraphQL a
|
||||
where
|
||||
class ToGraphQL a where
|
||||
toGraphQL :: a -> Type.Value
|
||||
|
||||
instance ToGraphQL Type.Value
|
||||
where
|
||||
toGraphQL a = a
|
||||
|
||||
instance ToGraphQL Text
|
||||
where
|
||||
instance ToGraphQL Text where
|
||||
toGraphQL = Type.String
|
||||
|
||||
instance ToGraphQL String
|
||||
where
|
||||
toGraphQL = Type.String . Text.pack
|
||||
|
||||
instance ToGraphQL Int
|
||||
where
|
||||
instance ToGraphQL Int where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Int8
|
||||
where
|
||||
instance ToGraphQL Int8 where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Int16
|
||||
where
|
||||
instance ToGraphQL Int16 where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Int32
|
||||
where
|
||||
instance ToGraphQL Int32 where
|
||||
toGraphQL = Type.Int
|
||||
|
||||
instance ToGraphQL Int64
|
||||
where
|
||||
instance ToGraphQL Int64 where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Word
|
||||
where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Word8
|
||||
where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Word16
|
||||
where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Word32
|
||||
where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL Word64
|
||||
where
|
||||
toGraphQL = Type.Int . fromIntegral
|
||||
|
||||
instance ToGraphQL a => ToGraphQL [a]
|
||||
where
|
||||
instance ToGraphQL a => ToGraphQL [a] where
|
||||
toGraphQL = Type.List . fmap toGraphQL
|
||||
|
||||
instance ToGraphQL a => ToGraphQL (Vector a)
|
||||
where
|
||||
instance ToGraphQL a => ToGraphQL (Vector a) where
|
||||
toGraphQL = Type.List . toList . fmap toGraphQL
|
||||
|
||||
instance ToGraphQL a => ToGraphQL (Maybe a)
|
||||
where
|
||||
instance ToGraphQL a => ToGraphQL (Maybe a) where
|
||||
toGraphQL (Just justValue) = toGraphQL justValue
|
||||
toGraphQL Nothing = Type.Null
|
||||
|
||||
instance ToGraphQL Bool
|
||||
where
|
||||
instance ToGraphQL Bool where
|
||||
toGraphQL = Type.Boolean
|
||||
|
||||
instance ToGraphQL Float
|
||||
where
|
||||
toGraphQL = Type.Float . realToFrac
|
||||
|
||||
instance ToGraphQL Double
|
||||
where
|
||||
toGraphQL = Type.Float
|
||||
|
||||
instance ToGraphQL Scientific
|
||||
where
|
||||
toGraphQL = Type.Float . toRealFloat
|
||||
|
||||
instance ToGraphQL Day
|
||||
where
|
||||
toGraphQL = Type.String . Text.pack . showGregorian
|
||||
|
||||
instance ToGraphQL DiffTime
|
||||
where
|
||||
toGraphQL = Type.Int . truncate . (realToFrac :: DiffTime -> Double)
|
||||
|
||||
instance ToGraphQL NominalDiffTime
|
||||
where
|
||||
toGraphQL = Type.Int . truncate . (realToFrac :: NominalDiffTime -> Double)
|
||||
|
||||
instance ToGraphQL UTCTime
|
||||
where
|
||||
toGraphQL = iso8601ToGraphQL
|
||||
|
||||
instance ToGraphQL TimeOfDay
|
||||
where
|
||||
toGraphQL = iso8601ToGraphQL
|
||||
|
||||
instance ToGraphQL LocalTime
|
||||
where
|
||||
toGraphQL = iso8601ToGraphQL
|
||||
|
||||
instance ToGraphQL a => ToGraphQL (HashMap.HashMap Text a)
|
||||
where
|
||||
toGraphQL = Type.Object . fmap toGraphQL
|
||||
|
||||
-- | Instances of this typeclass can be used to convert GraphQL internal
|
||||
-- representation to user-defined type.
|
||||
class FromGraphQL a
|
||||
where
|
||||
class FromGraphQL a where
|
||||
fromGraphQL :: Type.Value -> Maybe a
|
||||
|
||||
instance FromGraphQL Type.Value
|
||||
where
|
||||
fromGraphQL = Just
|
||||
|
||||
instance FromGraphQL Text
|
||||
where
|
||||
instance FromGraphQL Text where
|
||||
fromGraphQL (Type.String value) = Just value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL String
|
||||
where
|
||||
fromGraphQL (Type.String value) = Just $ Text.unpack value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL Int
|
||||
where
|
||||
instance FromGraphQL Int where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Int8
|
||||
where
|
||||
instance FromGraphQL Int8 where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Int16
|
||||
where
|
||||
instance FromGraphQL Int16 where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Int32
|
||||
where
|
||||
instance FromGraphQL Int32 where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Int64
|
||||
where
|
||||
instance FromGraphQL Int64 where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Word
|
||||
where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Word8
|
||||
where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Word16
|
||||
where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Word32
|
||||
where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL Word64
|
||||
where
|
||||
fromGraphQL = fromGraphQLToIntegral
|
||||
|
||||
instance FromGraphQL a => FromGraphQL [a]
|
||||
where
|
||||
instance FromGraphQL a => FromGraphQL [a] where
|
||||
fromGraphQL (Type.List value) = traverse fromGraphQL value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL a => FromGraphQL (Vector a)
|
||||
where
|
||||
instance FromGraphQL a => FromGraphQL (Vector a) where
|
||||
fromGraphQL (Type.List value) = Vector.fromList
|
||||
<$> traverse fromGraphQL value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL a => FromGraphQL (Maybe a)
|
||||
where
|
||||
instance FromGraphQL a => FromGraphQL (Maybe a) where
|
||||
fromGraphQL Type.Null = Just Nothing
|
||||
fromGraphQL value = Just <$> fromGraphQL value
|
||||
|
||||
instance FromGraphQL Bool
|
||||
where
|
||||
instance FromGraphQL Bool where
|
||||
fromGraphQL (Type.Boolean value) = Just value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL Float
|
||||
where
|
||||
fromGraphQL (Type.Float value) = Just $ realToFrac value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL Double
|
||||
where
|
||||
fromGraphQL (Type.Float value) = Just value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL Scientific
|
||||
where
|
||||
fromGraphQL (Type.Float value) = Just $ realToFrac value
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL Day
|
||||
where
|
||||
fromGraphQL = fromGraphQLToISO8601
|
||||
|
||||
instance FromGraphQL DiffTime
|
||||
where
|
||||
fromGraphQL (Type.Int value') = Just $ secondsToDiffTime $ fromIntegral value'
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL NominalDiffTime
|
||||
where
|
||||
fromGraphQL (Type.Int value') = Just $ secondsToNominalDiffTime $ fromIntegral value'
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
instance FromGraphQL UTCTime
|
||||
where
|
||||
fromGraphQL = fromGraphQLToISO8601
|
||||
|
||||
instance FromGraphQL TimeOfDay
|
||||
where
|
||||
fromGraphQL = fromGraphQLToISO8601
|
||||
|
||||
instance FromGraphQL LocalTime
|
||||
where
|
||||
fromGraphQL = fromGraphQLToISO8601
|
||||
|
||||
instance FromGraphQL a => FromGraphQL (HashMap.HashMap Text a)
|
||||
where
|
||||
fromGraphQL (Type.Object hm) = traverse fromGraphQL hm
|
||||
fromGraphQL _ = Nothing
|
||||
|
||||
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)|]
|
||||
]
|
||||
|
||||
@ -6,14 +6,13 @@
|
||||
|
||||
-- | Helper functions and exceptions to write resolvers.
|
||||
module Language.GraphQL.Resolver
|
||||
( ServerException(..)
|
||||
, argument
|
||||
( argument
|
||||
, defaultResolver
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (Exception(..), MonadCatch(..), MonadThrow(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict ((!))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Typeable (cast)
|
||||
@ -50,8 +49,7 @@ defaultResolver :: MonadCatch m => Name -> Type.Resolve m
|
||||
defaultResolver fieldName = do
|
||||
values' <- asks Type.values
|
||||
case values' of
|
||||
Type.Object objectValue
|
||||
| Just result <- HashMap.lookup fieldName objectValue -> pure result
|
||||
Type.Object objectValue -> pure $ objectValue ! fieldName
|
||||
_nonObject -> throwM $ FieldNotResolvedException fieldName
|
||||
|
||||
-- | Takes an argument name, validates that the argument exists, and optionally
|
||||
|
||||
@ -1,49 +0,0 @@
|
||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
module Language.GraphQL.TH
|
||||
( gql
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
( Exp(..)
|
||||
, Lit(..)
|
||||
)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
||||
|
||||
stripIndentation :: String -> String
|
||||
stripIndentation code = reverse
|
||||
$ dropWhile isLineBreak
|
||||
$ reverse
|
||||
$ unlines
|
||||
$ indent spaces <$> lines' withoutLeadingNewlines
|
||||
where
|
||||
indent 0 xs = xs
|
||||
indent count (' ' : xs) = indent (count - 1) xs
|
||||
indent _ xs = xs
|
||||
withoutLeadingNewlines = dropWhile isLineBreak code
|
||||
spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
|
||||
lines' "" = []
|
||||
lines' string =
|
||||
let (line, rest) = break isLineBreak string
|
||||
reminder =
|
||||
case rest of
|
||||
[] -> []
|
||||
'\r' : '\n' : strippedString -> lines' strippedString
|
||||
_ : strippedString -> lines' strippedString
|
||||
in line : reminder
|
||||
isLineBreak = flip any ['\n', '\r'] . (==)
|
||||
|
||||
-- | Removes leading and trailing newlines. Indentation of the first line is
|
||||
-- removed from each line of the string.
|
||||
gql :: QuasiQuoter
|
||||
gql = QuasiQuoter
|
||||
{ quoteExp = pure . LitE . StringL . stripIndentation
|
||||
, quotePat = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
|
||||
, quoteDec = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
@ -3,52 +3,14 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Language.GraphQL.ClassSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
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(..)
|
||||
, deriveFromGraphQL
|
||||
, deriveToGraphQL
|
||||
)
|
||||
import Language.GraphQL.Class (FromGraphQL(..), ToGraphQL(..))
|
||||
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
|
||||
@ -68,15 +30,6 @@ spec = do
|
||||
it "converts singleton lists" $
|
||||
toGraphQL [True] `shouldBe` Type.List [Type.Boolean True]
|
||||
|
||||
it "converts UTCTime" $
|
||||
let given = UTCTime
|
||||
{ utctDay = fromOrdinalDate 2023 5
|
||||
, utctDayTime = 90
|
||||
}
|
||||
actual = toGraphQL given
|
||||
expected = Type.String "2023-01-05T00:01:30Z"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
describe "FromGraphQL" $ do
|
||||
it "converts integers" $
|
||||
fromGraphQL (Type.Int 5) `shouldBe` Just (5 :: Int)
|
||||
@ -92,72 +45,3 @@ spec = do
|
||||
|
||||
it "converts singleton lists" $
|
||||
fromGraphQL (Type.List [Type.Boolean True]) `shouldBe` Just [True]
|
||||
|
||||
it "converts UTCTime" $
|
||||
let given = Type.String "2023-01-05T00:01:30Z"
|
||||
expected = Just $ UTCTime
|
||||
{ utctDay = fromOrdinalDate 2023 5
|
||||
, utctDayTime = 90
|
||||
}
|
||||
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
|
||||
|
||||
@ -3,7 +3,6 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Language.GraphQL.CoerceSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Language.GraphQL.DirectiveSpec
|
||||
( spec
|
||||
@ -17,7 +18,7 @@ import Language.GraphQL.TH
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.GraphQL
|
||||
import "graphql-spice" Test.Hspec.GraphQL
|
||||
|
||||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = schema queryType Nothing Nothing mempty
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Language.GraphQL.FragmentSpec
|
||||
( spec
|
||||
@ -19,7 +20,7 @@ import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.TH
|
||||
import qualified Language.GraphQL as GraphQL
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.GraphQL
|
||||
import "graphql-spice" Test.Hspec.GraphQL
|
||||
|
||||
size :: (Text, Value)
|
||||
size = ("size", String "L")
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Language.GraphQL.RootOperationSpec
|
||||
( spec
|
||||
@ -17,7 +18,7 @@ import Test.Hspec (Spec, describe, it)
|
||||
import Language.GraphQL.TH
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec.GraphQL
|
||||
import "graphql-spice" Test.Hspec.GraphQL
|
||||
|
||||
hatType :: Out.ObjectType IO
|
||||
hatType = Out.ObjectType "Hat" Nothing []
|
||||
|
||||
@ -1,27 +0,0 @@
|
||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.THSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.TH (gql)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "gql" $
|
||||
it "replaces CRNL with NL" $
|
||||
let expected :: Text
|
||||
expected = "line1\nline2\nline3"
|
||||
actual = [gql|
|
||||
line1
|
||||
line2
|
||||
line3
|
||||
|]
|
||||
in actual `shouldBe` expected
|
||||
Loading…
Reference in New Issue
Block a user