morpheus-graphql-code-gen 0.20.1 → 0.21.0

raw patch · 9 files changed

+349/−165 lines, 9 filesdep ~morpheus-graphql-coredep ~prettyprinterPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-core, prettyprinter

API changes (from Hackage documentation)

Files

• app/Main.hs +3/−3
• morpheus-graphql-code-gen.cabal +6/−6
• src/Data/Morpheus/CodeGen/Internal/AST.hs +44/−6
• src/Data/Morpheus/CodeGen/Internal/Name.hs +4/−3
• src/Data/Morpheus/CodeGen/Interpreting/Transform.hs +239/−108
• src/Data/Morpheus/CodeGen/Printing/GQLType.hs +21/−24
• src/Data/Morpheus/CodeGen/Printing/Render.hs +8/−7
• src/Data/Morpheus/CodeGen/Printing/Terms.hs +4/−3
• src/Data/Morpheus/CodeGen/Printing/Type.hs +20/−5

@@ -6,11 +6,11 @@   ) where +import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L   ( readFile,     writeFile,   )-import Data.ByteString.Lazy (ByteString) import Data.Char import Data.Morpheus.CodeGen   ( CodeGenConfig (..),@@ -48,13 +48,13 @@ import qualified Paths_morpheus_graphql_code_gen as CLI import Relude hiding (ByteString) import System.FilePath.Posix-  ( (</>),-    dropExtensions,+  ( dropExtensions,     makeRelative,     normalise,     replaceExtensions,     splitDirectories,     splitFileName,+    (</>),   )  currentVersion :: String

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           morpheus-graphql-code-gen-version:        0.20.1+version:        0.21.0 synopsis:       Morpheus GraphQL CLI description:    code generator for Morpheus GraphQL category:       web, graphql, cli@@ -46,8 +46,8 @@       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.20.0 && <0.21.0-    , prettyprinter >=1.2.0 && <2.0.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0+    , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <1.3.0@@ -67,9 +67,9 @@     , containers >=0.4.2.1 && <0.7.0     , filepath >=1.1.0 && <1.5.0     , morpheus-graphql-code-gen-    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0     , optparse-applicative >=0.12.0 && <0.18.0-    , prettyprinter >=1.2.0 && <2.0.0+    , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <1.3.0

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Internal.AST@@ -16,24 +17,24 @@     ServerConstructorDefinition (..),     ServerFieldDefinition (..),     Kind (..),+    ServerDirectiveUsage (..),+    TypeValue (..),   ) where  import Data.Morpheus.Types.Internal.AST   ( CONST,     Description,-    Directives,+    DirectiveLocation (..),     FieldName,     TypeKind (..),-    TypeKind,     TypeName,-    TypeName,     TypeRef (..),-    TypeRef,     TypeWrapper (..),     Value,     unpackName,   )+import Prettyprinter (Doc, Pretty (..), punctuate, vsep, (<+>)) import Relude  data ModuleDefinition = ModuleDefinition@@ -66,11 +67,42 @@  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,-    gqlTypeDirectives :: Map Text (Directives CONST),+    gqlTypeDirectiveUses :: [ServerDirectiveUsage],     gqlTypeDefaultValues :: Map Text (Value CONST)   }   deriving (Show)@@ -88,7 +120,13 @@         tCons :: [ServerConstructorDefinition],         tKind :: TypeKind,         derives :: [DerivingClass],-        gql :: Maybe GQLTypeDefinition+        typeGQLType :: Maybe GQLTypeDefinition+      }+  | DirectiveTypeDefinition+      { directiveConstructor :: ServerConstructorDefinition,+        directiveDerives :: [DerivingClass],+        directiveLocations :: [DirectiveLocation],+        directiveGQLType :: GQLTypeDefinition       }   | ServerInterfaceDefinition       TypeName

@@ -12,13 +12,13 @@   ( toLower,     toUpper,   )-import qualified Data.Morpheus.Types.Internal.AST as N 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 (..),@@ -35,8 +35,9 @@  camelCaseTypeName :: [N.Name t] -> TypeName -> TypeName camelCaseTypeName list name =-  packName $ T.concat $-    map (capitalize . unpackName) (list <> [coerce name])+  packName $+    T.concat $+      map (capitalize . unpackName) (list <> [coerce name])  toHaskellTypeName :: TypeName -> Text toHaskellTypeName "String" = "Text"

@@ -24,8 +24,10 @@     GQLTypeDefinition (..),     Kind (..),     ServerConstructorDefinition (..),+    ServerDirectiveUsage (..),     ServerFieldDefinition (..),     ServerTypeDefinition (..),+    TypeValue (..),   ) import Data.Morpheus.CodeGen.Internal.Name   ( camelCaseFieldName,@@ -35,18 +37,19 @@   ( ToName (toName),     camelCaseTypeName,   )-import Data.Morpheus.Core-  ( parseTypeDefinitions,-  )+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,-    Directives,+    Directive (Directive, directiveArgs, directiveName),+    DirectiveDefinition (..),     FieldContent (..),     FieldDefinition (..),     FieldName,@@ -54,7 +57,9 @@     GQLError,     IN,     OUT,+    ObjectEntry (..),     OperationType (Subscription),+    RawTypeDefinition (..),     TRUE,     Token,     TypeContent (..),@@ -63,13 +68,14 @@     TypeName,     TypeRef (..),     UnionMember (..),-    Value,     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 (..),@@ -109,39 +115,72 @@  data TypeContext s = TypeContext   { toArgsTypeName :: FieldName -> TypeName,-    schema :: [TypeDefinition ANY s],-    currentTypeName :: TypeName,-    hasNamespace :: Bool,-    currentKind :: Maybe TypeKind+    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 parseTypeDefinitions txt of+  case parseDefinitions txt of     Failure errors -> fail (renderGQLErrors errors)-    Success {result = schema, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) schema+    Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result  toTHDefinitions ::   CodeGenMonad m =>   Bool ->-  [TypeDefinition ANY CONST] ->+  [RawTypeDefinition] ->   m [ServerTypeDefinition]-toTHDefinitions namespace schema = concat <$> traverse generateTypes schema+toTHDefinitions namespace defs = concat <$> traverse generateTypes defs   where-    generateTypes :: CodeGenMonad m => TypeDefinition ANY CONST -> m [ServerTypeDefinition]-    generateTypes typeDef =+    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),-            schema,-            currentTypeName = 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 => TypeName -> m a -> m a-inType currentTypeName = local (\x -> x {currentTypeName, currentKind = 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" <>)@@ -158,32 +197,39 @@     { typeName = originalTypeName,       typeContent,       typeDescription-    } = withType <$> genTypeContent originalTypeName typeContent+    } = genTypeContent originalTypeName typeContent >>= withType     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-            }+      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) = [ServerTypeDefinition {..}]-      withType (ConsOUT others tCons) = ServerTypeDefinition {..} : others+      withType (ConsIN tCons) = do+        typeGQLType <- deriveGQL+        pure [ServerTypeDefinition {..}]+      withType (ConsOUT others tCons) = do+        typeGQLType <- deriveGQL+        pure (ServerTypeDefinition {..} : others)  derivingKind :: TypeKind -> Kind derivingKind KindScalar = Scalar@@ -226,10 +272,10 @@       fieldContent,       fieldType = TypeRef {typeConName, typeWrappers}     } = do-    isParametrized <- lift . isParametrizedResolverType typeConName =<< asks schema+    isParametrized <- lift . isParametrizedResolverType typeConName =<< asks typeDefinitions     genName <- asks toArgsTypeName     kind <- asks currentKind-    fieldName <- genFieldName fName+    fieldName <- renderFieldName fName     pure       ServerFieldDefinition         { fieldType = toHaskellTypeName typeConName,@@ -262,7 +308,7 @@ genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerTypeDefinition] genInterfaceUnion interfaceName =   mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName)-    <$> asks schema+    <$> asks typeDefinitions   where     tKind = KindUnion     mkInterface [] = []@@ -275,18 +321,18 @@             tKind,             typeParameters = ["m"],             derives = derivesClasses True,-            gql = Nothing+            typeGQLType = Nothing           }       ]     mkGuardWithPossibleType = ServerInterfaceDefinition interfaceName (mkInterfaceName interfaceName)     tName = mkPossibleTypesName interfaceName -genFieldName :: Monad m => FieldName -> ServerQ m FieldName-genFieldName fieldName = do+renderFieldName :: Monad m => FieldName -> ServerQ m FieldName+renderFieldName fieldName = do   TypeContext {hasNamespace, currentTypeName} <- ask   pure $     if hasNamespace-      then camelCaseFieldName currentTypeName fieldName+      then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName       else fieldName  mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition@@ -301,19 +347,12 @@         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]-        }+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 =>@@ -323,7 +362,7 @@ genTypeContent _ DataScalar {} = pure (ConsIN []) genTypeContent typeName (DataEnum tags) = ConsIN <$> traverse (mkConsEnum typeName) tags genTypeContent typeName (DataInputObject fields) =-  ConsIN . mkObjectCons typeName <$> traverse toNonResolverServerField (toList fields)+  ConsIN . mkObjectCons typeName <$> traverse renderDataField (toList fields) genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported" genTypeContent typeName DataInterface {interfaceFields} =   ConsOUT@@ -331,13 +370,14 @@     <*> ( do             let interfaceName = mkInterfaceName typeName             inType-              interfaceName+              (Just interfaceName)               ( mkObjectCons interfaceName                   <$> traverse mkObjectField (toList interfaceFields)               )         ) genTypeContent typeName DataObject {objectFields} =-  ConsOUT <$> genArgumentTypes objectFields+  ConsOUT+    <$> genArgumentTypes objectFields     <*> ( mkObjectCons typeName             <$> traverse mkObjectField (toList objectFields)         )@@ -371,52 +411,54 @@       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)-                        }-                    )-              }-          ]+        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 -mkFieldDirective :: FieldDefinition cat s -> (Text, Directives s)-mkFieldDirective FieldDefinition {..} = (unpackName fieldName, fieldDirectives)- --- -getDesc :: TypeDefinition c s -> Map Token Description-getDesc = fromList . get+getDesc :: MonadFail m => TypeDefinition c CONST -> ServerQ m (Map Token Description)+getDesc = fmap fromList . get -getDirs :: TypeDefinition c s -> Map Token (Directives s)-getDirs = 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 :: a -> [(Token, v)]+  get :: MonadFail m => a -> ServerQ m [(Token, v)]  instance (Meta a v) => Meta (Maybe a) v where   get (Just x) = get x-  get _ = []+  get _ = pure []  instance   ( Meta (FieldsDefinition IN s) v,@@ -437,41 +479,130 @@   get DataObject {objectFields} = get objectFields   get DataInputObject {inputObjectFields} = get inputObjectFields   get DataInterface {interfaceFields} = get interfaceFields-  get DataEnum {enumMembers} = concatMap get enumMembers-  get _ = []+  get DataEnum {enumMembers} = concat <$> traverse get enumMembers+  get _ = pure [] -instance Meta (DataEnumValue s) Description where-  get DataEnumValue {enumName, enumDescription = Just x} = [(unpackName enumName, x)]-  get _ = []+instance Meta (DataEnumValue CONST) Description where+  get DataEnumValue {enumName, enumDescription = Just x} = pure [(unpackName enumName, x)]+  get _ = pure [] -instance Meta (DataEnumValue s) (Directives s) where+instance Meta (DataEnumValue CONST) ServerDirectiveUsage where   get DataEnumValue {enumName, enumDirectives}-    | null enumDirectives = []-    | otherwise = [(unpackName enumName, enumDirectives)]+    | null enumDirectives = pure []+    | otherwise = traverse transform (toList enumDirectives)+    where+      transform x = (unpackName enumName,) . EnumDirectiveUsage enumName <$> directiveTypeValue x  instance-  Meta (FieldDefinition c s) v =>-  Meta (FieldsDefinition c s) v+  Meta (FieldDefinition c CONST) v =>+  Meta (FieldsDefinition c CONST) v   where-  get = concatMap get . toList+  get = fmap concat . traverse get . toList -instance Meta (FieldDefinition c s) Description where-  get FieldDefinition {fieldName, fieldDescription = Just x} = [(unpackName fieldName, x)]-  get _ = []+instance Meta (FieldDefinition c CONST) Description where+  get FieldDefinition {fieldName, fieldDescription = Just x} = pure [(unpackName fieldName, x)]+  get _ = pure [] -instance Meta (FieldDefinition c s) (Directives s) where+instance Meta (FieldDefinition c CONST) ServerDirectiveUsage where   get FieldDefinition {fieldName, fieldDirectives}-    | null fieldDirectives = []-    | otherwise = [(unpackName 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, Value s)+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!"

@@ -1,5 +1,5 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.CodeGen.Printing.GQLType@@ -10,6 +10,7 @@ import Data.Morpheus.CodeGen.Internal.AST   ( GQLTypeDefinition (..),     Kind (..),+    ServerDirectiveUsage (..),     ServerTypeDefinition (..),     TypeKind,   )@@ -17,36 +18,29 @@   ( optional,     parametrizedType,   )-import Data.Text.Prettyprint.Doc-  ( Doc,-    Pretty (pretty),-    indent,-    line,-    tupled,-    vsep,-    (<+>),-  )+import Prettyprinter 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 = ""+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 {tName, typeParameters, tKind, gql} =+renderGQLType ServerTypeDefinition {..} =   "instance"     <> optional renderTypeableConstraints typeParameters     <+> "GQLType"     <+> typeHead     <+> "where"-    <> line-    <> indent 2 (vsep (renderMethods typeHead gql <> [options]))+      <> line+      <> indent 2 (vsep (renderMethods typeHead typeGQLType <> [options]))   where-    options = defineTypeOptions tName tKind+    options = defineTypeOptions False tName tKind     typeHead =       if null typeParameters         then parametrizedType tName typeParameters@@ -57,16 +51,19 @@ renderMethods _ Nothing = [] renderMethods   typeHead-  ( Just-      GQLTypeDefinition-        { gqlTypeDescription,-          gqlTypeDescriptions,-          gqlKind-        }-    ) =+  (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"

@@ -27,7 +27,7 @@   ( fromStrict,   ) import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Text.Prettyprint.Doc+import Prettyprinter   ( Doc,     line,     pretty,@@ -49,6 +49,7 @@                   [ ("Data.Data", ["Typeable"]),                     ("Data.Morpheus.Kind", ["TYPE"]),                     ("Data.Morpheus.Types", []),+                    ("Data.Morpheus", []),                     ("Data.Text", ["Text"]),                     ("GHC.Generics", ["Generic"]),                     ("Data.Map", ["fromList", "empty"])@@ -78,9 +79,9 @@       <> "module"       <+> pretty moduleName       <+> "where"-      <> line-      <> line-      <> vsep (map renderImport imports)-      <> line-      <> line-      <> either (error . show) id (renderTypes types)+        <> line+        <> line+        <> vsep (map renderImport imports)+        <> line+        <> line+        <> either (error . show) id (renderTypes types)

@@ -22,7 +22,7 @@     unpackName,   ) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc+import Prettyprinter   ( Doc,     hsep,     list,@@ -73,5 +73,6 @@  renderImport :: (Text, [Text]) -> Doc ann renderImport (src, ls) =-  "import" <+> pretty src-    <> optional (tupled . map pretty) ls+  "import"+    <+> pretty src+      <> optional (tupled . map pretty) ls

@@ -31,7 +31,7 @@     renderType,     renderWrapped,   )-import Data.Text.Prettyprint.Doc+import Prettyprinter   ( Doc,     comma,     enclose,@@ -74,14 +74,29 @@         pure $           "data"             <+> parametrizedType tName typeParameters-            <> cons-            <> line-            <> indent 2 derivations-            <> line+              <> 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