packages feed

morpheus-graphql-code-gen 0.22.1 → 0.23.0

raw patch · 14 files changed

+855/−689 lines, 14 filesdep +Globdep +morpheus-graphql-clientdep +yamldep ~morpheus-graphql-code-gen-utilsdep ~morpheus-graphql-coredep ~morpheus-graphql-serverPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, morpheus-graphql-client, yaml

Dependency ranges changed: morpheus-graphql-code-gen-utils, morpheus-graphql-core, morpheus-graphql-server

API changes (from Hackage documentation)

- Data.Morpheus.CodeGen: printServerTypeDefinitions :: PrinterConfig -> [ServerDeclaration] -> ByteString
- Data.Morpheus.CodeGen.Server: printServerTypeDefinitions :: PrinterConfig -> [ServerDeclaration] -> ByteString

Files

+ app/CLI/Commands.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NoImplicitPrelude #-}++module CLI.Commands+  ( GlobalOptions (..),+    App (..),+    Operation (..),+    parseCLI,+  )+where++import Options.Applicative+  ( Parser,+    command,+    customExecParser,+    fullDesc,+    help,+    helper,+    info,+    long,+    metavar,+    prefs,+    progDesc,+    short,+    showHelpOnError,+    strArgument,+    subparser,+    switch,+  )+import qualified Options.Applicative as OA+import Relude hiding (ByteString)++data Operation+  = Build {source :: [FilePath]}+  | About+  deriving (Show)++data App = App+  { operations :: Operation,+    options :: GlobalOptions+  }+  deriving (Show)++newtype GlobalOptions = GlobalOptions+  { version :: Bool+  }+  deriving (Show)++commandParser :: Parser Operation+commandParser =+  buildOperation+    [ ( "build",+        "builds Haskell API from GraphQL schema",+        Build <$> readFiles+      ),+      ( "about",+        "api information",+        pure About+      )+    ]++buildOperation :: [(String, String, Parser Operation)] -> Parser Operation+buildOperation xs = joinParsers $ map parseOperation xs++joinParsers :: [OA.Mod OA.CommandFields a] -> Parser a+joinParsers xs = subparser $ mconcat xs++parseOperation :: (String, String, Parser Operation) -> OA.Mod OA.CommandFields Operation+parseOperation (bName, bDesc, bValue) =+  command bName (info (helper <*> bValue) (fullDesc <> progDesc bDesc))++readFiles :: Parser [String]+readFiles =+  (many . strArgument . mconcat)+    [ metavar "dir",+      help "source dirs with code-gen.yaml file for generating APIs"+    ]++parseCLI :: IO App+parseCLI =+  customExecParser+    (prefs showHelpOnError)+    (info (helper <*> parseApp) description)++parseApp :: OA.Parser App+parseApp = App <$> commandParser <*> parseOptions++parseOptions :: Parser GlobalOptions+parseOptions = GlobalOptions <$> switch (long "version" <> short 'v' <> help "show Version number")++description :: OA.InfoMod a+description = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator"
+ app/CLI/Config.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}++module CLI.Config+  ( Service (..),+    Config (..),+    readConfig,+    ServiceOptions (..),+  )+where++import qualified Data.ByteString as L+  ( readFile,+  )+import Data.Yaml (FromJSON, decodeThrow)+import Relude+import System.FilePath.Posix+  ( (</>),+  )++data ServiceOptions = ServiceOptions+  { namespace :: Maybe Bool,+    globals :: Maybe [Text]+  }+  deriving+    ( Generic,+      FromJSON,+      Show+    )++data Service = Service+  { name :: String,+    includes :: [FilePath],+    source :: FilePath,+    options :: Maybe ServiceOptions,+    schema :: Maybe FilePath+  }+  deriving+    ( Generic,+      FromJSON,+      Show+    )++data Config = Config+  { server :: Maybe [Service],+    client :: Maybe [Service]+  }+  deriving+    ( Generic,+      FromJSON,+      Show+    )++readConfig :: FilePath -> IO Config+readConfig path = do+  file <- L.readFile (path </> "code-gen.yaml")+  decodeThrow file
+ app/CLI/File.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module CLI.File where++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+  ( writeFile,+  )+import Data.Char+import Data.Morpheus.Internal.Ext+  ( GQLResult,+    Result (..),+  )+import Relude hiding (ByteString)+import System.FilePath.Posix+  ( dropExtensions,+    makeRelative,+    normalise,+    replaceExtensions,+    splitDirectories,+    splitFileName,+    (</>),+  )++processFileName :: FilePath -> FilePath+processFileName = (\(x, y) -> x </> replaceExtensions (capitalize y) "hs") . splitFileName . normalise++capitalize :: String -> String+capitalize [] = []+capitalize (x : xs) = toUpper x : xs++saveDocument :: FilePath -> GQLResult ByteString -> IO ()+saveDocument _ (Failure errors) = print errors+saveDocument output Success {result} = L.writeFile output result++getModuleNameByPath :: FilePath -> FilePath -> [Char]+getModuleNameByPath root path = intercalate "." $ splitDirectories $ dropExtensions $ makeRelative root path
+ app/CLI/Generator.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module CLI.Generator+  ( processServerDocument,+    processClientDocument,+    BuildConfig (..),+  )+where++import Data.ByteString.Lazy.Char8 (ByteString, pack)+import Data.Morpheus.Client+  ( SchemaSource,+    parseClientTypeDeclarations,+  )+import Data.Morpheus.CodeGen+  ( CodeGenConfig (..),+    parseServerTypeDefinitions,+  )+import Data.Morpheus.CodeGen.Internal.AST+import Data.Morpheus.Internal.Ext (GQLResult)+import qualified Data.Text as T+import Prettyprinter+import Relude hiding (ByteString, print)++data BuildConfig = BuildConfig+  { root :: String,+    namespaces :: Bool,+    globalImports :: [Text]+  }+  deriving (Show)++processServerDocument :: BuildConfig -> String -> ByteString -> GQLResult ByteString+processServerDocument BuildConfig {..} moduleName schema = do+  types <- parseServerTypeDefinitions CodeGenConfig {namespace = namespaces} schema+  pure $+    print $+      ModuleDefinition+        { moduleName = T.pack moduleName,+          imports =+            [ ("Data.Data", ["Typeable"]),+              ("Data.Morpheus.Kind", ["TYPE"]),+              ("Data.Morpheus.Types", ["*"]),+              ("Data.Morpheus", []),+              ("Data.Text", ["Text"]),+              ("GHC.Generics", ["Generic"])+            ]+              <> map (,["*"]) globalImports,+          extensions =+            [ "DeriveGeneric",+              "TypeFamilies",+              "OverloadedStrings",+              "DataKinds",+              "DuplicateRecordFields"+            ],+          types+        }++processClientDocument ::+  BuildConfig ->+  SchemaSource ->+  Maybe Text ->+  Text ->+  GQLResult ByteString+processClientDocument BuildConfig {..} schema query moduleName = do+  types <- parseClientTypeDeclarations schema query+  let moduleDef =+        ModuleDefinition+          { moduleName,+            imports =+              [("Data.Morpheus.Client.CodeGen.Internal", ["*"])]+                <> map (,["*"]) globalImports,+            extensions =+              [ "DeriveGeneric",+                "DuplicateRecordFields",+                "TypeFamilies",+                "OverloadedStrings",+                "LambdaCase"+              ],+            types+          }+  pure $ print moduleDef++print :: Pretty a => a -> ByteString+print = pack . show . pretty
app/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -7,160 +8,102 @@   ) where -import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L-  ( readFile,-    writeFile,+import CLI.Commands+  ( App (..),+    GlobalOptions (..),+    Operation (..),+    parseCLI,   )-import Data.Char-import Data.Morpheus.CodeGen-  ( CodeGenConfig (..),-    PrinterConfig (..),-    parseServerTypeDefinitions,-    printServerTypeDefinitions,+import CLI.Config+  ( Config (..),+    Service (..),+    ServiceOptions (..),+    readConfig,   )-import Data.Morpheus.Internal.Ext-  ( GQLResult,-    Result (..),+import CLI.File (getModuleNameByPath, processFileName, saveDocument)+import CLI.Generator+import qualified Data.ByteString.Lazy as L+  ( readFile,   )+import Data.Morpheus.Client (readSchemaSource)+import Data.Text (pack)+import qualified Data.Text.IO as TIO import Data.Version (showVersion)-import Options.Applicative-  ( Parser,-    ReadM,-    command,-    customExecParser,-    eitherReader,-    fullDesc,-    help,-    helper,-    info,-    long,-    metavar,-    option,-    prefs,-    progDesc,-    short,-    showHelpOnError,-    strArgument,-    subparser,-    switch,-  )-import qualified Options.Applicative as OA import qualified Paths_morpheus_graphql_code_gen as CLI import Relude hiding (ByteString)-import System.FilePath.Posix-  ( dropExtensions,-    makeRelative,-    normalise,-    replaceExtensions,-    splitDirectories,-    splitFileName,-    (</>),-  )+import System.FilePath (normalise, (</>))+import System.FilePath.Glob (glob)  currentVersion :: String currentVersion = showVersion CLI.version  main :: IO ()-main = defaultParser >>= runApp+main = parseCLI >>= runApp  runApp :: App -> IO () runApp App {..}   | version options = putStrLn currentVersion   | otherwise = runOperation operations   where-    runOperation About =-      putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion-    runOperation Build {source} = traverse_ (processFile options) source--processFile :: Options -> FilePath -> IO ()-processFile Options {root, namespaces} path =-  print (path, hsPath)-    >> L.readFile path-    >>= saveDocument hsPath-      . fmap (printServerTypeDefinitions PrinterConfig {moduleName})-      . parseServerTypeDefinitions CodeGenConfig {namespace = namespaces}-  where-    hsPath = processFileName path-    moduleName = intercalate "." $ splitDirectories $ dropExtensions $ makeRelative root hsPath--processFileName :: FilePath -> FilePath-processFileName = (\(x, y) -> x </> replaceExtensions (capitalize y) "hs") . splitFileName . normalise--capitalize :: String -> String-capitalize [] = []-capitalize (x : xs) = toUpper x : xs--saveDocument :: FilePath -> GQLResult ByteString -> IO ()-saveDocument _ (Failure errors) = print errors-saveDocument output Success {result} = L.writeFile output result--data Operation-  = Build {source :: [FilePath]}-  | About-  deriving (Show)--data App = App-  { operations :: Operation,-    options :: Options-  }-  deriving (Show)--data Options = Options-  { version :: Bool,-    root :: String,-    namespaces :: Bool-  }-  deriving (Show)--defaultParser :: IO App-defaultParser =-  customExecParser-    (prefs showHelpOnError)-    (info (helper <*> parseApp) description)--parseApp :: OA.Parser App-parseApp = App <$> commandParser <*> parseOptions--parseOptions :: Parser Options-parseOptions =-  Options-    <$> switch (long "version" <> short 'v' <> help "show Version number")-    <*> option readOutput (long "root" <> short 'r' <> help "Root directory of the Haskell project")-    <*> switch (long "namespaces" <> short 'n' <> help "namespaces type fields to avoid name conflicts")+    runOperation About = putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion+    runOperation Build {source} = traverse_ scan source -readOutput :: ReadM String-readOutput = eitherReader Right+scan :: FilePath -> IO ()+scan path = do+  Config {server, client} <- readConfig path+  traverse_ (handleServerService path) (concat $ maybeToList server)+  traverse_ (handleClientService path) (concat $ maybeToList client) -description :: OA.InfoMod a-description = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator"+getImports :: Maybe ServiceOptions -> [Text]+getImports = concat . maybeToList . (>>= globals) -commandParser :: Parser Operation-commandParser =-  buildOperation-    [ ( "build",-        "builds Haskell API from GraphQL schema",-        Build <$> readFiles-      ),-      ( "about",-        "api information",-        pure About-      )-    ]+handleClientService :: FilePath -> Service -> IO ()+handleClientService target Service {name, source, includes, options, schema} = do+  let root = normalise (target </> source)+  let namespaces = fromMaybe False (options >>= namespace)+  let patterns = map (normalise . (root </>)) includes+  files <- concat <$> traverse glob patterns+  putStrLn ("\n build:" <> name)+  schemaPath <- maybe (fail $ "client service " <> name <> " should provide schema!") pure schema+  let globalImports = getImports options+  let config = BuildConfig {..}+  buildClientGlobals config (normalise $ root </> schemaPath)+  traverse_ (buildClientQuery config (normalise $ root </> schemaPath)) files -buildOperation :: [(String, String, Parser Operation)] -> Parser Operation-buildOperation xs = joinParsers $ map parseOperation xs+buildClientGlobals :: BuildConfig -> FilePath -> IO ()+buildClientGlobals options schemaPath = do+  putStr ("  - " <> schemaPath <> "\n")+  schemaDoc <- readSchemaSource schemaPath+  let hsPath = processFileName schemaPath+  let moduleName = pack $ getModuleNameByPath (root options) hsPath+  saveDocument hsPath (processClientDocument options schemaDoc Nothing moduleName) -joinParsers :: [OA.Mod OA.CommandFields a] -> Parser a-joinParsers xs = subparser $ mconcat xs+buildClientQuery :: BuildConfig -> FilePath -> FilePath -> IO ()+buildClientQuery options schemaPath queryPath = do+  putStr ("  - " <> queryPath <> "\n")+  file <- TIO.readFile queryPath+  schemaDoc <- readSchemaSource schemaPath+  let moduleName = getModuleNameByPath (root options) hsPath+  let globalModuleName = pack (getModuleNameByPath (root options) (processFileName schemaPath))+  saveDocument hsPath (processClientDocument (options {globalImports = [globalModuleName]}) schemaDoc (Just file) (pack moduleName))+  where+    hsPath = processFileName queryPath -parseOperation :: (String, String, Parser Operation) -> OA.Mod OA.CommandFields Operation-parseOperation (bName, bDesc, bValue) =-  command bName (info (helper <*> bValue) (fullDesc <> progDesc bDesc))+handleServerService :: FilePath -> Service -> IO ()+handleServerService target Service {name, source, includes, options} = do+  let root = normalise (target </> source)+  let namespaces = fromMaybe False (options >>= namespace)+  let patterns = map (normalise . (root </>)) includes+  files <- concat <$> traverse glob patterns+  putStrLn ("\n build:" <> name)+  let globalImports = getImports options+  traverse_ (buildServer (BuildConfig {..}) {root, namespaces}) files -readFiles :: Parser [String]-readFiles =-  (many . strArgument . mconcat)-    [ metavar "file",-      help "source files for generating api"-    ]+buildServer :: BuildConfig -> FilePath -> IO ()+buildServer options path = do+  putStr ("  - " <> path <> "\n")+  file <- L.readFile path+  let moduleName = getModuleNameByPath (root options) hsPath+  saveDocument hsPath (processServerDocument options moduleName file)+  where+    hsPath = processFileName path
morpheus-graphql-code-gen.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-code-gen-version:        0.22.1+version:        0.23.0 synopsis:       Morpheus GraphQL CLI description:    code generator for Morpheus GraphQL category:       web, graphql, cli@@ -31,8 +31,9 @@       Data.Morpheus.CodeGen.Server   other-modules:       Data.Morpheus.CodeGen.Server.Internal.AST+      Data.Morpheus.CodeGen.Server.Interpreting.Directive       Data.Morpheus.CodeGen.Server.Interpreting.Transform-      Data.Morpheus.CodeGen.Server.Printing.Document+      Data.Morpheus.CodeGen.Server.Interpreting.Utils       Data.Morpheus.CodeGen.Server.Printing.TH       Paths_morpheus_graphql_code_gen   hs-source-dirs:@@ -43,9 +44,9 @@     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0     , file-embed >=0.0.10 && <1.0.0-    , morpheus-graphql-code-gen-utils >=0.22.0 && <0.23.0-    , morpheus-graphql-core >=0.22.0 && <0.23.0-    , morpheus-graphql-server >=0.22.0 && <0.23.0+    , morpheus-graphql-code-gen-utils >=0.23.0 && <0.24.0+    , morpheus-graphql-core >=0.23.0 && <0.24.0+    , morpheus-graphql-server >=0.23.0 && <0.24.0     , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0@@ -56,24 +57,31 @@ executable morpheus   main-is: Main.hs   other-modules:+      CLI.Commands+      CLI.Config+      CLI.File+      CLI.Generator       Paths_morpheus_graphql_code_gen   hs-source-dirs:       app   ghc-options: -Wall   build-depends:-      base >=4.7.0 && <5.0.0+      Glob >=0.7.0 && <1.0.0+    , base >=4.7.0 && <5.0.0     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0     , file-embed >=0.0.10 && <1.0.0     , filepath >=1.1.0 && <1.5.0+    , morpheus-graphql-client     , morpheus-graphql-code-gen-    , morpheus-graphql-code-gen-utils >=0.22.0 && <0.23.0-    , morpheus-graphql-core >=0.22.0 && <0.23.0-    , morpheus-graphql-server >=0.22.0 && <0.23.0+    , morpheus-graphql-code-gen-utils+    , morpheus-graphql-core >=0.23.0 && <0.24.0+    , morpheus-graphql-server >=0.23.0 && <0.24.0     , optparse-applicative >=0.12.0 && <0.18.0     , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <1.3.0     , unordered-containers >=0.2.8 && <0.3.0+    , yaml >=0.8.32 && <1.0.0   default-language: Haskell2010
src/Data/Morpheus/CodeGen.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen-  ( printServerTypeDefinitions,-    parseServerTypeDefinitions,+  ( parseServerTypeDefinitions,     PrinterConfig (..),     CodeGenConfig (..),   )@@ -10,7 +9,6 @@  import Data.Morpheus.CodeGen.Server   ( PrinterConfig (..),-    printServerTypeDefinitions,   ) import Data.Morpheus.CodeGen.Server.Internal.AST   ( CodeGenConfig (..),
src/Data/Morpheus/CodeGen/Server.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Server@@ -6,22 +5,16 @@     PrinterConfig (..),     gqlDocument,     importServerTypeDefinitions,-    printServerTypeDefinitions,   ) where  import Data.ByteString.Lazy.Char8-  ( ByteString,-    readFile,+  ( readFile,   ) import Data.FileEmbed (makeRelativeToProject) import Data.Morpheus.CodeGen.Server.Internal.AST   ( CodeGenConfig (..),-    ServerDeclaration,   )-import Data.Morpheus.CodeGen.Server.Printing.Document-  ( renderDocument,-  ) import Data.Morpheus.CodeGen.Server.Printing.TH   ( compileDocument,     gqlDocument,@@ -35,9 +28,6 @@ newtype PrinterConfig = PrinterConfig   { moduleName :: String   }--printServerTypeDefinitions :: PrinterConfig -> [ServerDeclaration] -> ByteString-printServerTypeDefinitions PrinterConfig {moduleName} = renderDocument moduleName  importServerTypeDefinitions :: CodeGenConfig -> FilePath -> Q [Dec] importServerTypeDefinitions ctx rawSrc = do
src/Data/Morpheus/CodeGen/Server/Internal/AST.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Server.Internal.AST-  ( ModuleDefinition (..),-    CodeGenConfig (..),+  ( CodeGenConfig (..),     ServerDeclaration (..),     GQLTypeDefinition (..),     CONST,@@ -20,6 +20,7 @@     TypeValue (..),     InterfaceDefinition (..),     GQLDirectiveTypeClass (..),+    ServerMethod (..),   ) where @@ -28,19 +29,17 @@     CodeGenTypeName,     DerivingClass (..),     FIELD_TYPE_WRAPPER (..),+    TypeClassInstance (..),     TypeValue (..),   )-import Data.Morpheus.CodeGen.TH-  ( PrintExp (..),-    PrintType (..),-  )-import Data.Morpheus.Server.Types-  ( SCALAR,-    TYPE,-    enumDirective,-    fieldDirective,-    typeDirective,+import Data.Morpheus.CodeGen.Printer+  ( Printer (..),+    ignore,+    unpack,+    (.<>),   )+import Data.Morpheus.CodeGen.TH (PrintDec (..), PrintExp (..), ToName (..), apply, m', m_, printTypeSynonym)+import Data.Morpheus.Server.Types (SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective) import Data.Morpheus.Types.Internal.AST   ( CONST,     DirectiveLocation (..),@@ -52,16 +51,17 @@     Value,     unpackName,   )-import Language.Haskell.TH.Lib (appE, conT, varE)-import Prettyprinter (Pretty (..), (<+>))-import Relude--data ModuleDefinition = ModuleDefinition-  { moduleName :: Text,-    imports :: [(Text, [Text])],-    extensions :: [Text],-    types :: [ServerDeclaration]-  }+import Language.Haskell.TH.Lib (appE, varE)+import Prettyprinter+  ( Pretty (..),+    align,+    pretty,+    punctuate,+    vsep,+    (<+>),+  )+import Relude hiding (Show, optional, print, show)+import Prelude (Show (..))  data Kind   = Scalar@@ -72,9 +72,9 @@   pretty Type = "TYPE"   pretty Scalar = "SCALAR" -instance PrintType Kind where-  printType Scalar = conT ''SCALAR-  printType Type = conT ''TYPE+instance ToName Kind where+  toName Scalar = ''SCALAR+  toName Type = ''TYPE  data ServerDirectiveUsage   = TypeDirectiveUsage TypeValue@@ -96,8 +96,7 @@   { gqlTarget :: CodeGenTypeName,     gqlKind :: Kind,     gqlTypeDirectiveUses :: [ServerDirectiveUsage],-    gqlTypeDefaultValues :: Map Text (Value CONST),-    dropNamespace :: Maybe (TypeKind, Text)+    gqlTypeDefaultValues :: Map Text (Value CONST)   }   deriving (Show) @@ -108,6 +107,17 @@   }   deriving (Show) +instance PrintDec InterfaceDefinition where+  printDec InterfaceDefinition {..} =+    pure $+      printTypeSynonym+        aliasName+        [m_]+        ( apply+            ''TypeGuard+            [apply interfaceName [m'], apply unionName [m']]+        )+ data GQLDirectiveTypeClass = GQLDirectiveTypeClass   { directiveTypeName :: CodeGenTypeName,     directiveLocations :: [DirectiveLocation]@@ -115,13 +125,41 @@   deriving (Show)  data ServerDeclaration-  = GQLTypeInstance GQLTypeDefinition-  | GQLDirectiveInstance GQLDirectiveTypeClass+  = GQLTypeInstance Kind (TypeClassInstance ServerMethod)+  | GQLDirectiveInstance (TypeClassInstance ServerMethod)   | DataType CodeGenType   | ScalarType {scalarTypeName :: Text}   | InterfaceType InterfaceDefinition   deriving (Show) -newtype CodeGenConfig = CodeGenConfig-  { namespace :: Bool-  }+instance Pretty ServerDeclaration where+  pretty (InterfaceType InterfaceDefinition {..}) =+    "type"+      <+> ignore (print aliasName)+      <+> "m"+      <+> "="+      <+> "TypeGuard"+      <+> unpack (print interfaceName .<> "m")+      <+> unpack (print unionName .<> "m")+  -- TODO: on scalar we should render user provided type+  pretty ScalarType {..} = "type" <+> ignore (print scalarTypeName) <+> "= Int"+  pretty (DataType cgType) = pretty cgType+  pretty (GQLTypeInstance kind gql)+    | kind == Scalar = ""+    | otherwise = pretty gql+  pretty (GQLDirectiveInstance _) = "TODO: not supported"++newtype CodeGenConfig = CodeGenConfig {namespace :: Bool}++data ServerMethod+  = ServerMethodDefaultValues (Map Text (Value CONST))+  | ServerMethodDirectives [ServerDirectiveUsage]+  deriving (Show)++instance Pretty ServerMethod where+  pretty (ServerMethodDefaultValues x) = pretty (show x)+  pretty (ServerMethodDirectives dirs) = align $ vsep $ punctuate " <>" (map pretty dirs)++instance PrintExp ServerMethod where+  printExp (ServerMethodDefaultValues values) = [|values|]+  printExp (ServerMethodDirectives dirs) = foldr (appE . appE [|(<>)|] . printExp) [|mempty|] dirs
+ src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server.Interpreting.Directive+  ( getDirs,+    getNamespaceDirs,+    dirRename,+  )+where++import Data.Char (isUpper)+import Data.Morpheus.CodeGen.Internal.AST+  ( getFullName,+  )+import Data.Morpheus.CodeGen.Server.Internal.AST (ServerDirectiveUsage (..), TypeValue (..), unpackName)+import Data.Morpheus.CodeGen.Server.Interpreting.Utils+  ( CodeGenT,+    TypeContext (..),+    getEnumName,+    getFieldName,+    inType,+    lookupFieldType,+  )+import Data.Morpheus.Core (internalSchema, render)+import Data.Morpheus.Internal.Utils (IsMap, selectOr)+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    ArgumentDefinition (..),+    CONST,+    DataEnumValue (..),+    Description,+    Directive (Directive, directiveArgs, directiveName),+    DirectiveDefinition (..),+    FieldDefinition (..),+    FieldName,+    FieldsDefinition,+    Name,+    ObjectEntry (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    TypeRef (..),+  )+import qualified Data.Morpheus.Types.Internal.AST as AST+import Data.Text (head)+import Relude hiding (ByteString, get, head)++getNamespaceDirs :: MonadReader (TypeContext s) m => Text -> m [ServerDirectiveUsage]+getNamespaceDirs genTypeName = do+  namespaces <- asks hasNamespace+  pure [TypeDirectiveUsage (dirDropNamespace genTypeName) | namespaces]++descDirective :: Maybe Description -> [TypeValue]+descDirective desc = map describe (maybeToList desc)+  where+    describe x = TypeValueObject "Describe" [("text", TypeValueString x)]++dirDropNamespace :: Text -> TypeValue+dirDropNamespace name = TypeValueObject "DropNamespace" [("dropNamespace", TypeValueString name)]++dirRename :: Name t -> TypeValue+dirRename name = TypeValueObject "Rename" [("newName", TypeValueString (unpackName name))]++class Meta a where+  getDirs :: MonadFail m => a -> CodeGenT m [ServerDirectiveUsage]++instance (Meta a) => Meta (Maybe a) where+  getDirs (Just x) = getDirs x+  getDirs _ = pure []++instance Meta (TypeDefinition c CONST) where+  getDirs TypeDefinition {typeContent, typeDirectives, typeDescription} = do+    contentD <- getDirs typeContent+    typeD <- traverse transform (toList typeDirectives)+    pure (contentD <> typeD <> map TypeDirectiveUsage (descDirective typeDescription))+    where+      transform v = TypeDirectiveUsage <$> directiveTypeValue v++instance Meta (TypeContent a c CONST) where+  getDirs DataObject {objectFields} = getDirs objectFields+  getDirs DataInputObject {inputObjectFields} = getDirs inputObjectFields+  getDirs DataInterface {interfaceFields} = getDirs interfaceFields+  getDirs DataEnum {enumMembers} = concat <$> traverse getDirs enumMembers+  getDirs _ = pure []++instance Meta (DataEnumValue CONST) where+  getDirs DataEnumValue {enumName, enumDirectives, enumDescription} = do+    dirs <- traverse directiveTypeValue (toList enumDirectives)+    name <- getFullName <$> getEnumName enumName+    let renameEnum = [EnumDirectiveUsage name (dirRename enumName) | not (isUpperCase enumName)]+    pure $ renameEnum <> map (EnumDirectiveUsage name) (dirs <> descDirective enumDescription)++instance Meta (FieldsDefinition c CONST) where+  getDirs = fmap concat . traverse getDirs . toList++instance Meta (FieldDefinition c CONST) where+  getDirs FieldDefinition {fieldName, fieldDirectives, fieldDescription} = do+    dirs <- traverse directiveTypeValue (toList fieldDirectives)+    name <- getFieldName fieldName+    let renameField = [FieldDirectiveUsage name (dirRename fieldName) | isUpperCase fieldName]+    pure $ renameField <> map (FieldDirectiveUsage name) (dirs <> descDirective fieldDescription)++directiveTypeValue :: MonadFail m => Directive CONST -> CodeGenT m TypeValue+directiveTypeValue Directive {..} = inType typeContext $ do+  dirs <- getDirective directiveName+  TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs)+  where+    (typeContext, typename) = renderDirectiveTypeName directiveName++nativeDirectives :: AST.DirectivesDefinition CONST+nativeDirectives = AST.directiveDefinitions internalSchema++isUpperCase :: Name t -> Bool+isUpperCase = isUpper . head . unpackName++getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST)+getDirective directiveName = do+  dirs <- asks directiveDefinitions+  case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of+    Just dir -> pure dir+    _ -> selectOr (fail $ "unknown directive" <> show directiveName) pure directiveName nativeDirectives++renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)+renderDirectiveTypeName "deprecated" = (Nothing, "Deprecated")+renderDirectiveTypeName name = (Just (coerce name), coerce name)++renderArgumentValue ::+  (IsMap FieldName c, MonadFail m) =>+  c (Argument CONST) ->+  ArgumentDefinition s ->+  ReaderT (TypeContext CONST) m (FieldName, TypeValue)+renderArgumentValue args ArgumentDefinition {..} = do+  let dirName = AST.fieldName argument+  gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args+  typeValue <- mapWrappedValue (AST.fieldType argument) gqlValue+  fName <- getFieldName dirName+  pure (fName, typeValue)++mapWrappedValue :: MonadFail m => TypeRef -> AST.Value CONST -> CodeGenT m TypeValue+mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value+  | isRequired = mapValue name value+  | value == AST.Null = pure (TypedValueMaybe Nothing)+  | otherwise = TypedValueMaybe . Just <$> mapValue name value+mapWrappedValue (TypeRef name (AST.TypeList elems isRequired)) d = case d of+  AST.Null | not isRequired -> pure (TypedValueMaybe Nothing)+  (AST.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs+  value -> expected "list" value++mapValue :: MonadFail m => TypeName -> AST.Value CONST -> CodeGenT m TypeValue+mapValue name (AST.List xs) = TypeValueList <$> traverse (mapValue name) xs+mapValue _ (AST.Enum name) = pure $ TypeValueObject name []+mapValue name (AST.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields)+mapValue _ (AST.Scalar x) = mapScalarValue x+mapValue t v = expected (show t) v++mapScalarValue :: MonadFail m => AST.ScalarValue -> CodeGenT m TypeValue+mapScalarValue (AST.Int x) = pure $ TypeValueNumber (fromIntegral x)+mapScalarValue (AST.Float x) = pure $ TypeValueNumber x+mapScalarValue (AST.String x) = pure $ TypeValueString x+mapScalarValue (AST.Boolean x) = pure $ TypeValueBool x+mapScalarValue (AST.Value _) = fail "JSON objects are not supported!"++expected :: MonadFail m => String -> AST.Value CONST -> CodeGenT m TypeValue+expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!")++mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> CodeGenT m (FieldName, TypeValue)+mapField tName ObjectEntry {..} = do+  t <- lookupFieldType tName entryName+  value <- mapWrappedValue t entryValue+  pure (entryName, value)
src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -7,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Server.Interpreting.Transform@@ -16,10 +16,13 @@  import Data.ByteString.Lazy.Char8 (ByteString) import Data.Morpheus.CodeGen.Internal.AST-  ( CodeGenConstructor (..),+  ( AssociatedType (..),+    CodeGenConstructor (..),     CodeGenField (..),     CodeGenType (..),-    CodeGenTypeName (CodeGenTypeName),+    CodeGenTypeName (CodeGenTypeName, typeParameters),+    MethodArgument (..),+    TypeClassInstance (..),     fromTypeName,     getFullName,   )@@ -27,45 +30,36 @@   ( CodeGenConfig (..),     DerivingClass (..),     FIELD_TYPE_WRAPPER (..),-    GQLDirectiveTypeClass (..),     GQLTypeDefinition (..),     InterfaceDefinition (..),     Kind (..),     ServerDeclaration (..),     ServerDirectiveUsage (..),-    TypeValue (..),-  )-import Data.Morpheus.CodeGen.TH-  ( ToName (toName),+    ServerMethod (..),   )+import Data.Morpheus.CodeGen.Server.Interpreting.Directive (dirRename, getDirs, getNamespaceDirs)+import Data.Morpheus.CodeGen.Server.Interpreting.Utils (CodeGenMonad (printWarnings), CodeGenT, TypeContext (..), getEnumName, getFieldName, inType, isParamResolverType, isSubscription)+import Data.Morpheus.CodeGen.TH (ToName (..)) import Data.Morpheus.CodeGen.Utils-  ( camelCaseFieldName,-    camelCaseTypeName,+  ( camelCaseTypeName,     toHaskellTypeName,   )-import Data.Morpheus.Core (internalSchema, parseDefinitions, render)-import Data.Morpheus.Error (gqlWarnings, renderGQLErrors)-import Data.Morpheus.Internal.Ext (GQLResult, Result (..))-import Data.Morpheus.Internal.Utils (IsMap, selectOr)-import Data.Morpheus.Server.Types (Arg, SubscriptionField)+import Data.Morpheus.Core (parseDefinitions)+import Data.Morpheus.Error (renderGQLErrors)+import Data.Morpheus.Internal.Ext (Result (..))+import Data.Morpheus.Server.Types (Arg, DIRECTIVE_LOCATIONS, GQLDirective, GQLType (..), SubscriptionField) import Data.Morpheus.Types.Internal.AST   ( ANY,-    Argument (..),     ArgumentDefinition (..),     CONST,     DataEnumValue (..),-    Description,-    Directive (Directive, directiveArgs, directiveName),     DirectiveDefinition (..),     FieldContent (..),     FieldDefinition (..),     FieldName,     FieldsDefinition,-    GQLError,     IN,     OUT,-    ObjectEntry (..),-    OperationType (Subscription),     RawTypeDefinition (..),     TRUE,     TypeContent (..),@@ -78,58 +72,12 @@     isPossibleInterfaceType,     isResolverType,     kindOf,-    lookupWith,     packName,     unpackName,   ) import qualified Data.Morpheus.Types.Internal.AST as AST-import qualified Data.Morpheus.Types.Internal.AST as V-import Language.Haskell.TH-  ( Dec (..),-    Info (..),-    Q,-    TyVarBndr,-    reify,-  ) import Relude hiding (ByteString, get) -type ServerQ m = ReaderT (TypeContext CONST) m--class (Monad m, MonadFail m) => CodeGenMonad m where-  isParametrizedType :: TypeName -> m Bool-  printWarnings :: [GQLError] -> m ()--isParametrizedHaskellType :: Info -> Bool-isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x-isParametrizedHaskellType _ = False--#if MIN_VERSION_template_haskell(2,17,0)-getTypeVariables :: Dec -> [TyVarBndr ()]-#else-getTypeVariables :: Dec -> [TyVarBndr]-#endif-getTypeVariables (DataD _ _ args _ _ _) = args-getTypeVariables (NewtypeD _ _ args _ _ _) = args-getTypeVariables (TySynD _ args _) = args-getTypeVariables _ = []--instance CodeGenMonad Q where-  isParametrizedType name = isParametrizedHaskellType <$> reify (toName name)-  printWarnings = gqlWarnings--instance CodeGenMonad GQLResult where-  isParametrizedType _ = pure False-  printWarnings _ = pure ()--data TypeContext s = TypeContext-  { toArgsTypeName :: FieldName -> TypeName,-    typeDefinitions :: [TypeDefinition ANY s],-    directiveDefinitions :: [DirectiveDefinition s],-    currentTypeName :: Maybe TypeName,-    currentKind :: Maybe TypeKind,-    hasNamespace :: Bool-  }- parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerDeclaration] parseServerTypeDefinitions ctx txt =   case parseDefinitions txt of@@ -153,7 +101,7 @@           { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef),             typeDefinitions,             directiveDefinitions,-            currentTypeName = Just (typeName typeDef),+            currentTypeName = Just (packName $ toHaskellTypeName $ typeName typeDef),             currentKind = Just (kindOf typeDef),             hasNamespace = namespace           }@@ -162,7 +110,7 @@         ( do             fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs)             let typename = coerce directiveDefinitionName-            dropNamespace <- defineTypeOptions KindInputObject (unpackName typename)+            namespaceDirs <- getNamespaceDirs (unpackName typename)             let cgTypeName = fromTypeName typename             pure               [ DataType@@ -172,17 +120,19 @@                       cgDerivations = [SHOW, GENERIC]                     },                 GQLDirectiveInstance-                  GQLDirectiveTypeClass-                    { directiveTypeName = cgTypeName,-                      directiveLocations = directiveDefinitionLocations+                  TypeClassInstance+                    { typeClassName = ''GQLDirective,+                      typeClassContext = [],+                      typeClassTarget = cgTypeName,+                      assoc = [(''DIRECTIVE_LOCATIONS, AssociatedLocations directiveDefinitionLocations)],+                      typeClassMethods = []                     },-                GQLTypeInstance+                gqlTypeToInstance                   GQLTypeDefinition                     { gqlTarget = cgTypeName,                       gqlKind = Type,                       gqlTypeDefaultValues = mempty,-                      gqlTypeDirectiveUses = [],-                      dropNamespace+                      gqlTypeDirectiveUses = namespaceDirs                     }               ]         )@@ -196,14 +146,6 @@           }     generateTypes _ = pure [] -defineTypeOptions :: MonadReader (TypeContext s) m => TypeKind -> Text -> m (Maybe (TypeKind, Text))-defineTypeOptions kind tName = do-  namespaces <- asks hasNamespace-  pure $ if namespaces then Just (kind, tName) else Nothing--inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a-inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing})- mkInterfaceName :: TypeName -> TypeName mkInterfaceName = ("Interface" <>) @@ -213,37 +155,36 @@ genTypeDefinition ::   CodeGenMonad m =>   TypeDefinition ANY CONST ->-  ServerQ m [ServerDeclaration]+  CodeGenT m [ServerDeclaration] genTypeDefinition   typeDef@TypeDefinition {typeName = originalTypeName, typeContent} =     case tKind of       KindScalar -> do         scalarGQLType <- deriveGQL-        pure-          [ ScalarType (toHaskellTypeName typeName),-            scalarGQLType-          ]+        pure [ScalarType (toHaskellTypeName typeName), scalarGQLType]       _ -> genTypeContent originalTypeName typeContent >>= withType     where-      typeName = case typeContent of-        DataInterface {} -> mkInterfaceName originalTypeName-        _ -> originalTypeName+      typeName+        | tKind == KindInterface = mkInterfaceName originalTypeName+        | otherwise = originalTypeName       tKind = kindOf typeDef-      cgTypeName = CodeGenTypeName [] ["m" | isResolverType tKind] (packName $ toHaskellTypeName typeName)+      hsTypeName = packName $ toHaskellTypeName typeName+      cgTypeName = CodeGenTypeName [] ["m" | isResolverType tKind] hsTypeName+      renameDir = [TypeDirectiveUsage (dirRename originalTypeName) | originalTypeName /= hsTypeName]       deriveGQL = do-        gqlTypeDirectiveUses <- getDirs typeDef-        dropNamespace <- defineTypeOptions tKind (unpackName typeName)+        namespaceDirs <- getNamespaceDirs (unpackName hsTypeName)+        dirs <- getDirs typeDef+        -- TODO: here         pure $-          GQLTypeInstance $+          gqlTypeToInstance             GQLTypeDefinition               { gqlTarget = cgTypeName,-                gqlTypeDirectiveUses,+                gqlTypeDirectiveUses = renameDir <> namespaceDirs <> dirs,                 gqlKind = derivingKind tKind,                 gqlTypeDefaultValues =                   fromList $                     mapMaybe getDefaultValue $-                      getInputFields typeDef,-                dropNamespace+                      getInputFields typeDef               }       cgDerivations = derivesClasses (isResolverType tKind)       -------------------------@@ -271,34 +212,20 @@   where     argTName = camelCaseTypeName [fieldName] "Args" -isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> m Bool-isParametrizedResolverType "__TypeKind" _ = pure False-isParametrizedResolverType "Boolean" _ = pure False-isParametrizedResolverType "String" _ = pure False-isParametrizedResolverType "Int" _ = pure False-isParametrizedResolverType "Float" _ = pure False-isParametrizedResolverType name lib = case lookupWith typeName name lib of-  Just x -> pure (isResolverType x)-  Nothing -> isParametrizedType name--isSubscription :: TypeKind -> Bool-isSubscription (KindObject (Just Subscription)) = True-isSubscription _ = False- mkObjectField ::   CodeGenMonad m =>   FieldDefinition OUT CONST ->-  ServerQ m CodeGenField+  CodeGenT m CodeGenField mkObjectField   FieldDefinition     { fieldName = fName,       fieldContent,       fieldType = TypeRef {typeConName, typeWrappers}     } = do-    isParametrized <- lift . isParametrizedResolverType typeConName =<< asks typeDefinitions+    isParametrized <- isParamResolverType typeConName     genName <- asks toArgsTypeName     kind <- asks currentKind-    fieldName <- renderFieldName fName+    fieldName <- getFieldName fName     pure       CodeGenField         { fieldType = packName (toHaskellTypeName typeConName),@@ -329,7 +256,21 @@   = ConsIN [CodeGenConstructor]   | ConsOUT [ServerDeclaration] [CodeGenConstructor] -genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerDeclaration]+gqlTypeToInstance :: GQLTypeDefinition -> ServerDeclaration+gqlTypeToInstance GQLTypeDefinition {..} =+  GQLTypeInstance+    gqlKind+    TypeClassInstance+      { typeClassName = ''GQLType,+        typeClassContext = map ((''Typeable,) . toName) (typeParameters gqlTarget),+        typeClassTarget = gqlTarget,+        assoc = [(''KIND, AssociatedTypeName (toName gqlKind))],+        typeClassMethods =+          [('defaultValues, ProxyArgument, ServerMethodDefaultValues gqlTypeDefaultValues) | not (null gqlTypeDefaultValues)]+            <> [('directives, ProxyArgument, ServerMethodDirectives gqlTypeDirectiveUses) | not (null gqlTypeDirectiveUses)]+      }++genInterfaceUnion :: Monad m => TypeName -> CodeGenT m [ServerDeclaration] genInterfaceUnion interfaceName =   mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName)     <$> asks typeDefinitions@@ -344,13 +285,12 @@               cgConstructors = map (mkUnionFieldDefinition tName) members,               cgDerivations = derivesClasses True             },-        GQLTypeInstance+        gqlTypeToInstance           GQLTypeDefinition             { gqlTarget = possTypeName,               gqlKind = Type,               gqlTypeDirectiveUses = empty,-              gqlTypeDefaultValues = mempty,-              dropNamespace = Nothing+              gqlTypeDefaultValues = mempty             }       ]       where@@ -358,29 +298,14 @@     mkGuardWithPossibleType = InterfaceType . InterfaceDefinition interfaceName (mkInterfaceName interfaceName)     tName = mkPossibleTypesName interfaceName -renderFieldName :: Monad m => FieldName -> ServerQ m FieldName-renderFieldName fieldName = do-  TypeContext {hasNamespace, currentTypeName} <- ask-  pure $-    if hasNamespace-      then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName-      else fieldName--mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m CodeGenConstructor-mkConsEnum name DataEnumValue {enumName} = do-  namespace <- asks hasNamespace-  pure-    CodeGenConstructor-      { constructorName =-          if namespace-            then CodeGenTypeName [coerce name] [] enumName-            else fromTypeName enumName,-        constructorFields = []-      }+mkConsEnum :: Monad m => DataEnumValue CONST -> CodeGenT m CodeGenConstructor+mkConsEnum DataEnumValue {enumName} = do+  constructorName <- getEnumName enumName+  pure CodeGenConstructor {constructorName, constructorFields = []} -renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m CodeGenField+renderDataField :: Monad m => FieldDefinition c CONST -> CodeGenT m CodeGenField renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do-  fieldName <- renderFieldName fName+  fieldName <- getFieldName fName   let wrappers = [GQL_WRAPPER typeWrappers]   let fieldType = packName (toHaskellTypeName typeConName)   let fieldIsNullable = isNullable typeWrappers@@ -390,9 +315,9 @@   CodeGenMonad m =>   TypeName ->   TypeContent TRUE ANY CONST ->-  ServerQ m BuildPlan+  CodeGenT m BuildPlan genTypeContent _ DataScalar {} = pure (ConsIN [])-genTypeContent typeName (DataEnum tags) = ConsIN <$> traverse (mkConsEnum typeName) tags+genTypeContent _ (DataEnum tags) = ConsIN <$> traverse mkConsEnum tags genTypeContent typeName (DataInputObject fields) =   ConsIN . mkObjectCons typeName <$> traverse renderDataField (toList fields) genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported"@@ -434,10 +359,10 @@   where     constructorName = CodeGenTypeName [coerce typeName] [] memberName -genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]+genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> CodeGenT m [ServerDeclaration] genArgumentTypes = fmap concat . traverse genArgumentType . toList -genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration]+genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> CodeGenT m [ServerDeclaration] genArgumentType   FieldDefinition     { fieldName,@@ -449,8 +374,8 @@           let argumentFields = argument <$> toList arguments           fields <- traverse renderDataField argumentFields           let typename = toHaskellTypeName tName-          gqlTypeDirectiveUses <- concat <$> traverse getDirs argumentFields-          dropNamespace <- defineTypeOptions KindInputObject typename+          namespaceDirs <- getNamespaceDirs typename+          dirs <- concat <$> traverse getDirs argumentFields           let cgTypeName = fromTypeName (packName typename)           pure             [ DataType@@ -459,155 +384,24 @@                     cgConstructors = mkObjectCons tName fields,                     cgDerivations = derivesClasses False                   },-              GQLTypeInstance+              gqlTypeToInstance                 GQLTypeDefinition                   { gqlTarget = cgTypeName,                     gqlKind = Type,                     gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields),-                    gqlTypeDirectiveUses,-                    dropNamespace+                    gqlTypeDirectiveUses = namespaceDirs <> dirs                   }             ] genArgumentType _ = pure [] --- mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description)--- mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription-------class Meta a where-  getDirs :: MonadFail m => a -> ServerQ m [ServerDirectiveUsage]--instance (Meta a) => Meta (Maybe a) where-  getDirs (Just x) = getDirs x-  getDirs _ = pure []--descDirective :: Maybe Description -> [TypeValue]-descDirective desc = map describe (maybeToList desc)-  where-    describe x = TypeValueObject "Describe" [("text", TypeValueString x)]--instance Meta (TypeDefinition c CONST) where-  getDirs TypeDefinition {typeContent, typeDirectives, typeDescription} = do-    contentD <- getDirs typeContent-    typeD <- traverse transform (toList typeDirectives)-    pure (contentD <> typeD <> map TypeDirectiveUsage (descDirective typeDescription))-    where-      transform v = TypeDirectiveUsage <$> directiveTypeValue v--instance Meta (TypeContent a c CONST) where-  getDirs DataObject {objectFields} = getDirs objectFields-  getDirs DataInputObject {inputObjectFields} = getDirs inputObjectFields-  getDirs DataInterface {interfaceFields} = getDirs interfaceFields-  getDirs DataEnum {enumMembers} = concat <$> traverse getDirs enumMembers-  getDirs _ = pure []--instance Meta (DataEnumValue CONST) where-  getDirs DataEnumValue {enumName, enumDirectives, enumDescription} = do-    dirs <- traverse directiveTypeValue (toList enumDirectives)-    pure $ map (EnumDirectiveUsage enumName) (dirs <> descDirective enumDescription)--instance Meta (FieldsDefinition c CONST) where-  getDirs = fmap concat . traverse getDirs . toList--instance Meta (FieldDefinition c CONST) where-  getDirs FieldDefinition {fieldName, fieldDirectives, fieldDescription} = do-    dirs <- traverse directiveTypeValue (toList fieldDirectives)-    pure $ map (FieldDirectiveUsage fieldName) (dirs <> descDirective fieldDescription)- getInputFields :: TypeDefinition c s -> [FieldDefinition IN s] getInputFields TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = toList inputObjectFields getInputFields _ = [] -getDefaultValue :: FieldDefinition c s -> Maybe (Text, V.Value s)+getDefaultValue :: FieldDefinition c s -> Maybe (Text, AST.Value s) getDefaultValue   FieldDefinition     { fieldName,       fieldContent = Just DefaultInputValue {defaultInputValue}     } = Just (unpackName fieldName, defaultInputValue) getDefaultValue _ = Nothing--nativeDirectives :: V.DirectivesDefinition CONST-nativeDirectives = AST.directiveDefinitions internalSchema--getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST)-getDirective directiveName = do-  dirs <- asks directiveDefinitions-  case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of-    Just dir -> pure dir-    _ -> selectOr (fail $ "unknown directive" <> show directiveName) pure directiveName nativeDirectives--directiveTypeValue :: MonadFail m => Directive CONST -> ServerQ m TypeValue-directiveTypeValue Directive {..} = inType typeContext $ do-  dirs <- getDirective directiveName-  TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs)-  where-    (typeContext, typename) = renderDirectiveTypeName directiveName--renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)-renderDirectiveTypeName "deprecated" = (Nothing, "Deprecated")-renderDirectiveTypeName name = (Just (coerce name), coerce name)--renderArgumentValue ::-  (IsMap FieldName c, MonadFail m) =>-  c (Argument CONST) ->-  ArgumentDefinition s ->-  ReaderT (TypeContext CONST) m (FieldName, TypeValue)-renderArgumentValue args ArgumentDefinition {..} = do-  let dirName = AST.fieldName argument-  gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args-  typeValue <- mapWrappedValue (AST.fieldType argument) gqlValue-  fName <- renderFieldName dirName-  pure (fName, typeValue)--notFound :: MonadFail m => String -> String -> m a-notFound name at = fail $ "can't found " <> name <> "at " <> at <> "!"--lookupType :: MonadFail m => TypeName -> ServerQ m (TypeDefinition ANY CONST)-lookupType name = do-  types <- asks typeDefinitions-  case find (\t -> typeName t == name) types of-    Just x -> pure x-    Nothing -> notFound (show name) "type definitions"--lookupValueFieldType :: MonadFail m => TypeName -> FieldName -> ServerQ m TypeRef-lookupValueFieldType name fieldName = do-  TypeDefinition {typeContent} <- lookupType name-  case typeContent of-    DataInputObject fields -> do-      FieldDefinition {fieldType} <- selectOr (notFound (show fieldName) (show name)) pure fieldName fields-      pure fieldType-    _ -> notFound "input object" (show name)--mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue)-mapField tName ObjectEntry {..} = do-  t <- lookupValueFieldType tName entryName-  value <- mapWrappedValue t entryValue-  pure (entryName, value)--expected :: MonadFail m => String -> V.Value CONST -> ServerQ m TypeValue-expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!")--mapWrappedValue :: MonadFail m => TypeRef -> V.Value CONST -> ServerQ m TypeValue-mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value-  | isRequired = mapValue name value-  | value == V.Null = pure (TypedValueMaybe Nothing)-  | otherwise = TypedValueMaybe . Just <$> mapValue name value-mapWrappedValue (TypeRef name (AST.TypeList elems isRequired)) d = case d of-  V.Null | not isRequired -> pure (TypedValueMaybe Nothing)-  (V.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs-  value -> expected "list" value--mapValue :: MonadFail m => TypeName -> V.Value CONST -> ServerQ m TypeValue-mapValue name (V.List xs) = TypeValueList <$> traverse (mapValue name) xs-mapValue _ (V.Enum name) = pure $ TypeValueObject name []-mapValue name (V.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields)-mapValue _ (V.Scalar x) = mapScalarValue x-mapValue t v = expected (show t) v--mapScalarValue :: MonadFail m => V.ScalarValue -> ServerQ m TypeValue-mapScalarValue (V.Int x) = pure $ TypeValueNumber (fromIntegral x)-mapScalarValue (V.Float x) = pure $ TypeValueNumber x-mapScalarValue (V.String x) = pure $ TypeValueString x-mapScalarValue (V.Boolean x) = pure $ TypeValueBool x-mapScalarValue (V.Value _) = fail "JSON objects are not supported!"
+ src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server.Interpreting.Utils+  ( CodeGenMonad (..),+    TypeContext (..),+    CodeGenT,+    getFieldName,+    getEnumName,+    isParamResolverType,+    lookupFieldType,+    isSubscription,+    inType,+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( CodeGenTypeName (CodeGenTypeName),+    fromTypeName,+  )+import Data.Morpheus.CodeGen.TH+  ( ToName (toName),+  )+import Data.Morpheus.CodeGen.Utils+  ( camelCaseFieldName,+  )+import Data.Morpheus.Error (gqlWarnings)+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Internal.Utils (selectOr)+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    CONST,+    DirectiveDefinition (..),+    FieldDefinition (..),+    FieldName,+    GQLError,+    OperationType (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeKind (..),+    TypeName,+    TypeRef (..),+    isResolverType,+    lookupWith,+  )+import Language.Haskell.TH+  ( Dec (..),+    Info (..),+    Q,+    TyVarBndr,+    reify,+  )+import Relude hiding (ByteString, get)++type CodeGenT m = ReaderT (TypeContext CONST) m++data TypeContext s = TypeContext+  { toArgsTypeName :: FieldName -> TypeName,+    typeDefinitions :: [TypeDefinition ANY s],+    directiveDefinitions :: [DirectiveDefinition s],+    currentTypeName :: Maybe TypeName,+    currentKind :: Maybe TypeKind,+    hasNamespace :: Bool+  }++getFieldName :: Monad m => FieldName -> CodeGenT m FieldName+getFieldName fieldName = do+  TypeContext {hasNamespace, currentTypeName} <- ask+  pure $+    if hasNamespace+      then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName+      else fieldName++getEnumName :: MonadReader (TypeContext s) m => TypeName -> m CodeGenTypeName+getEnumName enumName = do+  TypeContext {hasNamespace, currentTypeName} <- ask+  pure $+    if hasNamespace+      then CodeGenTypeName (map coerce $ maybeToList currentTypeName) [] enumName+      else fromTypeName enumName++class (Monad m, MonadFail m) => CodeGenMonad m where+  isParametrizedType :: TypeName -> m Bool+  printWarnings :: [GQLError] -> m ()++instance CodeGenMonad Q where+  isParametrizedType name = isParametrizedHaskellType <$> reify (toName name)+  printWarnings = gqlWarnings++instance CodeGenMonad GQLResult where+  isParametrizedType _ = pure False+  printWarnings _ = pure ()++-- Utils: is Parametrized type++#if MIN_VERSION_template_haskell(2,17,0)+getTypeVariables :: Dec -> [TyVarBndr ()]+#else+getTypeVariables :: Dec -> [TyVarBndr]+#endif+getTypeVariables (DataD _ _ args _ _ _) = args+getTypeVariables (NewtypeD _ _ args _ _ _) = args+getTypeVariables (TySynD _ args _) = args+getTypeVariables _ = []++isParametrizedHaskellType :: Info -> Bool+isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x+isParametrizedHaskellType _ = False++isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> CodeGenT m Bool+isParametrizedResolverType "__TypeKind" _ = pure False+isParametrizedResolverType "Boolean" _ = pure False+isParametrizedResolverType "String" _ = pure False+isParametrizedResolverType "Int" _ = pure False+isParametrizedResolverType "Float" _ = pure False+isParametrizedResolverType name lib = case lookupWith typeName name lib of+  Just x -> pure (isResolverType x)+  Nothing -> lift (isParametrizedType name)++isParamResolverType :: CodeGenMonad m => TypeName -> ReaderT (TypeContext CONST) m Bool+isParamResolverType typeConName =+  isParametrizedResolverType typeConName =<< asks typeDefinitions++notFoundError :: MonadFail m => String -> String -> m a+notFoundError name at = fail $ "can't found " <> name <> "at " <> at <> "!"++lookupType :: MonadFail m => TypeName -> CodeGenT m (TypeDefinition ANY CONST)+lookupType name = do+  types <- asks typeDefinitions+  case find (\t -> typeName t == name) types of+    Just x -> pure x+    Nothing -> notFoundError (show name) "type definitions"++lookupFieldType :: MonadFail m => TypeName -> FieldName -> CodeGenT m TypeRef+lookupFieldType name fieldName = do+  TypeDefinition {typeContent} <- lookupType name+  case typeContent of+    DataInputObject fields -> do+      FieldDefinition {fieldType} <- selectOr (notFoundError (show fieldName) (show name)) pure fieldName fields+      pure fieldType+    _ -> notFoundError "input object" (show name)++isSubscription :: TypeKind -> Bool+isSubscription (KindObject (Just Subscription)) = True+isSubscription _ = False++inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a+inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing})
− src/Data/Morpheus/CodeGen/Server/Printing/Document.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.CodeGen.Server.Printing.Document-  ( renderDocument,-  )-where--import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..))-import Data.Morpheus.CodeGen.Printer-  ( Printer (..),-    ignore,-    optional,-    renderExtension,-    renderImport,-    unpack,-  )-import Data.Morpheus.CodeGen.Server.Internal.AST-  ( GQLTypeDefinition (..),-    Kind (..),-    ModuleDefinition (..),-    ServerDeclaration (..),-    ServerDirectiveUsage (..),-    TypeKind,-  )-import Data.Text-  ( pack,-  )-import qualified Data.Text.Lazy as LT-  ( fromStrict,-  )-import Data.Text.Lazy.Encoding (encodeUtf8)-import Prettyprinter-  ( Doc,-    align,-    indent,-    line,-    pretty,-    punctuate,-    tupled,-    vsep,-    (<+>),-  )-import Relude hiding (ByteString, encodeUtf8, optional, print)--renderDocument :: String -> [ServerDeclaration] -> ByteString-renderDocument moduleName types =-  encodeUtf8 $-    LT.fromStrict $-      pack $-        show $-          renderModuleDefinition-            ModuleDefinition-              { moduleName = pack moduleName,-                imports =-                  [ ("Data.Data", ["Typeable"]),-                    ("Data.Morpheus.Kind", ["TYPE"]),-                    ("Data.Morpheus.Types", ["*"]),-                    ("Data.Morpheus", []),-                    ("Data.Text", ["Text"]),-                    ("GHC.Generics", ["Generic"])-                  ],-                extensions =-                  [ "DeriveGeneric",-                    "TypeFamilies",-                    "OverloadedStrings",-                    "DataKinds",-                    "DuplicateRecordFields"-                  ],-                types-              }--renderModuleDefinition :: ModuleDefinition -> Doc n-renderModuleDefinition-  ModuleDefinition-    { extensions,-      moduleName,-      imports,-      types-    } =-    vsep (map renderExtension extensions)-      <> line-      <> line-      <> "module"-      <+> pretty moduleName-      <+> "where"-        <> line-        <> line-        <> vsep (map renderImport imports)-        <> line-        <> line-        <> either (error . show) id (renderTypes types)--type Result = Either Text--renderTypes :: [ServerDeclaration] -> Either Text (Doc ann)-renderTypes = fmap vsep . traverse render--class RenderType a where-  render :: a -> Result (Doc ann)--instance RenderType ServerDeclaration where-  render InterfaceType {} = fail "not supported"-  -- TODO: on scalar we should render user provided type-  render ScalarType {scalarTypeName} =-    pure $ "type" <+> ignore (print scalarTypeName) <+> "= Int"-  render (DataType cgType) = pure (pretty cgType)-  render (GQLTypeInstance gqlType) = pure $ renderGQLType gqlType-  render (GQLDirectiveInstance _) = fail "not supported"--renderTypeableConstraints :: [Text] -> Doc n-renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>"--defineTypeOptions :: Maybe (TypeKind, Text) -> [Doc n]-defineTypeOptions (Just (kind, tName)) = ["typeOptions _ = dropNamespaceOptions" <+> "(" <> pretty (show kind :: String) <> ")" <+> pretty (show tName :: String)]-defineTypeOptions _ = []--renderGQLType :: GQLTypeDefinition -> Doc ann-renderGQLType gql@GQLTypeDefinition {..}-  | gqlKind == Scalar = ""-  | otherwise =-      "instance"-        <> optional renderTypeableConstraints (typeParameters gqlTarget)-        <+> "GQLType"-        <+> typeHead-        <+> "where"-          <> line-          <> indent 2 (vsep (renderMethods typeHead gql <> defineTypeOptions dropNamespace))-  where-    typeHead = unpack (print gqlTarget)--renderMethods :: Doc n -> GQLTypeDefinition -> [Doc n]-renderMethods typeHead GQLTypeDefinition {..} =-  ["type KIND" <+> typeHead <+> "=" <+> pretty gqlKind]-    <> ["directives _=" <+> renderDirectiveUsages gqlTypeDirectiveUses | not (null gqlTypeDirectiveUses)]--renderDirectiveUsages :: [ServerDirectiveUsage] -> Doc n-renderDirectiveUsages = align . vsep . punctuate " <>" . map pretty
src/Data/Morpheus/CodeGen/Server/Printing/TH.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Server.Printing.TH@@ -13,40 +9,17 @@   ) where -import qualified Data.ByteString.Lazy.Char8 as LB-import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..))+import Data.ByteString.Lazy.Char8 (ByteString, pack) import Data.Morpheus.CodeGen.Server.Internal.AST   ( CodeGenConfig (..),-    GQLDirectiveTypeClass (..),-    GQLTypeDefinition (..),-    InterfaceDefinition (..),     ServerDeclaration (..),-    ServerDirectiveUsage,-    TypeKind,   ) import Data.Morpheus.CodeGen.Server.Interpreting.Transform   ( parseServerTypeDefinitions,   ) import Data.Morpheus.CodeGen.TH-  ( PrintExp (..),-    PrintType (..),-    ToName (..),-    apply,-    m',-    m_,-    printDec,-    printTypeClass,-    printTypeSynonym,-    toCon,-    _',-  )-import Data.Morpheus.Server.Types-  ( GQLDirective (..),-    GQLType (..),-    TypeGuard (..),-    dropNamespaceOptions,+  ( PrintDec (..),   )-import Data.Morpheus.Types.Internal.AST (DirectiveLocation) import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Relude hiding (ByteString, Type)@@ -60,59 +33,20 @@     { quoteExp = notHandled "Expressions",       quotePat = notHandled "Patterns",       quoteType = notHandled "Types",-      quoteDec = compileDocument ctx . LB.pack+      quoteDec = compileDocument ctx . pack     }   where     notHandled things =       error $ things <> " are not supported by the GraphQL QuasiQuoter" -compileDocument :: CodeGenConfig -> LB.ByteString -> Q [Dec]-compileDocument ctx = parseServerTypeDefinitions ctx >=> printDecQ--class PrintDecQ a where-  printDecQ :: a -> Q [Dec]--instance PrintDecQ a => PrintDecQ [a] where-  printDecQ = fmap concat . traverse printDecQ--instance PrintDecQ InterfaceDefinition where-  printDecQ InterfaceDefinition {..} =-    pure [printTypeSynonym aliasName [m_] (apply ''TypeGuard [apply interfaceName [m'], apply unionName [m']])]--instance PrintDecQ GQLTypeDefinition where-  printDecQ GQLTypeDefinition {..} = do-    let params = map toName (typeParameters gqlTarget)-    associatedTypes <- fmap (pure . (''KIND,)) (printType gqlKind)-    pure <$> printTypeClass (map (''Typeable,) params) ''GQLType (printType gqlTarget) associatedTypes methods-    where-      methods =-        [ ('defaultValues, [_'], [|gqlTypeDefaultValues|]),-          ('directives, [_'], printDirectiveUsages gqlTypeDirectiveUses)-        ]-          <> map printTypeOptions (maybeToList dropNamespace)--instance PrintDecQ ServerDeclaration where-  printDecQ (InterfaceType interface) = printDecQ interface-  printDecQ ScalarType {} = pure []-  printDecQ (DataType dataType) = pure [printDec dataType]-  printDecQ (GQLTypeInstance gql) = printDecQ gql-  printDecQ (GQLDirectiveInstance dir) = printDecQ dir--instance PrintDecQ GQLDirectiveTypeClass where-  printDecQ GQLDirectiveTypeClass {..} =-    pure-      <$> printTypeClass-        []-        ''GQLDirective-        (toCon directiveTypeName)-        [(''DIRECTIVE_LOCATIONS, promotedList directiveLocations)]-        []--promotedList :: [DirectiveLocation] -> Type-promotedList = foldr (AppT . AppT PromotedConsT . PromotedT . toName) PromotedNilT--printTypeOptions :: (TypeKind, Text) -> (Name, [PatQ], ExpQ)-printTypeOptions (kind, tName) = ('typeOptions, [_'], [|dropNamespaceOptions kind tName|])+compileDocument :: CodeGenConfig -> ByteString -> Q [Dec]+compileDocument config =+  parseServerTypeDefinitions config+    >=> fmap concat . traverse printServerDec -printDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ-printDirectiveUsages = foldr (appE . appE [|(<>)|] . printExp) [|mempty|]+printServerDec :: ServerDeclaration -> Q [Dec]+printServerDec (InterfaceType interface) = pure <$> printDec interface+printServerDec ScalarType {} = pure []+printServerDec (DataType dataType) = pure <$> printDec dataType+printServerDec (GQLTypeInstance _ gql) = pure <$> printDec gql+printServerDec (GQLDirectiveInstance dir) = pure <$> printDec dir