packages feed

morpheus-graphql-code-gen 0.21.0 → 0.22.0

raw patch · 17 files changed

+1064/−1455 lines, 17 filesdep +file-embeddep +morpheus-graphql-code-gen-utilsdep +morpheus-graphql-serverdep ~morpheus-graphql-core

Dependencies added: file-embed, morpheus-graphql-code-gen-utils, morpheus-graphql-server

Dependency ranges changed: morpheus-graphql-core

Files

app/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}  module Main@@ -64,25 +65,21 @@ 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+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 :: FilePath -> FilePath -> IO ()-processFile root path =+processFile :: Options -> FilePath -> IO ()+processFile Options {root, namespaces} path =   print (path, hsPath)     >> L.readFile path     >>= saveDocument hsPath       . fmap (printServerTypeDefinitions PrinterConfig {moduleName})-      . parseServerTypeDefinitions CodeGenConfig {namespace = False}+      . parseServerTypeDefinitions CodeGenConfig {namespace = namespaces}   where     hsPath = processFileName path     moduleName = intercalate "." $ splitDirectories $ dropExtensions $ makeRelative root hsPath@@ -111,7 +108,8 @@  data Options = Options   { version :: Bool,-    root :: String+    root :: String,+    namespaces :: Bool   }   deriving (Show) @@ -129,6 +127,7 @@   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")  readOutput :: ReadM String readOutput = eitherReader Right
changelog.md view
@@ -1,5 +1,3 @@ # Changelog  see latest changes on [Github](https://github.com/morpheusgraphql/morpheus-graphql/releases)--## 0.18.0 - 08.11.2021
morpheus-graphql-code-gen.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-code-gen-version:        0.21.0+version:        0.22.0 synopsis:       Morpheus GraphQL CLI description:    code generator for Morpheus GraphQL category:       web, graphql, cli@@ -28,16 +28,12 @@ library   exposed-modules:       Data.Morpheus.CodeGen-      Data.Morpheus.CodeGen.Internal.AST-      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+  other-modules:+      Data.Morpheus.CodeGen.Server.Internal.AST+      Data.Morpheus.CodeGen.Server.Interpreting.Transform+      Data.Morpheus.CodeGen.Server.Printing.Document+      Data.Morpheus.CodeGen.Server.Printing.TH       Paths_morpheus_graphql_code_gen   hs-source-dirs:       src@@ -46,7 +42,10 @@       base >=4.7.0 && <5.0.0     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0-    , morpheus-graphql-core >=0.21.0 && <0.22.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     , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0@@ -65,9 +64,12 @@       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-code-gen-    , morpheus-graphql-core >=0.21.0 && <0.22.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     , optparse-applicative >=0.12.0 && <0.18.0     , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0
src/Data/Morpheus/CodeGen.hs view
@@ -8,13 +8,13 @@   ) where -import Data.Morpheus.CodeGen.Internal.AST-  ( CodeGenConfig (..),-  )-import Data.Morpheus.CodeGen.Interpreting.Transform-  ( parseServerTypeDefinitions,-  ) import Data.Morpheus.CodeGen.Server   ( PrinterConfig (..),     printServerTypeDefinitions,+  )+import Data.Morpheus.CodeGen.Server.Internal.AST+  ( CodeGenConfig (..),+  )+import Data.Morpheus.CodeGen.Server.Interpreting.Transform+  ( parseServerTypeDefinitions,   )
− src/Data/Morpheus/CodeGen/Internal/AST.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# 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 (..),-    ServerDirectiveUsage (..),-    TypeValue (..),-  )-where--import Data.Morpheus.Types.Internal.AST-  ( CONST,-    Description,-    DirectiveLocation (..),-    FieldName,-    TypeKind (..),-    TypeName,-    TypeRef (..),-    TypeWrapper (..),-    Value,-    unpackName,-  )-import Prettyprinter (Doc, Pretty (..), punctuate, vsep, (<+>))-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 TypeValue-  = TypeValueObject TypeName [(FieldName, TypeValue)]-  | TypeValueNumber Double-  | TypeValueString Text-  | TypeValueBool Bool-  | TypeValueList [TypeValue]-  | TypedValueMaybe (Maybe TypeValue)-  deriving (Show)--renderField :: (FieldName, TypeValue) -> Doc n-renderField (fName, fValue) = pretty (unpackName fName :: Text) <> "=" <+> pretty fValue--instance Pretty TypeValue where-  pretty (TypeValueObject name xs) =-    pretty (unpackName name :: Text)-      <+> "{"-      <+> vsep (punctuate "," (map renderField xs))-      <+> "}"-  pretty (TypeValueNumber x) = pretty x-  pretty (TypeValueString x) = pretty (show x :: String)-  pretty (TypeValueBool x) = pretty x-  pretty (TypedValueMaybe (Just x)) = "Just" <+> pretty x-  pretty (TypedValueMaybe Nothing) = "Nothing"-  pretty (TypeValueList xs) = prettyList xs--data ServerDirectiveUsage-  = TypeDirectiveUsage TypeValue-  | FieldDirectiveUsage FieldName TypeValue-  | EnumDirectiveUsage TypeName TypeValue-  deriving (Show)--data GQLTypeDefinition = GQLTypeDefinition-  { gqlKind :: Kind,-    gqlTypeDescription :: Maybe Text,-    gqlTypeDescriptions :: Map Text Description,-    gqlTypeDirectiveUses :: [ServerDirectiveUsage],-    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],-        typeGQLType :: Maybe GQLTypeDefinition-      }-  | DirectiveTypeDefinition-      { directiveConstructor :: ServerConstructorDefinition,-        directiveDerives :: [DerivingClass],-        directiveLocations :: [DirectiveLocation],-        directiveGQLType :: GQLTypeDefinition-      }-  | ServerInterfaceDefinition-      TypeName-      TypeName-      TypeName-  deriving (Show)--newtype CodeGenConfig = CodeGenConfig-  { namespace :: Bool-  }
− src/Data/Morpheus/CodeGen/Internal/Name.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.CodeGen.Internal.Name-  ( toHaskellTypeName,-    camelCaseTypeName,-    toHaskellName,-    camelCaseFieldName,-  )-where--import Data.Char-  ( toLower,-    toUpper,-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    TypeName,-    packName,-    unpackName,-  )-import qualified Data.Morpheus.Types.Internal.AST as N-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 
@@ -1,191 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# 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 
@@ -1,608 +0,0 @@-{-# 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 (..),-    ServerDirectiveUsage (..),-    ServerFieldDefinition (..),-    ServerTypeDefinition (..),-    TypeValue (..),-  )-import Data.Morpheus.CodeGen.Internal.Name-  ( camelCaseFieldName,-    toHaskellTypeName,-  )-import Data.Morpheus.CodeGen.Internal.TH-  ( ToName (toName),-    camelCaseTypeName,-  )-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.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,-    Token,-    TypeContent (..),-    TypeDefinition (..),-    TypeKind (..),-    TypeName,-    TypeRef (..),-    UnionMember (..),-    isPossibleInterfaceType,-    isResolverType,-    kindOf,-    lookupWith,-    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 [ServerTypeDefinition]-parseServerTypeDefinitions ctx txt =-  case parseDefinitions txt of-    Failure errors -> fail (renderGQLErrors errors)-    Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result--toTHDefinitions ::-  CodeGenMonad m =>-  Bool ->-  [RawTypeDefinition] ->-  m [ServerTypeDefinition]-toTHDefinitions namespace defs = concat <$> traverse generateTypes defs-  where-    typeDefinitions = [td | RawTypeDefinition td <- defs]-    directiveDefinitions = [td | RawDirectiveDefinition td <- defs]-    generateTypes :: CodeGenMonad m => RawTypeDefinition -> m [ServerTypeDefinition]-    generateTypes (RawTypeDefinition typeDef) =-      runReaderT-        (genTypeDefinition typeDef)-        TypeContext-          { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef),-            typeDefinitions,-            directiveDefinitions,-            currentTypeName = Just (typeName typeDef),-            currentKind = Just (kindOf typeDef),-            hasNamespace = namespace-          }-    generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) =-      runReaderT-        ( do-            fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs)-            pure-              [ DirectiveTypeDefinition-                  { directiveConstructor = ServerConstructorDefinition (coerce directiveDefinitionName) fields,-                    directiveDerives = [SHOW, GENERIC],-                    directiveLocations = directiveDefinitionLocations,-                    directiveGQLType =-                      GQLTypeDefinition-                        { gqlKind = Type,-                          gqlTypeDescription = Nothing,-                          gqlTypeDescriptions = mempty,-                          gqlTypeDefaultValues = mempty,-                          gqlTypeDirectiveUses = []-                        }-                  }-              ]-        )-        TypeContext-          { toArgsTypeName = coerce,-            typeDefinitions,-            currentTypeName = Just (coerce directiveDefinitionName),-            directiveDefinitions,-            currentKind = Nothing,-            hasNamespace = namespace-          }-    generateTypes _ = pure []--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" <>)--mkPossibleTypesName :: TypeName -> TypeName-mkPossibleTypesName = ("PossibleTypes" <>)--genTypeDefinition ::-  CodeGenMonad m =>-  TypeDefinition ANY CONST ->-  ServerQ m [ServerTypeDefinition]-genTypeDefinition-  typeDef@TypeDefinition-    { typeName = originalTypeName,-      typeContent,-      typeDescription-    } = genTypeContent originalTypeName typeContent >>= withType-    where-      typeName = case typeContent of-        DataInterface {} -> mkInterfaceName originalTypeName-        _ -> originalTypeName-      tKind = kindOf typeDef-      tName = toHaskellTypeName typeName-      deriveGQL = do-        gqlTypeDescriptions <- getDesc typeDef-        gqlTypeDirectiveUses <- getDirs typeDef-        pure $-          Just-            GQLTypeDefinition-              { gqlTypeDescription = typeDescription,-                gqlTypeDescriptions,-                gqlTypeDirectiveUses,-                gqlKind = derivingKind tKind,-                gqlTypeDefaultValues =-                  fromList $-                    mapMaybe getDefaultValue $-                      getInputFields typeDef-              }-      typeParameters-        | isResolverType tKind = ["m"]-        | otherwise = []-      derives = derivesClasses (isResolverType tKind)-      --------------------------      withType (ConsIN tCons) = do-        typeGQLType <- deriveGQL-        pure [ServerTypeDefinition {..}]-      withType (ConsOUT others tCons) = do-        typeGQLType <- deriveGQL-        pure (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 typeDefinitions-    genName <- asks toArgsTypeName-    kind <- asks currentKind-    fieldName <- renderFieldName 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 typeDefinitions-  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,-            typeGQLType = Nothing-          }-      ]-    mkGuardWithPossibleType = ServerInterfaceDefinition 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 ServerConstructorDefinition-mkConsEnum name DataEnumValue {enumName} = do-  namespace <- asks hasNamespace-  pure-    ServerConstructorDefinition-      { constructorName =-          if namespace-            then camelCaseTypeName [name] enumName-            else enumName,-        constructorFields = []-      }--renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m ServerFieldDefinition-renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do-  fieldName <- renderFieldName fName-  let wrappers = [GQL_WRAPPER typeWrappers]-  let fieldType = toHaskellTypeName typeConName-  pure ServerFieldDefinition {..}--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 renderDataField (toList fields)-genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported"-genTypeContent typeName DataInterface {interfaceFields} =-  ConsOUT-    <$> ((<>) <$> genArgumentTypes interfaceFields <*> genInterfaceUnion typeName)-    <*> ( do-            let interfaceName = mkInterfaceName typeName-            inType-              (Just 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 (Just tName) $ do-          let argumentFields = argument <$> toList arguments-          fields <- traverse renderDataField argumentFields-          let tKind = KindInputObject-          pure-            [ ServerTypeDefinition-                { tName = toHaskellTypeName tName,-                  tKind,-                  tCons = mkObjectCons tName fields,-                  derives = derivesClasses False,-                  typeParameters = [],-                  typeGQLType =-                    Just-                      ( GQLTypeDefinition-                          { gqlKind = Type,-                            gqlTypeDescription = Nothing,-                            gqlTypeDescriptions = fromList (mapMaybe mkFieldDescription argumentFields),-                            gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields),-                            gqlTypeDirectiveUses = []-                          }-                      )-                }-            ]-genArgumentType _ = pure []--mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description)-mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription-------getDesc :: MonadFail m => TypeDefinition c CONST -> ServerQ m (Map Token Description)-getDesc = fmap fromList . get--getDirs :: MonadFail m => TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage]-getDirs x = do-  contentD <- map snd <$> get x-  typeD <- traverse transform (toList $ AST.typeDirectives x)-  pure (contentD <> typeD)-  where-    transform v = TypeDirectiveUsage <$> directiveTypeValue v--class Meta a v where-  get :: MonadFail m => a -> ServerQ m [(Token, v)]--instance (Meta a v) => Meta (Maybe a) v where-  get (Just x) = get x-  get _ = pure []--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} = concat <$> traverse get enumMembers-  get _ = pure []--instance Meta (DataEnumValue CONST) Description where-  get DataEnumValue {enumName, enumDescription = Just x} = pure [(unpackName enumName, x)]-  get _ = pure []--instance Meta (DataEnumValue CONST) ServerDirectiveUsage where-  get DataEnumValue {enumName, enumDirectives}-    | null enumDirectives = pure []-    | otherwise = traverse transform (toList enumDirectives)-    where-      transform x = (unpackName enumName,) . EnumDirectiveUsage enumName <$> directiveTypeValue x--instance-  Meta (FieldDefinition c CONST) v =>-  Meta (FieldsDefinition c CONST) v-  where-  get = fmap concat . traverse get . toList--instance Meta (FieldDefinition c CONST) Description where-  get FieldDefinition {fieldName, fieldDescription = Just x} = pure [(unpackName fieldName, x)]-  get _ = pure []--instance Meta (FieldDefinition c CONST) ServerDirectiveUsage where-  get FieldDefinition {fieldName, fieldDirectives}-    | null fieldDirectives = pure []-    | otherwise = traverse transform (toList fieldDirectives)-    where-      transform x = (unpackName fieldName,) . FieldDirectiveUsage fieldName <$> directiveTypeValue x--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-    { 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/Printing/GQLType.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.CodeGen.Printing.GQLType-  ( renderGQLType,-  )-where--import Data.Morpheus.CodeGen.Internal.AST-  ( GQLTypeDefinition (..),-    Kind (..),-    ServerDirectiveUsage (..),-    ServerTypeDefinition (..),-    TypeKind,-  )-import Data.Morpheus.CodeGen.Printing.Terms-  ( optional,-    parametrizedType,-  )-import Prettyprinter-import Relude hiding (optional, show)-import Prelude (show)--renderTypeableConstraints :: [Text] -> Doc n-renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>"--defineTypeOptions :: Bool -> Text -> TypeKind -> Doc n-defineTypeOptions namespaces tName kind-  | namespaces = "typeOptions _ = dropNamespaceOptions " <> pretty tName <> " (" <> pretty (show kind) <> ")"-  | otherwise = "typeOptions _ options = options"--renderGQLType :: ServerTypeDefinition -> Doc n-renderGQLType ServerTypeDefinition {..} =-  "instance"-    <> optional renderTypeableConstraints typeParameters-    <+> "GQLType"-    <+> typeHead-    <+> "where"-      <> line-      <> indent 2 (vsep (renderMethods typeHead typeGQLType <> [options]))-  where-    options = defineTypeOptions False 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 {..}) =-    ["type KIND" <+> typeHead <+> "=" <+> renderKind gqlKind]-      <> ["description _ =" <+> pretty (show gqlTypeDescription) | not (null gqlTypeDescription)]-      <> ["getDescriptions _ =" <+> pretty (show gqlTypeDescriptions) | not (null gqlTypeDescriptions)]-      <> ["directives _=" <+> renderDirectiveUsages gqlTypeDirectiveUses | not (null gqlTypeDirectiveUses)]--renderDirectiveUsages :: [ServerDirectiveUsage] -> Doc n-renderDirectiveUsages = align . vsep . punctuate " <>" . map renderDirectiveUsage--renderDirectiveUsage :: ServerDirectiveUsage -> Doc n-renderDirectiveUsage (TypeDirectiveUsage value) = "typeDirective" <+> pretty value-renderDirectiveUsage (FieldDirectiveUsage place value) = "fieldDirective" <+> pretty (show place) <+> pretty value-renderDirectiveUsage (EnumDirectiveUsage place value) = "enumDirective" <+> pretty (show place) <+> pretty value--renderKind :: Kind -> Doc n-renderKind Type = "TYPE"-renderKind Scalar = "SCALAR"
− src/Data/Morpheus/CodeGen/Printing/Render.hs 
@@ -1,87 +0,0 @@-{-# 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 Prettyprinter-  ( 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.Morpheus", []),-                    ("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 
@@ -1,78 +0,0 @@-{-# 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 Prettyprinter-  ( 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 
@@ -1,150 +0,0 @@-{-# 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 Prettyprinter-  ( 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 [] = []-  render typeDef@DirectiveTypeDefinition {directiveConstructor, directiveDerives} = do-    typeRendering <- renderTypeDef-    pure $ label name <> vsep [typeRendering, renderGQLType typeDef]-    where-      renderTypeDef = do-        cons <- (" =" <+>) <$> render directiveConstructor-        derivations <- renderDeriving directiveDerives-        pure $-          "data"-            <+> parametrizedType name []-              <> cons-              <> line-              <> indent 2 derivations-              <> line-      name = unpackName (constructorName directiveConstructor)--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 :: Text)-          <+> "::"-          <+> 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
@@ -2,23 +2,46 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Server-  ( printServerTypeDefinitions,+  ( CodeGenConfig (..),     PrinterConfig (..),+    gqlDocument,+    importServerTypeDefinitions,+    printServerTypeDefinitions,   ) where -import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Morpheus.CodeGen.Internal.AST-  ( ServerTypeDefinition,+import Data.ByteString.Lazy.Char8+  ( ByteString,+    readFile,   )-import Data.Morpheus.CodeGen.Printing.Render+import Data.FileEmbed (makeRelativeToProject)+import Data.Morpheus.CodeGen.Server.Internal.AST+  ( CodeGenConfig (..),+    ServerDeclaration,+  )+import Data.Morpheus.CodeGen.Server.Printing.Document   ( renderDocument,   )-import Relude hiding (ByteString)+import Data.Morpheus.CodeGen.Server.Printing.TH+  ( compileDocument,+    gqlDocument,+  )+import Language.Haskell.TH (Dec, Q, runIO)+import Language.Haskell.TH.Syntax+  ( qAddDependentFile,+  )+import Relude hiding (ByteString, readFile)  newtype PrinterConfig = PrinterConfig   { moduleName :: String   } -printServerTypeDefinitions :: PrinterConfig -> [ServerTypeDefinition] -> ByteString+printServerTypeDefinitions :: PrinterConfig -> [ServerDeclaration] -> ByteString printServerTypeDefinitions PrinterConfig {moduleName} = renderDocument moduleName++importServerTypeDefinitions :: CodeGenConfig -> FilePath -> Q [Dec]+importServerTypeDefinitions ctx rawSrc = do+  src <- makeRelativeToProject rawSrc+  qAddDependentFile src+  runIO (readFile src)+    >>= compileDocument ctx
+ src/Data/Morpheus/CodeGen/Server/Internal/AST.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server.Internal.AST+  ( ModuleDefinition (..),+    CodeGenConfig (..),+    ServerDeclaration (..),+    GQLTypeDefinition (..),+    CONST,+    TypeKind (..),+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    unpackName,+    DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    Kind (..),+    ServerDirectiveUsage (..),+    TypeValue (..),+    InterfaceDefinition (..),+    GQLDirectiveTypeClass (..),+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( CodeGenType,+    CodeGenTypeName,+    DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    TypeValue (..),+  )+import Data.Morpheus.CodeGen.TH+  ( PrintExp (..),+    PrintType (..),+  )+import Data.Morpheus.Server.Types+  ( SCALAR,+    TYPE,+    enumDirective,+    fieldDirective,+    typeDirective,+  )+import Data.Morpheus.Types.Internal.AST+  ( CONST,+    DirectiveLocation (..),+    FieldName,+    TypeKind (..),+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    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]+  }++data Kind+  = Scalar+  | Type+  deriving (Show, Eq)++instance Pretty Kind where+  pretty Type = "TYPE"+  pretty Scalar = "SCALAR"++instance PrintType Kind where+  printType Scalar = conT ''SCALAR+  printType Type = conT ''TYPE++data ServerDirectiveUsage+  = TypeDirectiveUsage TypeValue+  | FieldDirectiveUsage FieldName TypeValue+  | EnumDirectiveUsage TypeName TypeValue+  deriving (Show)++instance PrintExp ServerDirectiveUsage where+  printExp (TypeDirectiveUsage x) = appE (varE 'typeDirective) (printExp x)+  printExp (FieldDirectiveUsage field x) = appE (appE (varE 'fieldDirective) [|field|]) (printExp x)+  printExp (EnumDirectiveUsage enum x) = appE (appE (varE 'enumDirective) [|enum|]) (printExp x)++instance Pretty ServerDirectiveUsage where+  pretty (TypeDirectiveUsage value) = "typeDirective" <+> pretty value+  pretty (FieldDirectiveUsage place value) = "fieldDirective" <+> pretty (show place :: String) <+> pretty value+  pretty (EnumDirectiveUsage place value) = "enumDirective" <+> pretty (show place :: String) <+> pretty value++data GQLTypeDefinition = GQLTypeDefinition+  { gqlTarget :: CodeGenTypeName,+    gqlKind :: Kind,+    gqlTypeDirectiveUses :: [ServerDirectiveUsage],+    gqlTypeDefaultValues :: Map Text (Value CONST),+    dropNamespace :: Maybe (TypeKind, Text)+  }+  deriving (Show)++data InterfaceDefinition = InterfaceDefinition+  { aliasName :: TypeName,+    interfaceName :: TypeName,+    unionName :: TypeName+  }+  deriving (Show)++data GQLDirectiveTypeClass = GQLDirectiveTypeClass+  { directiveTypeName :: CodeGenTypeName,+    directiveLocations :: [DirectiveLocation]+  }+  deriving (Show)++data ServerDeclaration+  = GQLTypeInstance GQLTypeDefinition+  | GQLDirectiveInstance GQLDirectiveTypeClass+  | DataType CodeGenType+  | ScalarType {scalarTypeName :: Text}+  | InterfaceType InterfaceDefinition+  deriving (Show)++newtype CodeGenConfig = CodeGenConfig+  { namespace :: Bool+  }
+ src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server.Interpreting.Transform+  ( parseServerTypeDefinitions,+  )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.CodeGen.Internal.AST+  ( CodeGenConstructor (..),+    CodeGenField (..),+    CodeGenType (..),+    CodeGenTypeName (CodeGenTypeName),+    fromTypeName,+    getFullName,+  )+import Data.Morpheus.CodeGen.Server.Internal.AST+  ( CodeGenConfig (..),+    DerivingClass (..),+    FIELD_TYPE_WRAPPER (..),+    GQLDirectiveTypeClass (..),+    GQLTypeDefinition (..),+    InterfaceDefinition (..),+    Kind (..),+    ServerDeclaration (..),+    ServerDirectiveUsage (..),+    TypeValue (..),+  )+import Data.Morpheus.CodeGen.TH+  ( ToName (toName),+  )+import Data.Morpheus.CodeGen.Utils+  ( camelCaseFieldName,+    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.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 (..),+    TypeDefinition (..),+    TypeKind (..),+    TypeName,+    TypeRef (..),+    UnionMember (..),+    isNullable,+    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+    Failure errors -> fail (renderGQLErrors errors)+    Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result++toTHDefinitions ::+  CodeGenMonad m =>+  Bool ->+  [RawTypeDefinition] ->+  m [ServerDeclaration]+toTHDefinitions namespace defs = concat <$> traverse generateTypes defs+  where+    typeDefinitions = [td | RawTypeDefinition td <- defs]+    directiveDefinitions = [td | RawDirectiveDefinition td <- defs]+    generateTypes :: CodeGenMonad m => RawTypeDefinition -> m [ServerDeclaration]+    generateTypes (RawTypeDefinition typeDef) =+      runReaderT+        (genTypeDefinition typeDef)+        TypeContext+          { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef),+            typeDefinitions,+            directiveDefinitions,+            currentTypeName = Just (typeName typeDef),+            currentKind = Just (kindOf typeDef),+            hasNamespace = namespace+          }+    generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) =+      runReaderT+        ( do+            fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs)+            let typename = coerce directiveDefinitionName+            dropNamespace <- defineTypeOptions KindInputObject (unpackName typename)+            let cgTypeName = fromTypeName typename+            pure+              [ DataType+                  CodeGenType+                    { cgTypeName,+                      cgConstructors = [CodeGenConstructor (fromTypeName typename) fields],+                      cgDerivations = [SHOW, GENERIC]+                    },+                GQLDirectiveInstance+                  GQLDirectiveTypeClass+                    { directiveTypeName = cgTypeName,+                      directiveLocations = directiveDefinitionLocations+                    },+                GQLTypeInstance+                  GQLTypeDefinition+                    { gqlTarget = cgTypeName,+                      gqlKind = Type,+                      gqlTypeDefaultValues = mempty,+                      gqlTypeDirectiveUses = [],+                      dropNamespace+                    }+              ]+        )+        TypeContext+          { toArgsTypeName = coerce,+            typeDefinitions,+            currentTypeName = Just (coerce directiveDefinitionName),+            directiveDefinitions,+            currentKind = Nothing,+            hasNamespace = namespace+          }+    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" <>)++mkPossibleTypesName :: TypeName -> TypeName+mkPossibleTypesName = ("PossibleTypes" <>)++genTypeDefinition ::+  CodeGenMonad m =>+  TypeDefinition ANY CONST ->+  ServerQ m [ServerDeclaration]+genTypeDefinition+  typeDef@TypeDefinition {typeName = originalTypeName, typeContent} =+    case tKind of+      KindScalar -> do+        scalarGQLType <- deriveGQL+        pure+          [ ScalarType (toHaskellTypeName typeName),+            scalarGQLType+          ]+      _ -> genTypeContent originalTypeName typeContent >>= withType+    where+      typeName = case typeContent of+        DataInterface {} -> mkInterfaceName originalTypeName+        _ -> originalTypeName+      tKind = kindOf typeDef+      cgTypeName = CodeGenTypeName [] ["m" | isResolverType tKind] (packName $ toHaskellTypeName typeName)+      deriveGQL = do+        gqlTypeDirectiveUses <- getDirs typeDef+        dropNamespace <- defineTypeOptions tKind (unpackName typeName)+        pure $+          GQLTypeInstance $+            GQLTypeDefinition+              { gqlTarget = cgTypeName,+                gqlTypeDirectiveUses,+                gqlKind = derivingKind tKind,+                gqlTypeDefaultValues =+                  fromList $+                    mapMaybe getDefaultValue $+                      getInputFields typeDef,+                dropNamespace+              }+      cgDerivations = derivesClasses (isResolverType tKind)+      -------------------------+      withType (ConsIN cgConstructors) = do+        gqlType <- deriveGQL+        pure [DataType CodeGenType {..}, gqlType]+      withType (ConsOUT others cgConstructors) = do+        gqlType <- deriveGQL+        pure (DataType CodeGenType {..} : gqlType : others)++derivingKind :: TypeKind -> Kind+derivingKind KindScalar = Scalar+derivingKind _ = Type++derivesClasses :: Bool -> [DerivingClass]+derivesClasses isResolver = GENERIC : [SHOW | not isResolver]++mkObjectCons :: TypeName -> [CodeGenField] -> [CodeGenConstructor]+mkObjectCons name = pure . CodeGenConstructor (fromTypeName 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 CodeGenField+mkObjectField+  FieldDefinition+    { fieldName = fName,+      fieldContent,+      fieldType = TypeRef {typeConName, typeWrappers}+    } = do+    isParametrized <- lift . isParametrizedResolverType typeConName =<< asks typeDefinitions+    genName <- asks toArgsTypeName+    kind <- asks currentKind+    fieldName <- renderFieldName fName+    pure+      CodeGenField+        { fieldType = packName (toHaskellTypeName typeConName),+          fieldIsNullable = isNullable typeWrappers,+          wrappers =+            mkFieldArguments fName genName (toArgList fieldContent)+              <> [SUBSCRIPTION ''SubscriptionField | 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 ''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 [CodeGenConstructor]+  | ConsOUT [ServerDeclaration] [CodeGenConstructor]++genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerDeclaration]+genInterfaceUnion interfaceName =+  mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName)+    <$> asks typeDefinitions+  where+    mkInterface [] = []+    mkInterface [possibleTypeName] = [mkGuardWithPossibleType possibleTypeName]+    mkInterface members =+      [ mkGuardWithPossibleType tName,+        DataType+          CodeGenType+            { cgTypeName = possTypeName,+              cgConstructors = map (mkUnionFieldDefinition tName) members,+              cgDerivations = derivesClasses True+            },+        GQLTypeInstance+          GQLTypeDefinition+            { gqlTarget = possTypeName,+              gqlKind = Type,+              gqlTypeDirectiveUses = empty,+              gqlTypeDefaultValues = mempty,+              dropNamespace = Nothing+            }+      ]+      where+        possTypeName = CodeGenTypeName [] ["m"] (packName $ toHaskellTypeName tName)+    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 = []+      }++renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m CodeGenField+renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do+  fieldName <- renderFieldName fName+  let wrappers = [GQL_WRAPPER typeWrappers]+  let fieldType = packName (toHaskellTypeName typeConName)+  let fieldIsNullable = isNullable typeWrappers+  pure CodeGenField {..}++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 renderDataField (toList fields)+genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported"+genTypeContent typeName DataInterface {interfaceFields} =+  ConsOUT+    <$> ((<>) <$> genArgumentTypes interfaceFields <*> genInterfaceUnion typeName)+    <*> ( do+            let interfaceName = mkInterfaceName typeName+            inType+              (Just 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 -> CodeGenConstructor+mkUnionFieldDefinition typeName memberName =+  CodeGenConstructor+    { constructorName,+      constructorFields =+        [ CodeGenField+            { fieldName = coerce ("un" <> getFullName constructorName),+              fieldType = packName (toHaskellTypeName memberName),+              wrappers = [PARAMETRIZED],+              fieldIsNullable = False+            }+        ]+    }+  where+    constructorName = CodeGenTypeName [coerce typeName] [] memberName++genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]+genArgumentTypes = fmap concat . traverse genArgumentType . toList++genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration]+genArgumentType+  FieldDefinition+    { fieldName,+      fieldContent = Just (FieldArgs arguments)+    }+    | length arguments > 1 = do+        tName <- (fieldName &) <$> asks toArgsTypeName+        inType (Just tName) $ do+          let argumentFields = argument <$> toList arguments+          fields <- traverse renderDataField argumentFields+          let typename = toHaskellTypeName tName+          gqlTypeDirectiveUses <- concat <$> traverse getDirs argumentFields+          dropNamespace <- defineTypeOptions KindInputObject typename+          let cgTypeName = fromTypeName (packName typename)+          pure+            [ DataType+                CodeGenType+                  { cgTypeName,+                    cgConstructors = mkObjectCons tName fields,+                    cgDerivations = derivesClasses False+                  },+              GQLTypeInstance+                GQLTypeDefinition+                  { gqlTarget = cgTypeName,+                    gqlKind = Type,+                    gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields),+                    gqlTypeDirectiveUses,+                    dropNamespace+                  }+            ]+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+    { 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/Printing/Document.hs view
@@ -0,0 +1,142 @@+{-# 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
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.CodeGen.Server.Printing.TH+  ( compileDocument,+    gqlDocument,+  )+where++import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..))+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,+  )+import Data.Morpheus.Types.Internal.AST (DirectiveLocation)+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Relude hiding (ByteString, Type)++gqlDocument :: QuasiQuoter+gqlDocument = mkQuasiQuoter CodeGenConfig {namespace = False}++mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter+mkQuasiQuoter ctx =+  QuasiQuoter+    { quoteExp = notHandled "Expressions",+      quotePat = notHandled "Patterns",+      quoteType = notHandled "Types",+      quoteDec = compileDocument ctx . LB.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|])++printDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ+printDirectiveUsages = foldr (appE . appE [|(<>)|] . printExp) [|mempty|]