morpheus-graphql-code-gen-utils 0.22.1 → 0.23.0

raw patch · 5 files changed

+159/−62 lines, 5 filesdep ~morpheus-graphql-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-core

API changes (from Hackage documentation)

Files

• morpheus-graphql-code-gen-utils.cabal +2/−2
• src/Data/Morpheus/CodeGen/Internal/AST.hs +104/−4
• src/Data/Morpheus/CodeGen/Internal/Name.hs +3/−1
• src/Data/Morpheus/CodeGen/Printer.hs +11/−13
• src/Data/Morpheus/CodeGen/TH.hs +39/−42

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-code-gen-utils-version:        0.22.1+version:        0.23.0 synopsis:       Morpheus GraphQL CLI description:    code generator for Morpheus GraphQL category:       web, graphql, cli@@ -41,7 +41,7 @@       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.22.0 && <0.23.0+    , morpheus-graphql-core >=0.23.0 && <0.24.0     , prettyprinter >=1.7.0 && <2.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0

@@ -12,13 +12,19 @@     TypeValue (..),     fromTypeName,     getFullName,+    ModuleDefinition (..),+    TypeClassInstance (..),+    AssociatedType (..),+    MethodArgument (..),+    printTHName,   ) where  import Data.Morpheus.CodeGen.Internal.Name (camelCaseTypeName) import Data.Morpheus.CodeGen.Printer import Data.Morpheus.Types.Internal.AST-  ( FieldName,+  ( DirectiveLocation,+    FieldName,     TypeName,     TypeRef,     TypeWrapper,@@ -33,6 +39,7 @@     hsep,     indent,     line,+    list,     nest,     pretty,     punctuate,@@ -40,7 +47,7 @@     vsep,     (<+>),   )-import Relude hiding (print)+import Relude hiding (optional, print)  data DerivingClass   = SHOW@@ -85,9 +92,13 @@   }   deriving (Show) +isNewType :: CodeGenType -> Bool+isNewType CodeGenType {cgConstructors = [CodeGenConstructor {constructorFields = [_]}]} = True+isNewType _ = False+ instance Pretty CodeGenType where-  pretty CodeGenType {..} =-    "data"+  pretty t@CodeGenType {..} =+    (if isNewType t then "newtype" else "data")       <+> ignore (print cgTypeName)         <> renderConstructors cgConstructors         <> line@@ -167,3 +178,92 @@  parametrizedType :: Text -> [Text] -> Doc ann parametrizedType tName typeParameters = hsep $ map pretty $ tName : typeParameters++data ModuleDefinition dec = ModuleDefinition+  { moduleName :: Text,+    imports :: [(Text, [Text])],+    extensions :: [Text],+    types :: [dec]+  }++instance Pretty dec => Pretty (ModuleDefinition dec) where+  pretty ModuleDefinition {..} =+    vsep+      (map renderExtension extensions)+      <> "{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}"+      <> line+      <> line+      <> "{-# HLINT ignore \"Use camelCase\" #-}"+      <> line+      <> line+      <> "module"+      <+> pretty moduleName+      <+> "where"+        <> line+        <> line+        <> vsep (map renderImport imports)+        <> line+        <> line+        <> vsep (map pretty types)++renderExtension :: Text -> Doc ann+renderExtension name = "{-#" <+> "LANGUAGE" <+> pretty name <+> "#-}"++renderImport :: (Text, [Text]) -> Doc ann+renderImport (src, ls) = "import" <+> pretty src <> renderImportList ls++renderImportList :: [Text] -> Doc ann+renderImportList ["*"] = ""+renderImportList xs = tupled (map pretty xs)++data TypeClassInstance body = TypeClassInstance+  { typeClassName :: TH.Name,+    typeClassContext :: [(TH.Name, TH.Name)],+    typeClassTarget :: CodeGenTypeName,+    assoc :: [(TH.Name, AssociatedType)],+    typeClassMethods :: [(TH.Name, MethodArgument, body)]+  }+  deriving (Show)++instance Pretty a => Pretty (TypeClassInstance a) where+  pretty TypeClassInstance {..} =+    "instance"+      <> optional renderTypeableConstraints (typeParameters typeClassTarget)+      <+> printTHName typeClassName+      <+> typeHead+      <+> "where"+        <> line+        <> indent 2 (vsep (map renderAssoc assoc <> map renderMethodD typeClassMethods))+    where+      typeHead = unpack (print typeClassTarget)+      renderAssoc (name, a) = "type" <+> printTHName name <+> typeHead <+> "=" <+> pretty a+      renderMethodD (name, args, method) = printTHName name <+> pretty args <+> "=" <+> pretty method++renderTypeableConstraints :: [Text] -> Doc n+renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>"++data AssociatedType+  = AssociatedTypeName TH.Name+  | AssociatedLocations [DirectiveLocation]+  deriving (Show)++printTHName :: TH.Name -> Doc ann+printTHName = ignore . print++printPromotedLocation :: DirectiveLocation -> Doc ann+printPromotedLocation = ("'" <>) . ignore . print++instance Pretty AssociatedType where+  pretty (AssociatedTypeName x) = printTHName x+  pretty (AssociatedLocations x) = list $ map printPromotedLocation x++data MethodArgument+  = NoArgument+  | ProxyArgument+  | DestructArgument TH.Name [TH.Name]+  deriving (Show)++instance Pretty MethodArgument where+  pretty NoArgument = ""+  pretty ProxyArgument = "_"+  pretty (DestructArgument x xs) = unpack (print x .<> pack (hsep $ map printTHName xs))

@@ -43,7 +43,9 @@ toHaskellTypeName "String" = "Text" toHaskellTypeName "Boolean" = "Bool" toHaskellTypeName "Float" = "Double"-toHaskellTypeName name = capitalize $ unpackName name+toHaskellTypeName name+  | T.head (unpackName name) == '_' = capitalize $ T.tail (unpackName name)+  | otherwise = capitalize $ unpackName name {-# INLINE toHaskellTypeName #-}  uncapitalize :: Text -> Text

@@ -13,22 +13,24 @@     wrapped,     (.<>),     optional,-    renderExtension,-    renderImport,     ignore,     pack,   ) where  import Data.Morpheus.Types.Internal.AST-  ( Name,+  ( DirectiveLocation,+    Name,     TypeRef (..),     TypeWrapper (..),+    packName,     unpackName,   ) import qualified Data.Text as T+import qualified Language.Haskell.TH as TH import Prettyprinter (Doc, Pretty (..), list, pretty, tupled, (<+>)) import Relude hiding (optional, print, show)+import Prelude (show)  infix' :: HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n infix' a op b = pack $ rawDocument a <+> rawDocument op <+> rawDocument b@@ -85,16 +87,12 @@ instance Printer String where   print = pack . pretty +instance Printer DirectiveLocation where+  print = fromString . show++instance Printer TH.Name where+  print = print . packName+ optional :: ([a] -> Doc n) -> [a] -> Doc n optional _ [] = "" optional f xs = " " <> f xs--renderExtension :: Text -> Doc ann-renderExtension name = "{-#" <+> "LANGUAGE" <+> pretty name <+> "#-}"--renderImport :: (Text, [Text]) -> Doc ann-renderImport (src, ls) = "import" <+> pretty src <> renderImportList ls--renderImportList :: [Text] -> Doc ann-renderImportList ["*"] = ""-renderImportList xs = tupled (map pretty xs)

@@ -26,23 +26,23 @@     PrintDec (..),     m',     m_,-    printTypeClass,     printTypeSynonym,-    destructConstructor,   ) where  import Data.Morpheus.CodeGen.Internal.AST-  ( CodeGenConstructor (..),+  ( AssociatedType (..),+    CodeGenConstructor (..),     CodeGenField (..),     CodeGenType (..),     CodeGenTypeName (..),     DerivingClass (..),     FIELD_TYPE_WRAPPER (..),+    MethodArgument (..),+    TypeClassInstance (..),     TypeValue (..),     getFullName,   )-import Data.Morpheus.CodeGen.Internal.Name (camelCaseFieldName) import Data.Morpheus.CodeGen.Utils   ( toHaskellName,     toHaskellTypeName,@@ -142,7 +142,7 @@ #if MIN_VERSION_template_haskell(2,18,0)   toCon name = ConP (toName name) [] [] #else-  toCon name = ConP (toName name) [] +  toCon name = ConP (toName name) [] #endif {- ORMOLU_ENABLE -} @@ -214,7 +214,7 @@   printType :: a -> TypeQ  class PrintDec a where-  printDec :: a -> Dec+  printDec :: a -> Q Dec  printFieldExp :: (FieldName, TypeValue) -> Q FieldExp printFieldExp (fName, fValue) = do@@ -275,17 +275,6 @@ printConstraints :: [(Name, Name)] -> Q Cxt printConstraints = cxt . map constraint -printTypeClass :: [(Name, Name)] -> Name -> Q Type -> [(Name, Type)] -> [(Name, [PatQ], ExpQ)] -> Q Dec-printTypeClass cts name target assoc methods =-  instanceD-    (printConstraints cts)-    headType-    (map assocTypes assoc <> map printFun methods)-  where-    printFun (funName, args, body) = funD funName [clause args (normalB body) []]-    assocTypes (assocName, type') = flip (typeInstanceDec assocName) type' <$> target-    headType = apply name [target]- printConstructor :: CodeGenConstructor -> Con printConstructor CodeGenConstructor {..}   | null constructorFields = NormalC (toName constructorName) []@@ -320,30 +309,38 @@   toName AST.INPUT_OBJECT = 'AST.INPUT_OBJECT   toName AST.INPUT_FIELD_DEFINITION = 'AST.INPUT_FIELD_DEFINITION -instance PrintDec CodeGenType where-  printDec CodeGenType {..} =-    DataD-      []-      (toName cgTypeName)-      (toTypeVars $ map toName $ typeParameters cgTypeName)-      Nothing-      (map printConstructor cgConstructors)-      [printDerivClause cgDerivations]+instance PrintType AssociatedType where+  printType (AssociatedLocations xs) = pure $ foldr (AppT . AppT PromotedConsT . PromotedT . toName) PromotedNilT xs+  printType (AssociatedTypeName name) = toCon name --- |--- input:--- >>>--- WAS WAS destructRecord "User" ["name","id"]--- >>>------ expression:--- >>>--- WAS WAS (User name id)--- >>>-destructConstructor :: CodeGenConstructor -> PatQ-destructConstructor (CodeGenConstructor conName fields) = conP (toName conName) names-  where-    names = map (typeField conName . fieldName) fields+instance PrintExp body => PrintDec (TypeClassInstance body) where+  printDec TypeClassInstance {..} =+    instanceD+      (printConstraints typeClassContext)+      headType+      (map assocTypes assoc <> map printFun typeClassMethods)+    where+      printFun (funName, args, body) = funD funName [clause (printArg args) (normalB (printExp body)) []]+      assocTypes (assocName, type') = do+        ty <- printType typeClassTarget+        assocType <- printType type'+        pure $ typeInstanceDec assocName ty assocType+      headType = do+        ty <- printType typeClassTarget+        pure $ apply typeClassName [ty] -typeField :: ToVar FieldName c => CodeGenTypeName -> FieldName -> c-typeField conName = toVar . camelCaseFieldName (getFullName conName)+printArg :: MethodArgument -> [PatQ]+printArg (DestructArgument con fields) = [conP con (map toVar fields)]+printArg NoArgument = []+printArg ProxyArgument = [_']++instance PrintDec CodeGenType where+  printDec CodeGenType {..} =+    pure $+      DataD+        []+        (toName cgTypeName)+        (toTypeVars $ map toName $ typeParameters cgTypeName)+        Nothing+        (map printConstructor cgConstructors)+        [printDerivClause cgDerivations]