Compare commits

..

No commits in common. "v1.0.3.0" and "v1.0.2.0" have entirely different histories.

5 changed files with 5 additions and 308 deletions

View File

@ -1,31 +0,0 @@
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

View File

@ -6,11 +6,6 @@ The format is based on
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`,
@ -31,6 +26,5 @@ and this project adheres to
- 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

View File

@ -1,7 +1,7 @@
cabal-version: 2.4
name: graphql-spice
version: 1.0.3.0
version: 1.0.2.0
synopsis: GraphQL with batteries
description: Various extensions and convenience functions for the core
graphql package.
@ -16,7 +16,7 @@ license-files: LICENSE
build-type: Simple
extra-source-files: CHANGELOG.md
tested-with:
GHC == 9.4.8
GHC == 9.2.8
source-repository head
type: git
@ -41,7 +41,6 @@ library
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,
@ -71,6 +70,4 @@ test-suite graphql-test
text,
time,
unordered-containers
build-tool-depends:
hspec-discover:hspec-discover
default-language: Haskell2010

View File

@ -3,24 +3,22 @@
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
@ -40,42 +38,6 @@ import Data.Time.Format.ISO8601
, 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
@ -307,134 +269,3 @@ instance FromGraphQL TimeOfDay
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)|]
]

View File

@ -3,7 +3,6 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.GraphQL.ClassSpec
( spec
) where
@ -12,41 +11,8 @@ 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
@ -99,63 +65,3 @@ spec = do
}
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