Add deriveToGraphQL
… for deriving `ToGraphQL` instances automatically.
This commit is contained in:
parent
6590cfaae8
commit
11ab7e18e1
@ -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
|
||||||
|
@ -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,
|
||||||
|
@ -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)|]
|
||||||
|
]
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user