diff options
| -rw-r--r-- | .gitea/workflows/build.yml | 27 | ||||
| -rw-r--r-- | CHANGELOG.md | 1 | ||||
| -rw-r--r-- | src/Language/GraphQL/Class.hs | 56 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ClassSpec.hs | 24 |
4 files changed, 82 insertions, 26 deletions
diff --git a/.gitea/workflows/build.yml b/.gitea/workflows/build.yml index 6fe1228..1d02288 100644 --- a/.gitea/workflows/build.yml +++ b/.gitea/workflows/build.yml @@ -7,28 +7,14 @@ on: jobs: audit: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - - name: Install dependencies - run: | - cabal update - cabal install hlint "--constraint=hlint ==3.8" - - run: cabal exec hlint -- src tests + - run: hlint -- src tests test: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - name: Install dependencies run: cabal update @@ -37,13 +23,8 @@ jobs: - run: cabal test --test-show-details=streaming doc: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - name: Install dependencies run: cabal update diff --git a/CHANGELOG.md b/CHANGELOG.md index 656fe5a..74e09f1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to ## [Unreleased] ### Added - Add `deriveToGraphQL` for deriving `ToGraphQL` instances automatically. +- Add `deriveFromGraphQL`for deriving `FromGraphQL` instances automatically. ## [1.0.2.0] - 2023-07-07 ### Added diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs index 2f5d6ff..45159d1 100644 --- a/src/Language/GraphQL/Class.hs +++ b/src/Language/GraphQL/Class.hs @@ -11,6 +11,7 @@ module Language.GraphQL.Class ( FromGraphQL(..) , ToGraphQL(..) + , deriveFromGraphQL , deriveToGraphQL ) where @@ -66,6 +67,10 @@ import Language.Haskell.TH , normalB , appE , mkName + , conE + , integerL + , litP + , wildP ) import Data.Foldable (Foldable(..)) import qualified Data.HashMap.Strict as HashMap @@ -306,6 +311,57 @@ instance FromGraphQL LocalTime stringLE :: Name -> Q Exp stringLE = litE . stringL . nameBase +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 records with a single data constructor are supported" + 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 + deriveToGraphQL :: Name -> Q [Dec] deriveToGraphQL typeName = do TyConI plainConstructor <- reify typeName diff --git a/tests/Language/GraphQL/ClassSpec.hs b/tests/Language/GraphQL/ClassSpec.hs index 9e98905..c14ca7b 100644 --- a/tests/Language/GraphQL/ClassSpec.hs +++ b/tests/Language/GraphQL/ClassSpec.hs @@ -12,16 +12,22 @@ 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(..), deriveToGraphQL) +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) spec :: Spec spec = do @@ -76,7 +82,7 @@ spec = do in actual `shouldBe` expected describe "deriveToGraphQL" $ do - it "derives ToGraphQL for a record" $ do + it "derives ToGraphQL for a record with multiple fields" $ do let expected = Type.Object $ HashMap.fromList [ ("x", Type.Int 1) , ("y", Type.Boolean True) @@ -87,3 +93,15 @@ spec = do , y = True } in toGraphQL given `shouldBe` expected + + describe "deriveFromGraphQL" $ do + it "derives FromGraphQL for a record with multiple fields" $ do + 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 |