diff --git a/morpheus-graphql-code-gen-utils.cabal b/morpheus-graphql-code-gen-utils.cabal --- a/morpheus-graphql-code-gen-utils.cabal +++ b/morpheus-graphql-code-gen-utils.cabal @@ -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 diff --git a/src/Data/Morpheus/CodeGen/Internal/AST.hs b/src/Data/Morpheus/CodeGen/Internal/AST.hs --- a/src/Data/Morpheus/CodeGen/Internal/AST.hs +++ b/src/Data/Morpheus/CodeGen/Internal/AST.hs @@ -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)) diff --git a/src/Data/Morpheus/CodeGen/Internal/Name.hs b/src/Data/Morpheus/CodeGen/Internal/Name.hs --- a/src/Data/Morpheus/CodeGen/Internal/Name.hs +++ b/src/Data/Morpheus/CodeGen/Internal/Name.hs @@ -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 diff --git a/src/Data/Morpheus/CodeGen/Printer.hs b/src/Data/Morpheus/CodeGen/Printer.hs --- a/src/Data/Morpheus/CodeGen/Printer.hs +++ b/src/Data/Morpheus/CodeGen/Printer.hs @@ -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) diff --git a/src/Data/Morpheus/CodeGen/TH.hs b/src/Data/Morpheus/CodeGen/TH.hs --- a/src/Data/Morpheus/CodeGen/TH.hs +++ b/src/Data/Morpheus/CodeGen/TH.hs @@ -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]