summaryrefslogtreecommitdiff
path: root/src/Data/Morpheus/Execution/Client/Build.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Morpheus/Execution/Client/Build.hs')
-rw-r--r--src/Data/Morpheus/Execution/Client/Build.hs71
1 files changed, 40 insertions, 31 deletions
diff --git a/src/Data/Morpheus/Execution/Client/Build.hs b/src/Data/Morpheus/Execution/Client/Build.hs
index 5b19044..2356ac3 100644
--- a/src/Data/Morpheus/Execution/Client/Build.hs
+++ b/src/Data/Morpheus/Execution/Client/Build.hs
@@ -8,52 +8,61 @@ module Data.Morpheus.Execution.Client.Build
( defineQuery
) where
-import Control.Lens (declareLenses)
-import Data.Aeson (ToJSON)
import Data.Semigroup ((<>))
import Language.Haskell.TH
--
-- MORPHEUS
import Data.Morpheus.Error.Client.Client (renderGQLErrors)
-import Data.Morpheus.Execution.Client.Aeson (deriveFromJSON)
+import Data.Morpheus.Execution.Client.Aeson (deriveFromJSON, deriveToJSON)
import Data.Morpheus.Execution.Client.Compile (validateWith)
import Data.Morpheus.Execution.Client.Fetch (deriveFetch)
import Data.Morpheus.Execution.Internal.Declare (declareType)
-import Data.Morpheus.Types.Internal.Data (DataTypeLib)
-import Data.Morpheus.Types.Internal.DataD (QueryD (..), TypeD (..))
+import Data.Morpheus.Types.Internal.Data (DataTypeKind (..), DataTypeLib, isOutputObject)
+import Data.Morpheus.Types.Internal.DataD (GQLTypeD (..), QueryD (..), TypeD (..))
import Data.Morpheus.Types.Internal.Validation (Validation)
import Data.Morpheus.Types.Types (GQLQueryRoot (..))
-queryArgumentType :: [TypeD] -> (Type, Q [Dec])
-queryArgumentType [] = (ConT $ mkName "()", pure [])
-queryArgumentType (rootType@TypeD {tName}:xs) = (ConT $ mkName tName, types)
- where
- types = pure $ map (declareType [''Show, ''ToJSON]) (rootType : xs)
-
-defineJSONType :: TypeD -> Q [Dec]
-defineJSONType datatype = do
- record <- declareLenses (pure [declareType [''Show] datatype])
- toJson <- pure <$> deriveFromJSON datatype
- pure $ record <> toJson
-
-defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec]
-defineOperationType (argType, argumentTypes) query datatype = do
- rootType <- defineJSONType datatype
- typeClassFetch <- deriveFetch argType (tName datatype) query
- args <- argumentTypes
- pure $ rootType <> typeClassFetch <> args
-
-defineQueryD :: QueryD -> Q [Dec]
-defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgTypes} = do
- rootDecs <- defineOperationType (queryArgumentType queryArgTypes) queryText rootType
- subTypeDecs <- concat <$> mapM defineJSONType subTypes
- return $ rootDecs ++ subTypeDecs
-defineQueryD QueryD {queryTypes = []} = return []
-
defineQuery :: IO (Validation DataTypeLib) -> (GQLQueryRoot, String) -> Q [Dec]
defineQuery ioSchema queryRoot = do
schema <- runIO ioSchema
case schema >>= (`validateWith` queryRoot) of
Left errors -> fail (renderGQLErrors errors)
Right queryD -> defineQueryD queryD
+
+defineQueryD :: QueryD -> Q [Dec]
+defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgsType} = do
+ rootDecs <- defineOperationType (queryArgumentType queryArgsType) queryText rootType
+ subTypeDecs <- concat <$> traverse declareT subTypes
+ return $ rootDecs ++ subTypeDecs
+ where
+ declareT GQLTypeD {typeD, typeKindD}
+ | isOutputObject typeKindD || typeKindD == KindUnion = withToJSON declareOutputType typeD
+ | typeKindD == KindEnum = withToJSON declareInputType typeD
+ | otherwise = declareInputType typeD
+defineQueryD QueryD {queryTypes = []} = return []
+
+declareOutputType :: TypeD -> Q [Dec]
+declareOutputType typeD = pure [declareType False Nothing [''Show] typeD]
+
+declareInputType :: TypeD -> Q [Dec]
+declareInputType typeD = do
+ toJSONDec <- deriveToJSON typeD
+ pure $ declareType True Nothing [''Show] typeD : toJSONDec
+
+withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec]
+withToJSON f datatype = do
+ toJson <- deriveFromJSON datatype
+ dec <- f datatype
+ pure (toJson : dec)
+
+queryArgumentType :: Maybe TypeD -> (Type, Q [Dec])
+queryArgumentType Nothing = (ConT $ mkName "()", pure [])
+queryArgumentType (Just rootType@TypeD {tName}) = (ConT $ mkName tName, declareInputType rootType)
+
+defineOperationType :: (Type, Q [Dec]) -> String -> GQLTypeD -> Q [Dec]
+defineOperationType (argType, argumentTypes) query GQLTypeD {typeD} = do
+ rootType <- withToJSON declareOutputType typeD
+ typeClassFetch <- deriveFetch argType (tName typeD) query
+ argsT <- argumentTypes
+ pure $ rootType <> typeClassFetch <> argsT