packages feed

morpheus-graphql-code-gen (empty) → 0.18.0

raw patch · 15 files changed

+1619/−0 lines, 15 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, filepath, morpheus-graphql-code-gen, morpheus-graphql-core, optparse-applicative, prettyprinter, relude, template-haskell, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Daviti Nalchevanidze++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,76 @@+# Morpheus GraphQL Code Gen++Morpheus GraphQL Code Gen helps you to generate GraphQL APIs .++Morpheus GraphQL CLI is still in an early stage of development, so any feedback is more than welcome, and we appreciate any contribution!+Just open an issue here on GitHub, or join [our Slack channel](https://morpheus-graphql-slack-invite.herokuapp.com/) to get in touch.++## Getting Started++Generating dummy Morpheus Api from `schema.gql`++```ssh+morpheus build src/*.gql --root src+```++_src/schema.gql_++```gql+type Query {+  deity(name: String!): Deity+  deities: [Deity!]!+}++"""+deity description+"""+type Deity {+  """+  name description+  """+  name: String!+  power: String+}+```++_src/Schema.hs_++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Schema where++import Data.Data (Typeable)+import Data.Map (empty, fromList)+import Data.Morpheus.Kind (TYPE)+import Data.Morpheus.Types+import Data.Text (Text)+import GHC.Generics (Generic)++---- GQL Query -------------------------------+data Query m = Query+  { queryDeity :: Arg "name" Text -> m (Maybe (Deity m)),+    queryDeities :: m [Deity m]+  }+  deriving (Generic)++instance (Typeable m) => GQLType (Query m) where+  type KIND (Query m) = TYPE++---- GQL Deity -------------------------------+data Deity m = Deity+  { deityName :: m Text,+    deityPower :: m (Maybe Text)+  }+  deriving (Generic)++instance (Typeable m) => GQLType (Deity m) where+  type KIND (Deity m) = TYPE+  description _ = Just "\ndeity description\n"+  getDescriptions _ = fromList [("name", "\n  name description\n  ")]+```
+ app/Main.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main+  ( main,+  )+where++import qualified Data.ByteString.Lazy as L+  ( readFile,+    writeFile,+  )+import Data.ByteString.Lazy (ByteString)+import Data.Char+import Data.Morpheus.CodeGen+  ( CodeGenConfig (..),+    PrinterConfig (..),+    parseServerTypeDefinitions,+    printServerTypeDefinitions,+  )+import Data.Morpheus.Internal.Ext+  ( GQLResult,+    Result (..),+  )+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,+  )++currentVersion :: String+currentVersion = showVersion CLI.version++main :: IO ()+main = defaultParser >>= runApp++runApp :: App -> IO ()+runApp+  App+    { operations,+      options = Options {version, root}+    }+    | version = putStrLn currentVersion+    | otherwise = runOperation operations+    where+      runOperation About =+        putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion+      runOperation Build {source} = traverse_ (processFile root) source++processFile :: FilePath -> FilePath -> IO ()+processFile root path =+  print (path, hsPath)+    >> L.readFile path+    >>= saveDocument hsPath+      . fmap (printServerTypeDefinitions PrinterConfig {moduleName})+      . parseServerTypeDefinitions CodeGenConfig {namespace = False}+  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+  }+  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")++readOutput :: ReadM String+readOutput = eitherReader Right++description :: OA.InfoMod a+description = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator"++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 "file",+      help "source files for generating api"+    ]
+ changelog.md view
@@ -0,0 +1,3 @@+# Changelog++## 0.18.0 - 08.11.2021
+ morpheus-graphql-code-gen.cabal view
@@ -0,0 +1,79 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+--+-- hash: abefa3a7c152fe401ea2fdbb8e9a4607248515d8be7b1633173ba783c10c4b3b++name:           morpheus-graphql-code-gen+version:        0.18.0+synopsis:       Morpheus GraphQL CLI+description:    code generator for Morpheus GraphQL+category:       web, graphql, cli+homepage:       https://morpheusgraphql.com+bug-reports:    https://github.com/morpheusgraphql/morpheus-graphql/issues+author:         Daviti Nalchevanidze+maintainer:     d.nalchevanidze@gmail.com+copyright:      (c) 2019 Daviti Nalchevanidze+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    changelog.md+    README.md++source-repository head+  type: git+  location: https://github.com/morpheusgraphql/morpheus-graphql++library+  exposed-modules:+      Data.Morpheus.CodeGen.Internal.AST+      Data.Morpheus.CodeGen+      Data.Morpheus.CodeGen.Internal.TH+  other-modules:+      Data.Morpheus.CodeGen.Internal.Name+      Data.Morpheus.CodeGen.Interpreting.Transform+      Data.Morpheus.CodeGen.Printing.GQLType+      Data.Morpheus.CodeGen.Printing.Render+      Data.Morpheus.CodeGen.Printing.Terms+      Data.Morpheus.CodeGen.Printing.Type+      Data.Morpheus.CodeGen.Server+      Paths_morpheus_graphql_code_gen+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10.4 && <0.11+    , containers >=0.4.2.1 && <0.7+    , morpheus-graphql-core >=0.18.0 && <0.19.0+    , prettyprinter >=1.2 && <2.0+    , relude >=0.3.0 && <1.1+    , template-haskell >=2.0 && <3.0+    , text >=1.2.3.0 && <1.3+    , unordered-containers >=0.2.8.0 && <0.3+  default-language: Haskell2010++executable morpheus+  main-is: Main.hs+  other-modules:+      Paths_morpheus_graphql_code_gen+  hs-source-dirs:+      app+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10.4 && <0.11+    , containers >=0.4.2.1 && <0.7+    , filepath >=1.1 && <1.5+    , morpheus-graphql-code-gen+    , morpheus-graphql-core >=0.18.0 && <0.19.0+    , optparse-applicative >=0.12 && <0.17+    , prettyprinter >=1.2 && <2.0+    , relude >=0.3.0 && <1.1+    , template-haskell >=2.0 && <3.0+    , text >=1.2.3.0 && <1.3+    , unordered-containers >=0.2.8.0 && <0.3+  default-language: Haskell2010
+ src/Data/Morpheus/CodeGen.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen+  ( printServerTypeDefinitions,+    parseServerTypeDefinitions,+    PrinterConfig (..),+    CodeGenConfig (..),+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( CodeGenConfig (..),+  )+import Data.Morpheus.CodeGen.Interpreting.Transform+  ( parseServerTypeDefinitions,+  )+import Data.Morpheus.CodeGen.Server+  ( PrinterConfig (..),+    printServerTypeDefinitions,+  )
+ src/Data/Morpheus/CodeGen/Internal/AST.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Internal.AST+  ( ModuleDefinition (..),+    CodeGenConfig (..),+    ServerTypeDefinition (..),+    GQLTypeDefinition (..),+    CONST,+    TypeKind (..),+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    unpackName,+    DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    ServerConstructorDefinition (..),+    ServerFieldDefinition (..),+    Kind (..),+  )+where++import Data.Morpheus.Types.Internal.AST+  ( CONST,+    Description,+    Directives,+    FieldName,+    TypeKind (..),+    TypeKind,+    TypeName,+    TypeName,+    TypeRef (..),+    TypeRef,+    TypeWrapper (..),+    Value,+    unpackName,+  )+import Relude++data ModuleDefinition = ModuleDefinition+  { moduleName :: Text,+    imports :: [(Text, [Text])],+    extensions :: [Text],+    types :: [ServerTypeDefinition]+  }++data FIELD_TYPE_WRAPPER+  = MONAD+  | SUBSCRIPTION+  | PARAMETRIZED+  | ARG TypeName+  | TAGGED_ARG FieldName TypeRef+  | GQL_WRAPPER TypeWrapper+  deriving (Show)++data DerivingClass+  = SHOW+  | GENERIC+  deriving (Show)++data ServerFieldDefinition = ServerFieldDefinition+  { fieldType :: Text,+    fieldName :: FieldName,+    wrappers :: [FIELD_TYPE_WRAPPER]+  }+  deriving (Show)++data Kind = Scalar | Type deriving (Show)++data GQLTypeDefinition = GQLTypeDefinition+  { gqlKind :: Kind,+    gqlTypeDescription :: Maybe Text,+    gqlTypeDescriptions :: Map Text Description,+    gqlTypeDirectives :: Map Text (Directives CONST),+    gqlTypeDefaultValues :: Map Text (Value CONST)+  }+  deriving (Show)++data ServerConstructorDefinition = ServerConstructorDefinition+  { constructorName :: TypeName,+    constructorFields :: [ServerFieldDefinition]+  }+  deriving (Show)++data ServerTypeDefinition+  = ServerTypeDefinition+      { tName :: Text,+        typeParameters :: [Text],+        tCons :: [ServerConstructorDefinition],+        tKind :: TypeKind,+        derives :: [DerivingClass],+        gql :: Maybe GQLTypeDefinition+      }+  | ServerInterfaceDefinition+      TypeName+      TypeName+      TypeName+  deriving (Show)++newtype CodeGenConfig = CodeGenConfig+  { namespace :: Bool+  }
+ src/Data/Morpheus/CodeGen/Internal/Name.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.CodeGen.Internal.Name+  ( toHaskellTypeName,+    camelCaseTypeName,+    toHaskellName,+    camelCaseFieldName,+  )+where++import Data.Char+  ( toLower,+    toUpper,+  )+import qualified Data.Morpheus.Types.Internal.AST as N+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    packName,+    unpackName,+  )+import qualified Data.Text as T+import Relude hiding+  ( ToString (..),+    Type,+  )++mapFstChar :: (Char -> Char) -> Text -> Text+mapFstChar f x+  | T.null x = x+  | otherwise = T.singleton (f $ T.head x) <> T.tail x++capitalize :: Text -> Text+capitalize = mapFstChar toUpper++camelCaseTypeName :: [N.Name t] -> TypeName -> TypeName+camelCaseTypeName list name =+  packName $ T.concat $+    map (capitalize . unpackName) (list <> [coerce name])++toHaskellTypeName :: TypeName -> Text+toHaskellTypeName "String" = "Text"+toHaskellTypeName "Boolean" = "Bool"+toHaskellTypeName "Float" = "Double"+toHaskellTypeName name = capitalize $ unpackName name+{-# INLINE toHaskellTypeName #-}++uncapitalize :: Text -> Text+uncapitalize = mapFstChar toLower++camelCaseFieldName :: TypeName -> FieldName -> FieldName+camelCaseFieldName nSpace name =+  packName $+    uncapitalize (unpackName nSpace)+      <> capitalize (unpackName name)++toHaskellName :: FieldName -> String+toHaskellName name+  | isReserved name = T.unpack (unpackName name <> "'")+  | otherwise = T.unpack (uncapitalize (unpackName name))+{-# INLINE toHaskellName #-}++-- handle reserved Names+isReserved :: FieldName -> Bool+isReserved "case" = True+isReserved "class" = True+isReserved "data" = True+isReserved "default" = True+isReserved "deriving" = True+isReserved "do" = True+isReserved "else" = True+isReserved "foreign" = True+isReserved "if" = True+isReserved "import" = True+isReserved "in" = True+isReserved "infix" = True+isReserved "infixl" = True+isReserved "infixr" = True+isReserved "instance" = True+isReserved "let" = True+isReserved "module" = True+isReserved "newtype" = True+isReserved "of" = True+isReserved "then" = True+isReserved "type" = True+isReserved "where" = True+isReserved "_" = True+isReserved _ = False+{-# INLINE isReserved #-}
+ src/Data/Morpheus/CodeGen/Internal/TH.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Internal.TH+  ( _',+    apply,+    applyCons,+    applyVars,+    declareTypeRef,+    funDSimple,+    camelCaseFieldName,+    camelCaseTypeName,+    toCon,+    toVar,+    ToName (..),+    toString,+    typeInstanceDec,+    v',+    vars,+    wrappedType,+  )+where++import Data.Morpheus.CodeGen.Internal.Name+  ( camelCaseFieldName,+    camelCaseTypeName,+    toHaskellName,+    toHaskellTypeName,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    unpackName,+  )+import qualified Data.Text as T+import Language.Haskell.TH+import Relude hiding+  ( ToString (..),+    Type,+  )++_' :: PatQ+_' = toVar (mkName "_")++v' :: ToVar Name a => a+v' = toVar (mkName "v")++wrappedType :: TypeWrapper -> Type -> Type+wrappedType (TypeList xs nonNull) = withNonNull nonNull . withList . wrappedType xs+wrappedType (BaseType nonNull) = withNonNull nonNull+{-# INLINE wrappedType #-}++declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type+declareTypeRef f TypeRef {typeConName, typeWrappers} =+  wrappedType typeWrappers (f typeConName)+{-# INLINE declareTypeRef #-}++withList :: Type -> Type+withList = AppT (ConT ''[])++withNonNull :: Bool -> Type -> Type+withNonNull True = id+withNonNull False = AppT (ConT ''Maybe)+{-# INLINE withNonNull #-}++cons :: ToCon a b => [a] -> [b]+cons = map toCon++vars :: ToVar a b => [a] -> [b]+vars = map toVar++class ToName a where+  toName :: a -> Name++instance ToName String where+  toName = mkName++instance ToName Name where+  toName = id++instance ToName Text where+  toName = toName . T.unpack++instance ToName TypeName where+  toName = toName . toHaskellTypeName++instance ToName FieldName where+  toName = mkName . toHaskellName++class ToString a b where+  toString :: a -> b++instance ToString a b => ToString a (Q b) where+  toString = pure . toString++instance ToString TypeName Lit where+  toString = stringL . T.unpack . unpackName++instance ToString TypeName Pat where+  toString = LitP . toString++instance ToString FieldName Lit where+  toString = stringL . T.unpack . unpackName++instance ToString TypeName Exp where+  toString = LitE . toString++instance ToString FieldName Exp where+  toString = LitE . toString++class ToCon a b where+  toCon :: a -> b++instance ToCon a b => ToCon a (Q b) where+  toCon = pure . toCon++instance (ToName a) => ToCon a Type where+  toCon = ConT . toName++instance (ToName a) => ToCon a Exp where+  toCon = ConE . toName++class ToVar a b where+  toVar :: a -> b++instance ToVar a b => ToVar a (Q b) where+  toVar = pure . toVar++instance (ToName a) => ToVar a Type where+  toVar = VarT . toName++instance (ToName a) => ToVar a Exp where+  toVar = VarE . toName++instance (ToName a) => ToVar a Pat where+  toVar = VarP . toName++class Apply a where+  apply :: ToCon i a => i -> [a] -> a++instance Apply TypeQ where+  apply = foldl' appT . toCon++instance Apply Type where+  apply = foldl' AppT . toCon++instance Apply Exp where+  apply = foldl' AppE . toCon++instance Apply ExpQ where+  apply = foldl' appE . toCon++applyVars ::+  ( ToName con,+    ToName var,+    Apply res,+    ToCon con res,+    ToVar var res+  ) =>+  con ->+  [var] ->+  res+applyVars name li = apply name (vars li)++applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type+applyCons name li = apply name (cons li)++funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ+funDSimple name args body = funD name [clause args (normalB body) []]++#if MIN_VERSION_template_haskell(2,15,0)+-- fix breaking changes+typeInstanceDec :: Name -> Type -> Type -> Dec+typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)+#else+--+typeInstanceDec :: Name -> Type -> Type -> Dec+typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)+#endif
+ src/Data/Morpheus/CodeGen/Interpreting/Transform.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Interpreting.Transform+  ( parseServerTypeDefinitions,+  )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.CodeGen.Internal.AST+  ( CodeGenConfig (..),+    DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    GQLTypeDefinition (..),+    Kind (..),+    ServerConstructorDefinition (..),+    ServerFieldDefinition (..),+    ServerTypeDefinition (..),+  )+import Data.Morpheus.CodeGen.Internal.Name+  ( camelCaseFieldName,+    toHaskellTypeName,+  )+import Data.Morpheus.CodeGen.Internal.TH+  ( ToName (toName),+    camelCaseTypeName,+  )+import Data.Morpheus.Core+  ( parseTypeDefinitions,+  )+import Data.Morpheus.Error (gqlWarnings, renderGQLErrors)+import Data.Morpheus.Internal.Ext (GQLResult, Result (..))+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ArgumentDefinition (..),+    CONST,+    DataEnumValue (..),+    Description,+    Directives,+    FieldContent (..),+    FieldDefinition (..),+    FieldName,+    FieldsDefinition,+    GQLError,+    IN,+    OUT,+    OperationType (Subscription),+    TRUE,+    Token,+    TypeContent (..),+    TypeDefinition (..),+    TypeKind (..),+    TypeName,+    TypeRef (..),+    UnionMember (..),+    Value,+    isPossibleInterfaceType,+    isResolverType,+    kindOf,+    lookupWith,+    unpackName,+  )+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,+    schema :: [TypeDefinition ANY s],+    currentTypeName :: TypeName,+    hasNamespace :: Bool,+    currentKind :: Maybe TypeKind+  }++parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerTypeDefinition]+parseServerTypeDefinitions ctx txt =+  case parseTypeDefinitions txt of+    Failure errors -> fail (renderGQLErrors errors)+    Success {result = schema, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) schema++toTHDefinitions ::+  CodeGenMonad m =>+  Bool ->+  [TypeDefinition ANY CONST] ->+  m [ServerTypeDefinition]+toTHDefinitions namespace schema = concat <$> traverse generateTypes schema+  where+    generateTypes :: CodeGenMonad m => TypeDefinition ANY CONST -> m [ServerTypeDefinition]+    generateTypes typeDef =+      runReaderT+        (genTypeDefinition typeDef)+        TypeContext+          { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef),+            schema,+            currentTypeName = typeName typeDef,+            currentKind = Just (kindOf typeDef),+            hasNamespace = namespace+          }++inType :: MonadReader (TypeContext s) m => TypeName -> m a -> m a+inType currentTypeName = local (\x -> x {currentTypeName, currentKind = Nothing})++mkInterfaceName :: TypeName -> TypeName+mkInterfaceName = ("Interface" <>)++mkPossibleTypesName :: TypeName -> TypeName+mkPossibleTypesName = ("PossibleTypes" <>)++genTypeDefinition ::+  CodeGenMonad m =>+  TypeDefinition ANY CONST ->+  ServerQ m [ServerTypeDefinition]+genTypeDefinition+  typeDef@TypeDefinition+    { typeName = originalTypeName,+      typeContent,+      typeDescription+    } = withType <$> genTypeContent originalTypeName typeContent+    where+      typeName = case typeContent of+        DataInterface {} -> mkInterfaceName originalTypeName+        _ -> originalTypeName+      tKind = kindOf typeDef+      tName = toHaskellTypeName typeName+      gql =+        Just+          GQLTypeDefinition+            { gqlTypeDescription = typeDescription,+              gqlTypeDescriptions = getDesc typeDef,+              gqlTypeDirectives = getDirs typeDef,+              gqlKind = derivingKind tKind,+              gqlTypeDefaultValues =+                fromList+                  $ mapMaybe getDefaultValue+                  $ getInputFields typeDef+            }+      typeParameters+        | isResolverType tKind = ["m"]+        | otherwise = []+      derives = derivesClasses (isResolverType tKind)+      -------------------------+      withType (ConsIN tCons) = [ServerTypeDefinition {..}]+      withType (ConsOUT others tCons) = ServerTypeDefinition {..} : others++derivingKind :: TypeKind -> Kind+derivingKind KindScalar = Scalar+derivingKind _ = Type++derivesClasses :: Bool -> [DerivingClass]+derivesClasses isResolver = GENERIC : [SHOW | not isResolver]++mkObjectCons :: TypeName -> [ServerFieldDefinition] -> [ServerConstructorDefinition]+mkObjectCons name = pure . ServerConstructorDefinition name++mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName+mkArgsTypeName namespace typeName fieldName+  | namespace = typeName <> argTName+  | otherwise = argTName+  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 ServerFieldDefinition+mkObjectField+  FieldDefinition+    { fieldName = fName,+      fieldContent,+      fieldType = TypeRef {typeConName, typeWrappers}+    } = do+    isParametrized <- lift . isParametrizedResolverType typeConName =<< asks schema+    genName <- asks toArgsTypeName+    kind <- asks currentKind+    fieldName <- genFieldName fName+    pure+      ServerFieldDefinition+        { fieldType = toHaskellTypeName typeConName,+          wrappers =+            mkFieldArguments fName genName (toArgList fieldContent)+              <> [SUBSCRIPTION | fmap isSubscription kind == Just True]+              <> [MONAD]+              <> [GQL_WRAPPER typeWrappers]+              <> [PARAMETRIZED | isParametrized],+          ..+        }++mkFieldArguments :: FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> [FIELD_TYPE_WRAPPER]+mkFieldArguments _ _ [] = []+mkFieldArguments+  _+  _+  [ ArgumentDefinition FieldDefinition {fieldName, fieldType}+    ] = [TAGGED_ARG fieldName fieldType]+mkFieldArguments fName genName _ = [ARG (genName fName)]++toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s]+toArgList (Just (FieldArgs args)) = toList args+toArgList _ = []++data BuildPlan+  = ConsIN [ServerConstructorDefinition]+  | ConsOUT [ServerTypeDefinition] [ServerConstructorDefinition]++genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerTypeDefinition]+genInterfaceUnion interfaceName =+  mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName)+    <$> asks schema+  where+    tKind = KindUnion+    mkInterface [] = []+    mkInterface [possibleTypeName] = [mkGuardWithPossibleType possibleTypeName]+    mkInterface members =+      [ mkGuardWithPossibleType tName,+        ServerTypeDefinition+          { tName = toHaskellTypeName tName,+            tCons = map (mkUnionFieldDefinition tName) members,+            tKind,+            typeParameters = ["m"],+            derives = derivesClasses True,+            gql = Nothing+          }+      ]+    mkGuardWithPossibleType = ServerInterfaceDefinition interfaceName (mkInterfaceName interfaceName)+    tName = mkPossibleTypesName interfaceName++genFieldName :: Monad m => FieldName -> ServerQ m FieldName+genFieldName fieldName = do+  TypeContext {hasNamespace, currentTypeName} <- ask+  pure $+    if hasNamespace+      then camelCaseFieldName currentTypeName fieldName+      else fieldName++mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition+mkConsEnum name DataEnumValue {enumName} = do+  namespace <- asks hasNamespace+  pure+    ServerConstructorDefinition+      { constructorName =+          if namespace+            then camelCaseTypeName [name] enumName+            else enumName,+        constructorFields = []+      }++toNonResolverServerField :: Monad m => FieldDefinition c CONST -> ServerQ m ServerFieldDefinition+toNonResolverServerField+  FieldDefinition+    { fieldType = TypeRef {typeConName, typeWrappers},+      fieldName = fName+    } = do+    fieldName <- genFieldName fName+    pure $+      ServerFieldDefinition+        { fieldType = toHaskellTypeName typeConName,+          fieldName,+          wrappers = [GQL_WRAPPER typeWrappers]+        }++genTypeContent ::+  CodeGenMonad m =>+  TypeName ->+  TypeContent TRUE ANY CONST ->+  ServerQ m BuildPlan+genTypeContent _ DataScalar {} = pure (ConsIN [])+genTypeContent typeName (DataEnum tags) = ConsIN <$> traverse (mkConsEnum typeName) tags+genTypeContent typeName (DataInputObject fields) =+  ConsIN . mkObjectCons typeName <$> traverse toNonResolverServerField (toList fields)+genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported"+genTypeContent typeName DataInterface {interfaceFields} =+  ConsOUT+    <$> ((<>) <$> genArgumentTypes interfaceFields <*> genInterfaceUnion typeName)+    <*> ( do+            let interfaceName = mkInterfaceName typeName+            inType+              interfaceName+              ( mkObjectCons interfaceName+                  <$> traverse mkObjectField (toList interfaceFields)+              )+        )+genTypeContent typeName DataObject {objectFields} =+  ConsOUT <$> genArgumentTypes objectFields+    <*> ( mkObjectCons typeName+            <$> traverse mkObjectField (toList objectFields)+        )+genTypeContent typeName (DataUnion members) =+  pure $ ConsOUT [] (unionCon <$> toList members)+  where+    unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName++mkUnionFieldDefinition :: TypeName -> TypeName -> ServerConstructorDefinition+mkUnionFieldDefinition typeName memberName =+  ServerConstructorDefinition+    { constructorName,+      constructorFields =+        [ ServerFieldDefinition+            { fieldName = coerce ("un" <> constructorName),+              fieldType = toHaskellTypeName memberName,+              wrappers = [PARAMETRIZED]+            }+        ]+    }+  where+    constructorName = camelCaseTypeName [typeName] memberName++genArgumentTypes :: Monad m => FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]+genArgumentTypes = fmap concat . traverse genArgumentType . toList++genArgumentType :: Monad m => FieldDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]+genArgumentType+  FieldDefinition+    { fieldName,+      fieldContent = Just (FieldArgs arguments)+    }+    | length arguments > 1 = do+      tName <- (fieldName &) <$> asks toArgsTypeName+      inType tName $ do+        let argumentFields = argument <$> toList arguments+        fields <- traverse toNonResolverServerField argumentFields+        let tKind = KindInputObject+        pure+          [ ServerTypeDefinition+              { tName = toHaskellTypeName tName,+                tKind,+                tCons = mkObjectCons tName fields,+                derives = derivesClasses False,+                typeParameters = [],+                gql =+                  Just+                    ( GQLTypeDefinition+                        { gqlKind = Type,+                          gqlTypeDescription = Nothing,+                          gqlTypeDescriptions = fromList (mapMaybe mkFieldDescription argumentFields),+                          gqlTypeDirectives = fromList (mkFieldDirective <$> argumentFields),+                          gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields)+                        }+                    )+              }+          ]+genArgumentType _ = pure []++mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description)+mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription++mkFieldDirective :: FieldDefinition cat s -> (Text, Directives s)+mkFieldDirective FieldDefinition {..} = (unpackName fieldName, fieldDirectives)++---++getDesc :: TypeDefinition c s -> Map Token Description+getDesc = fromList . get++getDirs :: TypeDefinition c s -> Map Token (Directives s)+getDirs = fromList . get++class Meta a v where+  get :: a -> [(Token, v)]++instance (Meta a v) => Meta (Maybe a) v where+  get (Just x) = get x+  get _ = []++instance+  ( Meta (FieldsDefinition IN s) v,+    Meta (FieldsDefinition OUT s) v,+    Meta (DataEnumValue s) v+  ) =>+  Meta (TypeDefinition c s) v+  where+  get TypeDefinition {typeContent} = get typeContent++instance+  ( Meta (FieldsDefinition IN s) v,+    Meta (FieldsDefinition OUT s) v,+    Meta (DataEnumValue s) v+  ) =>+  Meta (TypeContent a c s) v+  where+  get DataObject {objectFields} = get objectFields+  get DataInputObject {inputObjectFields} = get inputObjectFields+  get DataInterface {interfaceFields} = get interfaceFields+  get DataEnum {enumMembers} = concatMap get enumMembers+  get _ = []++instance Meta (DataEnumValue s) Description where+  get DataEnumValue {enumName, enumDescription = Just x} = [(unpackName enumName, x)]+  get _ = []++instance Meta (DataEnumValue s) (Directives s) where+  get DataEnumValue {enumName, enumDirectives}+    | null enumDirectives = []+    | otherwise = [(unpackName enumName, enumDirectives)]++instance+  Meta (FieldDefinition c s) v =>+  Meta (FieldsDefinition c s) v+  where+  get = concatMap get . toList++instance Meta (FieldDefinition c s) Description where+  get FieldDefinition {fieldName, fieldDescription = Just x} = [(unpackName fieldName, x)]+  get _ = []++instance Meta (FieldDefinition c s) (Directives s) where+  get FieldDefinition {fieldName, fieldDirectives}+    | null fieldDirectives = []+    | otherwise = [(unpackName fieldName, fieldDirectives)]++getInputFields :: TypeDefinition c s -> [FieldDefinition IN s]+getInputFields TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = toList inputObjectFields+getInputFields _ = []++getDefaultValue :: FieldDefinition c s -> Maybe (Text, Value s)+getDefaultValue+  FieldDefinition+    { fieldName,+      fieldContent = Just DefaultInputValue {defaultInputValue}+    } = Just (unpackName fieldName, defaultInputValue)+getDefaultValue _ = Nothing
+ src/Data/Morpheus/CodeGen/Printing/GQLType.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Printing.GQLType+  ( renderGQLType,+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( GQLTypeDefinition (..),+    Kind (..),+    ServerTypeDefinition (..),+    TypeKind,+  )+import Data.Morpheus.CodeGen.Printing.Terms+  ( optional,+    parametrizedType,+  )+import Data.Text.Prettyprint.Doc+  ( (<+>),+    Doc,+    Pretty (pretty),+    indent,+    line,+    tupled,+    vsep,+  )+import Relude hiding (optional, show)+import Prelude (show)++renderTypeableConstraints :: [Text] -> Doc n+renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>"++-- TODO: fill namespace options+defineTypeOptions :: Text -> TypeKind -> Doc n+defineTypeOptions tName kind = ""++renderGQLType :: ServerTypeDefinition -> Doc n+renderGQLType ServerTypeDefinition {tName, typeParameters, tKind, gql} =+  "instance"+    <> optional renderTypeableConstraints typeParameters+    <+> "GQLType"+    <+> typeHead+    <+> "where"+    <> line+    <> indent 2 (vsep (renderMethods typeHead gql <> [options]))+  where+    options = defineTypeOptions tName tKind+    typeHead =+      if null typeParameters+        then parametrizedType tName typeParameters+        else tupled (pure $ parametrizedType tName typeParameters)+renderGQLType _ = ""++renderMethods :: Doc n -> Maybe GQLTypeDefinition -> [Doc n]+renderMethods _ Nothing = []+renderMethods+  typeHead+  ( Just+      GQLTypeDefinition+        { gqlTypeDescription,+          gqlTypeDescriptions,+          gqlKind+        }+    ) =+    ["type KIND" <+> typeHead <+> "=" <+> renderKind gqlKind]+      <> ["description _ =" <+> pretty (show gqlTypeDescription) | not (null gqlTypeDescription)]+      <> ["getDescriptions _ =" <+> pretty (show gqlTypeDescriptions) | not (null gqlTypeDescriptions)]++renderKind :: Kind -> Doc n+renderKind Type = "TYPE"+renderKind Scalar = "SCALAR"
+ src/Data/Morpheus/CodeGen/Printing/Render.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Printing.Render+  ( renderDocument,+  )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.CodeGen.Internal.AST+  ( ModuleDefinition (..),+    ServerTypeDefinition (..),+  )+import Data.Morpheus.CodeGen.Printing.Terms+  ( renderExtension,+    renderImport,+  )+import Data.Morpheus.CodeGen.Printing.Type+  ( renderTypes,+  )+import Data.Text+  ( pack,+  )+import qualified Data.Text.Lazy as LT+  ( fromStrict,+  )+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text.Prettyprint.Doc+  ( (<+>),+    Doc,+    line,+    pretty,+    vsep,+  )+import Relude hiding (ByteString, encodeUtf8)++renderDocument :: String -> [ServerTypeDefinition] -> 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.Text", ["Text"]),+              ("GHC.Generics", ["Generic"]),+              ("Data.Map", ["fromList", "empty"])+            ],+          extensions =+            [ "DeriveAnyClass",+              "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)
+ src/Data/Morpheus/CodeGen/Printing/Terms.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Printing.Terms+  ( renderExtension,+    renderWrapped,+    label,+    parametrizedType,+    TypeDoc (..),+    appendType,+    optional,+    renderImport,+    renderType,+    renderName,+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( TypeName,+    TypeWrapper (..),+    unpackName,+  )+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc+  ( (<+>),+    Doc,+    hsep,+    list,+    pretty,+    tupled,+  )+import Relude hiding (optional)++parametrizedType :: Text -> [Text] -> Doc ann+parametrizedType tName typeParameters = hsep $ map pretty $ tName : typeParameters++-- TODO: this should be done in transformer+renderName :: TypeName -> Doc ann+renderName = pretty . T.unpack . unpackName++renderExtension :: Text -> Doc ann+renderExtension name = "{-#" <+> "LANGUAGE" <+> pretty name <+> "#-}"++data TypeDoc n = TypeDoc+  { isComplex :: Bool,+    unDoc :: Doc n+  }++renderType :: TypeDoc n -> Doc n+renderType TypeDoc {isComplex, unDoc = doc} = if isComplex then tupled [doc] else doc++appendType :: TypeName -> TypeDoc n -> TypeDoc n+appendType t1 tyDoc = TypeDoc True $ renderName t1 <> " " <> renderType tyDoc++renderMaybe :: Bool -> TypeDoc n -> TypeDoc n+renderMaybe True = id+renderMaybe False = appendType "Maybe"++renderList :: TypeDoc n -> TypeDoc n+renderList = TypeDoc False . list . pure . unDoc++renderWrapped :: TypeWrapper -> TypeDoc n -> TypeDoc n+renderWrapped (TypeList wrapper notNull) = renderMaybe notNull . renderList . renderWrapped wrapper+renderWrapped (BaseType notNull) = renderMaybe notNull++label :: Text -> Doc ann+label typeName = "---- GQL " <> pretty typeName <> " -------------------------------\n"++optional :: ([a] -> Doc n) -> [a] -> Doc n+optional _ [] = ""+optional f xs = " " <> f xs++renderImport :: (Text, [Text]) -> Doc ann+renderImport (src, ls) =+  "import" <+> pretty src+    <> optional (tupled . map pretty) ls
+ src/Data/Morpheus/CodeGen/Printing/Type.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Printing.Type+  ( renderTypes,+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    ServerConstructorDefinition (..),+    ServerFieldDefinition (..),+    ServerTypeDefinition (..),+    TypeKind (..),+    TypeRef (..),+    unpackName,+  )+import Data.Morpheus.CodeGen.Printing.GQLType+  ( renderGQLType,+  )+import Data.Morpheus.CodeGen.Printing.Terms+  ( TypeDoc (TypeDoc, unDoc),+    appendType,+    label,+    parametrizedType,+    renderName,+    renderType,+    renderWrapped,+  )+import Data.Text.Prettyprint.Doc+  ( (<+>),+    Doc,+    comma,+    enclose,+    indent,+    line,+    nest,+    pretty,+    punctuate,+    tupled,+    vsep,+  )+import Relude hiding (show)+import Prelude (show)++type Result = Either Text++renderTypes :: [ServerTypeDefinition] -> Either Text (Doc ann)+renderTypes = fmap vsep . traverse render++class RenderType a where+  render :: a -> Result (Doc ann)++instance RenderType DerivingClass where+  render SHOW = pure "Show"+  render GENERIC = pure "Generic"++instance RenderType ServerTypeDefinition where+  render ServerInterfaceDefinition {} = fail "not supported"+  -- TODO: on scalar we should render user provided type+  render ServerTypeDefinition {tKind = KindScalar, tName} =+    pure $ label tName <> "type" <+> pretty tName <+> "= Int"+  render typeDef@ServerTypeDefinition {tName, tCons, typeParameters, derives} = do+    typeRendering <- renderTypeDef+    pure $ label tName <> vsep [typeRendering, renderGQLType typeDef]+    where+      renderTypeDef = do+        cons <- renderConstructors tCons+        derivations <- renderDeriving derives+        pure $+          "data"+            <+> parametrizedType tName typeParameters+            <> cons+            <> line+            <> indent 2 derivations+            <> line+      renderConstructors [cons] = (" =" <+>) <$> render cons+      renderConstructors conses = nest 2 . (line <>) . vsep . prefixVariants <$> traverse render conses+      prefixVariants (x : xs) = "=" <+> x : map ("|" <+>) xs+      prefixVariants [] = []++renderDeriving :: [DerivingClass] -> Result (Doc n)+renderDeriving list = ("deriving" <+>) . tupled <$> traverse render list++instance RenderType ServerConstructorDefinition where+  render ServerConstructorDefinition {constructorName, constructorFields = []} =+    pure $ renderName constructorName+  render ServerConstructorDefinition {constructorName, constructorFields} = do+    fields <- traverse render constructorFields+    pure $ renderName constructorName <> renderSet fields+    where+      renderSet = nest 2 . enclose "\n{ " "\n}" . nest 2 . vsep . punctuate comma++instance RenderType ServerFieldDefinition where+  render+    ServerFieldDefinition+      { fieldName,+        wrappers,+        fieldType+      } =+      pure $+        pretty (unpackName fieldName)+          <+> "::"+          <+> unDoc (foldr renderWrapper (TypeDoc False $ pretty fieldType) wrappers)++renderWrapper :: FIELD_TYPE_WRAPPER -> TypeDoc n -> TypeDoc n+renderWrapper PARAMETRIZED = \x -> TypeDoc True (unDoc x <+> "m")+renderWrapper MONAD = appendType "m"+renderWrapper SUBSCRIPTION = id+renderWrapper (GQL_WRAPPER typeWrappers) = renderWrapped typeWrappers+renderWrapper (ARG name) = TypeDoc True . ((renderName name <+> "->") <+>) . unDoc+renderWrapper (TAGGED_ARG name typeRef) =+  TypeDoc True+    . ( ( "Arg"+            <+> pretty (show name)+            <+> renderType (renderTypeRef typeRef)+            <+> "->"+        )+          <+>+      )+    . unDoc++renderTypeRef :: TypeRef -> TypeDoc n+renderTypeRef+  TypeRef+    { typeConName,+      typeWrappers+    } =+    renderWrapped+      typeWrappers+      (TypeDoc False (renderName typeConName))
+ src/Data/Morpheus/CodeGen/Server.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server+  ( printServerTypeDefinitions,+    PrinterConfig (..),+  )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.CodeGen.Internal.AST+  ( ServerTypeDefinition,+  )+import Data.Morpheus.CodeGen.Printing.Render+  ( renderDocument,+  )+import Relude hiding (ByteString)++newtype PrinterConfig = PrinterConfig+  { moduleName :: String+  }++printServerTypeDefinitions :: PrinterConfig -> [ServerTypeDefinition] -> ByteString+printServerTypeDefinitions PrinterConfig {moduleName} = renderDocument moduleName