morpheus-graphql-client 0.12.0 → 0.13.0

raw patch · 13 files changed

+617/−368 lines, 13 filesdep ~morpheus-graphql-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-core

API changes (from Hackage documentation)

Files

• README.md +3/−3
• changelog.md +12/−0
• morpheus-graphql-client.cabal +7/−4
• src/Data/Morpheus/Client.hs +6/−0
• src/Data/Morpheus/Client/Aeson.hs +0/−200
• src/Data/Morpheus/Client/Build.hs +21/−78
• src/Data/Morpheus/Client/Declare/Aeson.hs +268/−0
• src/Data/Morpheus/Client/Declare/Client.hs +64/−0
• src/Data/Morpheus/Client/Declare/Type.hs +76/−0
• src/Data/Morpheus/Client/Internal/Types.hs +26/−0
• src/Data/Morpheus/Client/Transform/Core.hs +19/−9
• src/Data/Morpheus/Client/Transform/Inputs.hs +63/−34
• src/Data/Morpheus/Client/Transform/Selection.hs +52/−40

@@ -67,11 +67,11 @@   | PowerOmniscience  data GetHeroArgs = GetHeroArgs {-  getHeroArgsCharacter: Character+  character: Character }  data Character = Character {-  characterName: Person+  name: Person } ``` @@ -83,7 +83,7 @@   fetchHero :: Args GetHero -> m (Either String GetHero)   fetchHero = fetch jsonRes args       where-        args = GetHeroArgs {getHeroArgsCharacter = Person {characterName = "Zeus"}}+        args = GetHeroArgs {character = Person {name = "Zeus"}}         jsonRes :: ByteString -> m ByteString         jsonRes = <GraphQL APi> ```

@@ -1,3 +1,15 @@ # Changelog +## 0.13.0 - unreleased changes++### breaking changes++- from now you should provide for every custom graphql scalar definition coresponoding haskell type definition and `GQLScalar` implementation fot it. for details see [`examples-client`](https://github.com/morpheusgraphql/morpheus-graphql/tree/master/examples-client)++- input fields and query arguments are imported without namespacing++### new features++- exposed: `ScalarValues`,`GQLScalar`, `ID`+ ## 0.12.0 - 21.05.2020

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8749fc28a63b46eed778a0eb7cfcb2e6f184c7e9c49a7f3a2847b7b735e2599e+-- hash: 7197b378712c75bda382590d65bb12695851254973a9d957be9bf41539618227  name:           morpheus-graphql-client-version:        0.12.0+version:        0.13.0 synopsis:       Morpheus GraphQL Client description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql, client@@ -31,9 +31,12 @@   exposed-modules:       Data.Morpheus.Client   other-modules:-      Data.Morpheus.Client.Aeson       Data.Morpheus.Client.Build+      Data.Morpheus.Client.Declare.Aeson+      Data.Morpheus.Client.Declare.Client+      Data.Morpheus.Client.Declare.Type       Data.Morpheus.Client.Fetch+      Data.Morpheus.Client.Internal.Types       Data.Morpheus.Client.Transform.Core       Data.Morpheus.Client.Transform.Inputs       Data.Morpheus.Client.Transform.Selection@@ -45,7 +48,7 @@       aeson >=1.4.4.0 && <=1.6     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11-    , morpheus-graphql-core >=0.12.0+    , morpheus-graphql-core >=0.13.0     , mtl >=2.0 && <=3.0     , template-haskell >=2.0 && <=3.0     , text >=1.2.3.0 && <1.3

@@ -8,6 +8,9 @@     defineByDocumentFile,     defineByIntrospection,     defineByIntrospectionFile,+    ScalarValue (..),+    GQLScalar (..),+    ID (..),   ) where @@ -28,8 +31,11 @@     parseFullGQLDocument,   ) import Data.Morpheus.QuasiQuoter (gql)+import Data.Morpheus.Types.GQLScalar (GQLScalar (..))+import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.Internal.AST   ( GQLQuery,+    ScalarValue (..),     Schema,   ) import Data.Morpheus.Types.Internal.Resolving

@@ -1,200 +0,0 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Client.Aeson-  ( deriveFromJSON,-    deriveToJSON,-    takeValueType,-  )-where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.HashMap.Lazy as H-  ( lookup,-  )------ MORPHEUS-import Data.Morpheus.Internal.TH-  ( destructRecord,-    instanceFunD,-    instanceHeadT,-    mkTypeName,-    nameConE,-    nameLitP,-    nameStringL,-    nameVarE,-    nameVarP,-  )-import Data.Morpheus.Internal.Utils-  ( nameSpaceType,-  )-import Data.Morpheus.Types.Internal.AST-  ( ConsD (..),-    FieldDefinition (..),-    FieldName,-    Message,-    TypeD (..),-    TypeName (..),-    isEnum,-    isFieldNullable,-    msg,-    toFieldName,-  )-import Data.Semigroup ((<>))-import Data.Text-  ( unpack,-  )-import Language.Haskell.TH--failure :: Message -> Q a-failure = fail . show---- FromJSON-deriveFromJSON :: TypeD -> Q Dec-deriveFromJSON TypeD {tCons = [], tName} =-  failure $ "Type " <> msg tName <> " Should Have at least one Constructor"-deriveFromJSON TypeD {tName, tNamespace, tCons = [cons]} =-  defineFromJSON-    name-    (aesonObject tNamespace)-    cons-  where-    name = nameSpaceType tNamespace tName-deriveFromJSON typeD@TypeD {tName, tCons, tNamespace}-  | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons-  | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD-  where-    name = nameSpaceType tNamespace tName--aesonObject :: [FieldName] -> ConsD -> ExpQ-aesonObject tNamespace con@ConsD {cName} =-  appE-    [|withObject name|]-    (lamE [nameVarP "o"] (aesonObjectBody tNamespace con))-  where-    name = nameSpaceType tNamespace cName--aesonObjectBody :: [FieldName] -> ConsD -> ExpQ-aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields-  where-    consName = nameConE (nameSpaceType namespace cName)-    -----------------------------------------------------------    handleFields [] =-      failure $-        "Type \""-          <> msg cName-          <> "\" is Empty Object"-    handleFields fields = startExp fields-      where-        ------------------------------------------------------------        defField field@FieldDefinition {fieldName}-          | isFieldNullable field = [|o .:? fieldName|]-          | otherwise = [|o .: fieldName|]-        ---------------------------------------------------------        startExp fNames =-          uInfixE-            consName-            (varE '(<$>))-            (applyFields fNames)-          where-            applyFields [] = fail "No Empty fields"-            applyFields [x] = defField x-            applyFields (x : xs) =-              uInfixE (defField x) (varE '(<*>)) (applyFields xs)--aesonUnionObject :: [FieldName] -> TypeD -> ExpQ-aesonUnionObject namespace TypeD {tCons} =-  appE-    (varE 'takeValueType)-    (lamCaseE (map buildMatch tCons <> [elseCaseEXP]))-  where-    buildMatch cons@ConsD {cName} = match objectPattern body []-      where-        objectPattern = tupP [nameLitP cName, nameVarP "o"]-        body = normalB $ aesonObjectBody namespace cons--takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a-takeValueType f (Object hMap) = case H.lookup "__typename" hMap of-  Nothing -> fail "key \"__typename\" not found on object"-  Just (String x) -> pure (unpack x, hMap) >>= f-  Just val ->-    fail $ "key \"__typename\" should be string but found: " <> show val-takeValueType _ _ = fail "expected Object"--defineFromJSON :: TypeName -> (t -> ExpQ) -> t -> DecQ-defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method]-  where-    iHead = instanceHeadT ''FromJSON tName []-    ------------------------------------------    method = instanceFunD 'parseJSON [] (parseJ cFields)--aesonFromJSONEnumBody :: TypeName -> [ConsD] -> ExpQ-aesonFromJSONEnumBody tName cons = lamCaseE handlers-  where-    handlers = map buildMatch cons <> [elseCaseEXP]-      where-        buildMatch ConsD {cName} = match enumPat body []-          where-            enumPat = nameLitP cName-            body =-              normalB $-                appE-                  (varE 'pure)-                  (nameConE $ nameSpaceType [toFieldName tName] cName)--elseCaseEXP :: MatchQ-elseCaseEXP = match (nameVarP varName) body []-  where-    varName = "invalidValue"-    body =-      normalB $-        appE-          (nameVarE "fail")-          ( uInfixE-              (appE (varE 'show) (nameVarE varName))-              (varE '(<>))-              (stringE " is Not Valid Union Constructor")-          )--aesonToJSONEnumBody :: TypeName -> [ConsD] -> ExpQ-aesonToJSONEnumBody tName cons = lamCaseE handlers-  where-    handlers = map buildMatch cons-      where-        buildMatch ConsD {cName} = match enumPat body []-          where-            enumPat = conP (mkTypeName $ nameSpaceType [toFieldName tName] cName) []-            body = normalB $ litE (nameStringL cName)---- ToJSON-deriveToJSON :: TypeD -> Q [Dec]-deriveToJSON TypeD {tCons = []} =-  fail "Type Should Have at least one Constructor"-deriveToJSON TypeD {tName, tCons = [ConsD {cFields}]} =-  pure <$> instanceD (cxt []) appHead methods-  where-    appHead = instanceHeadT ''ToJSON tName []-    -------------------------------------------------------------------    -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]-    methods = [funD 'toJSON [clause argsE (normalB body) []]]-      where-        argsE = [destructRecord tName varNames]-        body = appE (varE 'object) (listE $ map decodeVar varNames)-        decodeVar name = [|name .= $(varName)|] where varName = nameVarE name-        varNames = map fieldName cFields-deriveToJSON TypeD {tName, tCons}-  | isEnum tCons =-    let methods = [funD 'toJSON clauses]-        clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []]-     in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods-  | otherwise =-    fail "Input Unions are not yet supported"

@@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  module Data.Morpheus.Client.Build   ( defineQuery,@@ -12,16 +10,14 @@ -- -- MORPHEUS -import Data.Morpheus.Client.Aeson-  ( deriveFromJSON,-    deriveToJSON,+import Data.Morpheus.Client.Declare.Client+  ( declareClient,   )-import Data.Morpheus.Client.Fetch-  ( deriveFetch,+import Data.Morpheus.Client.Internal.Types+  ( ClientDefinition (..),   ) import Data.Morpheus.Client.Transform.Selection-  ( ClientDefinition (..),-    toClientDefinition,+  ( toClientDefinition,   ) import Data.Morpheus.Core   ( validateRequest,@@ -30,29 +26,16 @@   ( gqlWarnings,     renderGQLErrors,   )-import Data.Morpheus.Internal.TH-  ( Scope (..),-    declareType,-    nameConType,-    nameConType,-  )-import qualified Data.Morpheus.Types.Internal.AST as O-  ( Operation (..),-  ) import Data.Morpheus.Types.Internal.AST-  ( DataTypeKind (..),-    GQLQuery (..),+  ( GQLQuery (..),+    Operation (..),     Schema,-    TypeD (..),-    TypeD (..),     VALIDATION_MODE (..),-    isOutputObject,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,     Result (..),   )-import Data.Semigroup ((<>)) import Language.Haskell.TH  defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec]@@ -60,59 +43,19 @@   schema <- runIO ioSchema   case schema >>= (`validateWith` query) of     Failure errors -> fail (renderGQLErrors errors)-    Success {result, warnings} -> gqlWarnings warnings >> defineQueryD src result--defineQueryD :: String -> ClientDefinition -> Q [Dec]-defineQueryD _ ClientDefinition {clientTypes = []} = return []-defineQueryD src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} =-  do-    rootDeclaration <--      defineOperationType-        (queryArgumentType clientArguments)-        src-        rootType-    typeDeclarations <- concat <$> traverse declareT subTypes-    pure (rootDeclaration <> typeDeclarations)-  where-    declareT clientType@TypeD {tKind}-      | isOutputObject tKind || tKind == KindUnion =-        withToJSON-          declareOutputType-          clientType-      | tKind == KindEnum = withToJSON declareInputType clientType-      | otherwise = declareInputType clientType--declareOutputType :: TypeD -> Q [Dec]-declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD]--declareInputType :: TypeD -> Q [Dec]-declareInputType typeD = do-  toJSONDec <- deriveToJSON typeD-  pure $ declareType CLIENT 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 = (nameConType "()", pure [])-queryArgumentType (Just rootType@TypeD {tName}) =-  (nameConType tName, declareInputType rootType)--defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec]-defineOperationType (argType, argumentTypes) query clientType =-  do-    rootType <- withToJSON declareOutputType clientType-    typeClassFetch <- deriveFetch argType (tName clientType) query-    argsT <- argumentTypes-    pure $ rootType <> typeClassFetch <> argsT+    Success+      { result,+        warnings+      } -> gqlWarnings warnings >> declareClient src result  validateWith :: Schema -> GQLQuery -> Eventless ClientDefinition-validateWith schema rawRequest@GQLQuery {operation} = do-  validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest-  toClientDefinition-    schema-    (O.operationArguments operation)-    validOperation+validateWith+  schema+  rawRequest@GQLQuery+    { operation = Operation {operationArguments}+    } = do+    validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest+    toClientDefinition+      schema+      operationArguments+      validOperation

@@ -0,0 +1,268 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Client.Declare.Aeson+  ( aesonDeclarations,+  )+where++--+-- MORPHEUS+import Data.Aeson+import Data.Aeson.Types+import qualified Data.HashMap.Lazy as H+  ( lookup,+  )+import Data.Morpheus.Client.Internal.Types+  ( ClientTypeDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.Internal.TH+  ( destructRecord,+    instanceFunD,+    instanceHeadT,+    mkTypeName,+    nameConE,+    nameLitP,+    nameStringL,+    nameVarE,+    nameVarP,+  )+import Data.Morpheus.Internal.Utils+  ( nameSpaceType,+  )+import Data.Morpheus.Types.GQLScalar+  ( scalarFromJSON,+    scalarToJSON,+  )+import Data.Morpheus.Types.Internal.AST+  ( ConsD (..),+    FieldDefinition (..),+    FieldName,+    Message,+    TypeKind (..),+    TypeName (..),+    isEnum,+    isFieldNullable,+    isOutputObject,+    msg,+    toFieldName,+  )+import Data.Semigroup ((<>))+import Data.Text+  ( unpack,+  )+import Language.Haskell.TH++aesonDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec]+aesonDeclarations KindEnum = [deriveFromJSON, deriveToJSON]+aesonDeclarations KindScalar = deriveScalarJSON+aesonDeclarations kind+  | isOutputObject kind || kind == KindUnion = [deriveFromJSON]+  | otherwise = [deriveToJSON]++failure :: Message -> Q a+failure = fail . show++deriveScalarJSON :: [ClientTypeDefinition -> Q Dec]+deriveScalarJSON = [deriveScalarFromJSON, deriveScalarToJSON]++deriveScalarFromJSON :: ClientTypeDefinition -> Q Dec+deriveScalarFromJSON ClientTypeDefinition {clientTypeName} =+  defineFromJSON+    clientTypeName+    (const $ varE 'scalarFromJSON)+    clientTypeName++deriveScalarToJSON :: ClientTypeDefinition -> Q Dec+deriveScalarToJSON+  ClientTypeDefinition+    { clientTypeName = TypeNameTH {typename}+    } =+    let methods = [funD 'toJSON clauses]+        clauses = [clause [] (normalB $ varE 'scalarToJSON) []]+     in instanceD (cxt []) (instanceHeadT ''ToJSON typename []) methods++-- FromJSON+deriveFromJSON :: ClientTypeDefinition -> Q Dec+deriveFromJSON ClientTypeDefinition {clientCons = [], clientTypeName} =+  failure $+    "Type "+      <> msg (typename clientTypeName)+      <> " Should Have at least one Constructor"+deriveFromJSON+  ClientTypeDefinition+    { clientTypeName = clientTypeName@TypeNameTH {namespace},+      clientCons = [cons]+    } =+    defineFromJSON+      clientTypeName+      (aesonObject namespace)+      cons+deriveFromJSON typeD@ClientTypeDefinition {clientTypeName, clientCons}+  | isEnum clientCons =+    defineFromJSON+      clientTypeName+      (aesonFromJSONEnumBody clientTypeName)+      clientCons+  | otherwise =+    defineFromJSON+      clientTypeName+      aesonUnionObject+      typeD++aesonObject :: [FieldName] -> ConsD cat -> ExpQ+aesonObject tNamespace con@ConsD {cName} =+  appE+    [|withObject name|]+    (lamE [nameVarP "o"] (aesonObjectBody tNamespace con))+  where+    name = nameSpaceType tNamespace cName++aesonObjectBody :: [FieldName] -> ConsD cat -> ExpQ+aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields+  where+    consName = nameConE (nameSpaceType namespace cName)+    ----------------------------------------------------------+    handleFields [] =+      failure $+        "Type \""+          <> msg cName+          <> "\" is Empty Object"+    handleFields fields = startExp fields+      where+        ----------------------------------------------------------++        defField field@FieldDefinition {fieldName}+          | isFieldNullable field = [|o .:? fieldName|]+          | otherwise = [|o .: fieldName|]+        --------------------------------------------------------+        startExp fNames =+          uInfixE+            consName+            (varE '(<$>))+            (applyFields fNames)+          where+            applyFields [] = fail "No Empty fields"+            applyFields [x] = defField x+            applyFields (x : xs) =+              uInfixE (defField x) (varE '(<*>)) (applyFields xs)++aesonUnionObject :: ClientTypeDefinition -> ExpQ+aesonUnionObject+  ClientTypeDefinition+    { clientCons,+      clientTypeName = TypeNameTH {namespace}+    } =+    appE+      (varE 'takeValueType)+      (lamCaseE (map buildMatch clientCons <> [elseCaseEXP]))+    where+      buildMatch cons@ConsD {cName} = match objectPattern body []+        where+          objectPattern = tupP [nameLitP cName, nameVarP "o"]+          body = normalB $ aesonObjectBody namespace cons++takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a+takeValueType f (Object hMap) = case H.lookup "__typename" hMap of+  Nothing -> fail "key \"__typename\" not found on object"+  Just (String x) -> pure (unpack x, hMap) >>= f+  Just val ->+    fail $ "key \"__typename\" should be string but found: " <> show val+takeValueType _ _ = fail "expected Object"++namespaced :: TypeNameTH -> TypeName+namespaced TypeNameTH {namespace, typename} =+  nameSpaceType namespace typename++defineFromJSON :: TypeNameTH -> (t -> ExpQ) -> t -> Q Dec+defineFromJSON name parseJ cFields = instanceD (cxt []) iHead [method]+  where+    iHead = instanceHeadT ''FromJSON (namespaced name) []+    -----------------------------------------+    method = instanceFunD 'parseJSON [] (parseJ cFields)++aesonFromJSONEnumBody :: TypeNameTH -> [ConsD cat] -> ExpQ+aesonFromJSONEnumBody TypeNameTH {typename} cons = lamCaseE handlers+  where+    handlers = map buildMatch cons <> [elseCaseEXP]+      where+        buildMatch ConsD {cName} = match enumPat body []+          where+            enumPat = nameLitP cName+            body =+              normalB $+                appE+                  (varE 'pure)+                  (nameConE $ nameSpaceType [toFieldName typename] cName)++elseCaseEXP :: MatchQ+elseCaseEXP = match (nameVarP varName) body []+  where+    varName = "invalidValue"+    body =+      normalB $+        appE+          (nameVarE "fail")+          ( uInfixE+              (appE (varE 'show) (nameVarE varName))+              (varE '(<>))+              (stringE " is Not Valid Union Constructor")+          )++aesonToJSONEnumBody :: TypeNameTH -> [ConsD cat] -> ExpQ+aesonToJSONEnumBody TypeNameTH {typename} cons = lamCaseE handlers+  where+    handlers = map buildMatch cons+      where+        buildMatch ConsD {cName} = match enumPat body []+          where+            enumPat = conP (mkTypeName $ nameSpaceType [toFieldName typename] cName) []+            body = normalB $ litE (nameStringL cName)++-- ToJSON+deriveToJSON :: ClientTypeDefinition -> Q Dec+deriveToJSON+  ClientTypeDefinition+    { clientCons = []+    } =+    fail "Type Should Have at least one Constructor"+deriveToJSON+  ClientTypeDefinition+    { clientTypeName = TypeNameTH {typename},+      clientCons = [ConsD {cFields}]+    } =+    instanceD (cxt []) appHead methods+    where+      appHead = instanceHeadT ''ToJSON typename []+      ------------------------------------------------------------------+      -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]+      methods = [funD 'toJSON [clause argsE (normalB body) []]]+        where+          argsE = [destructRecord typename varNames]+          body = appE (varE 'object) (listE $ map decodeVar varNames)+          decodeVar name = [|name .= $(varName)|] where varName = nameVarE name+          varNames = map fieldName cFields+deriveToJSON+  ClientTypeDefinition+    { clientTypeName = clientTypeName@TypeNameTH {typename},+      clientCons+    }+    | isEnum clientCons =+      let methods = [funD 'toJSON clauses]+          clauses =+            [ clause+                []+                (normalB $ aesonToJSONEnumBody clientTypeName clientCons)+                []+            ]+       in instanceD (cxt []) (instanceHeadT ''ToJSON typename []) methods+    | otherwise =+      fail "Input Unions are not yet supported"

@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Client.Declare.Client+  ( declareClient,+  )+where++import Data.Morpheus.Client.Declare.Aeson+  ( aesonDeclarations,+  )+import Data.Morpheus.Client.Declare.Type (typeDeclarations)+import Data.Morpheus.Client.Fetch+  ( deriveFetch,+  )+import Data.Morpheus.Client.Internal.Types+  ( ClientDefinition (..),+    ClientTypeDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.Internal.TH+  ( nameConType,+  )+import Data.Semigroup ((<>))+import Language.Haskell.TH++declareClient :: String -> ClientDefinition -> Q [Dec]+declareClient _ ClientDefinition {clientTypes = []} = return []+declareClient src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} =+  do+    root <-+      defineOperationType+        (queryArgumentType clientArguments)+        src+        rootType+    types <- concat <$> traverse declareType subTypes+    pure (root <> types)++declareType :: ClientTypeDefinition -> Q [Dec]+declareType clientType@ClientTypeDefinition {clientKind} =+  apply clientType (typeDeclarations clientKind <> aesonDeclarations clientKind)++apply :: Applicative f => a -> [a -> f b] -> f [b]+apply a = traverse (\f -> f a)++queryArgumentType :: Maybe ClientTypeDefinition -> (Type, Q [Dec])+queryArgumentType Nothing = (nameConType "()", pure [])+queryArgumentType (Just client@ClientTypeDefinition {clientTypeName}) =+  (nameConType (typename clientTypeName), declareType client)++defineOperationType :: (Type, Q [Dec]) -> String -> ClientTypeDefinition -> Q [Dec]+defineOperationType+  (argType, argumentTypes)+  query+  clientType@ClientTypeDefinition+    { clientTypeName = TypeNameTH {typename}+    } =+    do+      rootType <- declareType clientType+      typeClassFetch <- deriveFetch argType typename query+      argsT <- argumentTypes+      pure $ rootType <> typeClassFetch <> argsT

@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Client.Declare.Type+  ( typeDeclarations,+  )+where++--+-- MORPHEUS+import Data.Morpheus.Client.Internal.Types+  ( ClientTypeDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.Internal.TH+  ( declareTypeRef,+    isEnum,+    mkFieldName,+    mkTypeName,+    nameSpaceType,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ConsD (..),+    FieldDefinition (..),+    FieldName,+    TypeKind (..),+    TypeName,+  )+import Data.Semigroup ((<>))+import GHC.Generics (Generic)+import Language.Haskell.TH++typeDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec]+typeDeclarations KindScalar = []+typeDeclarations _ = [pure . declareType]++declareType :: ClientTypeDefinition -> Dec+declareType+  ClientTypeDefinition+    { clientTypeName = thName@TypeNameTH {namespace, typename},+      clientCons+    } =+    DataD+      []+      (mkConName namespace typename)+      []+      Nothing+      (declareCons thName clientCons)+      (map derive [''Generic, ''Show])+    where+      derive className = DerivClause Nothing [ConT className]++declareCons :: TypeNameTH -> [ConsD ANY] -> [Con]+declareCons TypeNameTH {namespace, typename} clientCons+  | isEnum clientCons = map consE clientCons+  | otherwise = map consR clientCons+  where+    consE ConsD {cName} = NormalC (mkConName namespace (typename <> cName)) []+    consR ConsD {cName, cFields} =+      RecC+        (mkConName namespace cName)+        (map declareField cFields)++declareField :: FieldDefinition ANY -> (Name, Bang, Type)+declareField FieldDefinition {fieldName, fieldType} =+  ( mkFieldName fieldName,+    Bang NoSourceUnpackedness NoSourceStrictness,+    declareTypeRef False fieldType+  )++mkConName :: [FieldName] -> TypeName -> Name+mkConName namespace = mkTypeName . nameSpaceType namespace

@@ -0,0 +1,26 @@+module Data.Morpheus.Client.Internal.Types+  ( ClientTypeDefinition (..),+    TypeNameTH (..),+    ClientDefinition (..),+  )+where++import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ConsD (..),+    TypeKind,+    TypeNameTH (..),+  )++data ClientTypeDefinition = ClientTypeDefinition+  { clientTypeName :: TypeNameTH,+    clientCons :: [ConsD ANY],+    clientKind :: TypeKind+  }+  deriving (Show)++data ClientDefinition = ClientDefinition+  { clientArguments :: Maybe ClientTypeDefinition,+    clientTypes :: [ClientTypeDefinition]+  }+  deriving (Show)

@@ -14,6 +14,7 @@     leafType,     typeFrom,     deprecationWarning,+    customScalarTypes,   ) where @@ -24,6 +25,9 @@ import Control.Monad.Trans.Reader   ( ReaderT (..),   )+import Data.Morpheus.Client.Internal.Types+  ( ClientTypeDefinition (..),+  ) import Data.Morpheus.Error   ( deprecatedField,     globalErrorMessage,@@ -35,23 +39,24 @@   ) import Data.Morpheus.Types.Internal.AST   ( ANY,+    Directives,     FieldName,     GQLErrors,     Message,-    Meta,     RAW,     Ref (..),     Schema (..),     TRUE,     TypeContent (..),-    TypeD,     TypeDefinition (..),     TypeName,+    VALID,     VariableDefinitions,+    hsTypeName,+    isSystemTypeName,     lookupDeprecated,     lookupDeprecatedReason,     msg,-    typeFromScalar,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,@@ -80,24 +85,29 @@ getType :: TypeName -> Converter (TypeDefinition ANY) getType typename = asks fst >>= selectBy (compileError $ " cant find Type" <> msg typename) typename -leafType :: TypeDefinition a -> Converter ([TypeD], [TypeName])+customScalarTypes :: TypeName -> [TypeName]+customScalarTypes typeName+  | not (isSystemTypeName typeName) = [typeName]+  | otherwise = []++leafType :: TypeDefinition a -> Converter ([ClientTypeDefinition], [TypeName]) leafType TypeDefinition {typeName, typeContent} = fromKind typeContent   where-    fromKind :: TypeContent TRUE a -> Converter ([TypeD], [TypeName])+    fromKind :: TypeContent TRUE a -> Converter ([ClientTypeDefinition], [TypeName])     fromKind DataEnum {} = pure ([], [typeName])-    fromKind DataScalar {} = pure ([], [])+    fromKind DataScalar {} = pure ([], customScalarTypes typeName)     fromKind _ = failure $ compileError "Invalid schema Expected scalar"  typeFrom :: [FieldName] -> TypeDefinition a -> TypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent   where-    __typeFrom DataScalar {} = typeFromScalar typeName+    __typeFrom DataScalar {} = hsTypeName typeName     __typeFrom DataObject {} = nameSpaceType path typeName     __typeFrom DataUnion {} = nameSpaceType path typeName     __typeFrom _ = typeName -deprecationWarning :: Maybe Meta -> (FieldName, Ref) -> Converter ()-deprecationWarning meta (typename, ref) = case meta >>= lookupDeprecated of+deprecationWarning :: Directives VALID -> (FieldName, Ref) -> Converter ()+deprecationWarning dirs (typename, ref) = case lookupDeprecated dirs of   Just deprecation -> Converter $ lift $ Success {result = (), warnings, events = []}     where       warnings =

@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -14,23 +15,31 @@ -- -- MORPHEUS import Control.Monad.Reader (asks)-import Data.Morpheus.Client.Transform.Core (Converter (..), getType, typeFrom)+import Data.Morpheus.Client.Internal.Types+  ( ClientTypeDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.Client.Transform.Core+  ( Converter (..),+    customScalarTypes,+    getType,+    typeFrom,+  ) import Data.Morpheus.Internal.Utils   ( elems,+    empty,   ) import Data.Morpheus.Types.Internal.AST   ( ANY,-    ArgumentsDefinition (..),     ConsD (..),-    DataTypeKind (..),     FieldDefinition (..),     IN,     Operation (..),     RAW,     TRUE,     TypeContent (..),-    TypeD (..),     TypeDefinition (..),+    TypeKind (..),     TypeName,     TypeRef (..),     VALID,@@ -39,47 +48,59 @@     getOperationName,     mkConsEnum,     removeDuplicates,+    toAny,   ) import Data.Morpheus.Types.Internal.Resolving   ( resolveUpdates,   ) import Data.Semigroup ((<>)) -renderArguments :: VariableDefinitions RAW -> TypeName -> Maybe TypeD-renderArguments variables argsName+renderArguments ::+  VariableDefinitions RAW ->+  TypeName ->+  Maybe ClientTypeDefinition+renderArguments variables cName   | null variables = Nothing   | otherwise = Just rootArgumentsType   where-    rootArgumentsType :: TypeD+    rootArgumentsType :: ClientTypeDefinition     rootArgumentsType =-      TypeD-        { tName = argsName,-          tNamespace = [],-          tCons = [ConsD {cName = argsName, cFields = map fieldD (elems variables)}],-          tMeta = Nothing,-          tKind = KindInputObject+      ClientTypeDefinition+        { clientTypeName = TypeNameTH [] cName,+          clientKind = KindInputObject,+          clientCons =+            [ ConsD+                { cName,+                  cFields = map fieldD (elems variables)+                }+            ]         }       where         fieldD :: Variable RAW -> FieldDefinition ANY         fieldD Variable {variableName, variableType} =           FieldDefinition             { fieldName = variableName,-              fieldArgs = NoArguments,+              fieldContent = Nothing,               fieldType = variableType,-              fieldMeta = Nothing+              fieldDescription = Nothing,+              fieldDirectives = empty             } -renderOperationArguments :: Operation VALID -> Converter (Maybe TypeD)+renderOperationArguments ::+  Operation VALID ->+  Converter (Maybe ClientTypeDefinition) renderOperationArguments Operation {operationName} = do   variables <- asks snd   pure $ renderArguments variables (getOperationName operationName <> "Args")  -- INPUTS-renderNonOutputTypes :: [TypeName] -> Converter [TypeD]-renderNonOutputTypes enums = do+renderNonOutputTypes ::+  [TypeName] ->+  Converter [ClientTypeDefinition]+renderNonOutputTypes leafTypes = do   variables <- elems <$> asks snd   inputTypeRequests <- resolveUpdates [] $ map (exploreInputTypeNames . typeConName . variableType) variables-  concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> enums)+  concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> leafTypes)  exploreInputTypeNames :: TypeName -> [TypeName] -> Converter [TypeName] exploreInputTypeNames name collected@@ -97,23 +118,26 @@             toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} =               exploreInputTypeNames typeConName         scanType (DataEnum _) = pure (collected <> [typeName])+        scanType (DataScalar _) = pure (collected <> customScalarTypes typeName)         scanType _ = pure collected -buildInputType :: TypeName -> Converter [TypeD]+buildInputType ::+  TypeName ->+  Converter [ClientTypeDefinition] buildInputType name = getType name >>= generateTypes   where     generateTypes TypeDefinition {typeName, typeContent} = subTypes typeContent       where-        subTypes :: TypeContent TRUE ANY -> Converter [TypeD]+        subTypes :: TypeContent TRUE ANY -> Converter [ClientTypeDefinition]         subTypes (DataInputObject inputFields) = do-          fields <- traverse toFieldD (elems inputFields)+          fields <- traverse toClientFieldDefinition (elems inputFields)           pure             [ mkInputType                 typeName                 KindInputObject                 [ ConsD                     { cName = typeName,-                      cFields = fields+                      cFields = fmap toAny fields                     }                 ]             ]@@ -124,19 +148,24 @@                 KindEnum                 (map mkConsEnum enumTags)             ]+        subTypes DataScalar {} =+          pure+            [ mkInputType+                typeName+                KindScalar+                []+            ]         subTypes _ = pure [] -mkInputType :: TypeName -> DataTypeKind -> [ConsD] -> TypeD-mkInputType tName tKind tCons =-  TypeD-    { tName,-      tNamespace = [],-      tCons,-      tKind,-      tMeta = Nothing+mkInputType :: TypeName -> TypeKind -> [ConsD ANY] -> ClientTypeDefinition+mkInputType typename clientKind clientCons =+  ClientTypeDefinition+    { clientTypeName = TypeNameTH [] typename,+      clientKind,+      clientCons     } -toFieldD :: FieldDefinition cat -> Converter (FieldDefinition ANY)-toFieldD field@FieldDefinition {fieldType} = do+toClientFieldDefinition :: FieldDefinition IN -> Converter (FieldDefinition IN)+toClientFieldDefinition FieldDefinition {fieldType, ..} = do   typeConName <- typeFrom [] <$> getType (typeConName fieldType)-  pure $ field {fieldType = fieldType {typeConName}}+  pure FieldDefinition {fieldType = fieldType {typeConName}, ..}

@@ -15,19 +15,23 @@ -- -- MORPHEUS import Control.Monad.Reader (asks, runReaderT)+import Data.Morpheus.Client.Internal.Types+  ( ClientDefinition (..),+    ClientTypeDefinition (..),+    TypeNameTH (..),+  ) import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, leafType, typeFrom) import Data.Morpheus.Client.Transform.Inputs (renderNonOutputTypes, renderOperationArguments) import Data.Morpheus.Internal.Utils   ( Failure (..),     elems,+    empty,     keyOf,     selectBy,   ) import Data.Morpheus.Types.Internal.AST   ( ANY,-    ArgumentsDefinition (..),     ConsD (..),-    DataTypeKind (..),     FieldDefinition (..),     FieldName,     Operation (..),@@ -38,8 +42,8 @@     SelectionContent (..),     SelectionSet,     TypeContent (..),-    TypeD (..),     TypeDefinition (..),+    TypeKind (..),     TypeName,     TypeRef (..),     UnionTag (..),@@ -56,12 +60,6 @@   ) import Data.Semigroup ((<>)) -data ClientDefinition = ClientDefinition-  { clientArguments :: Maybe TypeD,-    clientTypes :: [TypeD]-  }-  deriving (Show)- toClientDefinition ::   Schema ->   VariableDefinitions RAW ->@@ -75,7 +73,13 @@   nonOutputTypes <- renderNonOutputTypes enums   pure ClientDefinition {clientArguments, clientTypes = outputTypes <> nonOutputTypes} -renderOperationType :: Operation VALID -> Converter (Maybe TypeD, [TypeD], [TypeName])+renderOperationType ::+  Operation VALID ->+  Converter+    ( Maybe ClientTypeDefinition,+      [ClientTypeDefinition],+      [TypeName]+    ) renderOperationType op@Operation {operationName, operationSelection} = do   datatype <- asks fst >>= getOperationDataType op   arguments <- renderOperationArguments op@@ -94,16 +98,14 @@   TypeName ->   TypeDefinition ANY ->   SelectionSet VALID ->-  Converter ([TypeD], [TypeName])+  Converter ([ClientTypeDefinition], [TypeName]) genRecordType path tName dataType recordSelSet = do   (con, subTypes, requests) <- genConsD path tName dataType recordSelSet   pure-    ( TypeD-        { tName,-          tNamespace = path,-          tCons = [con],-          tKind = KindObject Nothing,-          tMeta = Nothing+    ( ClientTypeDefinition+        { clientTypeName = TypeNameTH path tName,+          clientCons = [con],+          clientKind = KindObject Nothing         }         : subTypes,       requests@@ -114,14 +116,18 @@   TypeName ->   TypeDefinition ANY ->   SelectionSet VALID ->-  Converter (ConsD, [TypeD], [TypeName])+  Converter+    ( ConsD ANY,+      [ClientTypeDefinition],+      [TypeName]+    ) genConsD path cName datatype selSet = do   (cFields, subTypes, requests) <- unzip3 <$> traverse genField (elems selSet)   pure (ConsD {cName, cFields}, concat subTypes, concat requests)   where     genField ::       Selection VALID ->-      Converter (FieldDefinition ANY, [TypeD], [TypeName])+      Converter (FieldDefinition ANY, [ClientTypeDefinition], [TypeName])     genField sel =       do         (fieldDataType, fieldType) <-@@ -134,8 +140,9 @@           ( FieldDefinition               { fieldName,                 fieldType,-                fieldArgs = NoArguments,-                fieldMeta = Nothing+                fieldContent = Nothing,+                fieldDescription = Nothing,+                fieldDirectives = empty               },             subTypes,             requests@@ -150,22 +157,23 @@   [FieldName] ->   TypeDefinition ANY ->   Selection VALID ->-  Converter ([TypeD], [TypeName])+  Converter+    ( [ClientTypeDefinition],+      [TypeName]+    ) subTypesBySelection _ dType Selection {selectionContent = SelectionField} =   leafType dType subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} =   genRecordType path (typeFrom [] dType) dType selectionSet subTypesBySelection path dType Selection {selectionContent = UnionSelection unionSelections} =   do-    (tCons, subTypes, requests) <-+    (clientCons, subTypes, requests) <-       unzip3 <$> traverse getUnionType (elems unionSelections)     pure-      ( TypeD-          { tNamespace = path,-            tName = typeFrom [] dType,-            tCons,-            tKind = KindUnion,-            tMeta = Nothing+      ( ClientTypeDefinition+          { clientTypeName = TypeNameTH path (typeFrom [] dType),+            clientCons,+            clientKind = KindUnion           }           : concat subTypes,         concat requests@@ -190,16 +198,20 @@     selectBy selError selectionName objectFields >>= processDeprecation     where       selError = compileError $ "cant find field " <> msg (show objectFields)-      processDeprecation FieldDefinition {fieldType = alias@TypeRef {typeConName}, fieldMeta} =-        checkDeprecated >> (trans <$> getType typeConName)-        where-          trans x =-            (x, alias {typeConName = typeFrom path x, typeArgs = Nothing})-          -------------------------------------------------------------------          checkDeprecated :: Converter ()-          checkDeprecated =-            deprecationWarning-              fieldMeta-              (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition})+      processDeprecation+        FieldDefinition+          { fieldType = alias@TypeRef {typeConName},+            fieldDirectives+          } =+          checkDeprecated >> (trans <$> getType typeConName)+          where+            trans x =+              (x, alias {typeConName = typeFrom path x, typeArgs = Nothing})+            ------------------------------------------------------------------+            checkDeprecated :: Converter ()+            checkDeprecated =+              deprecationWarning+                fieldDirectives+                (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition}) getFieldType _ dt _ =   failure (compileError $ "Type should be output Object \"" <> msg (show dt))