diff --git a/pinch-gen.cabal b/pinch-gen.cabal --- a/pinch-gen.cabal +++ b/pinch-gen.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: pinch-gen -version: 0.4.4.0 +version: 0.4.5.0 -- synopsis: synopsis: A code generator for the pinch Thrift library. homepage: https://github.com/phile314/pinch-gen @@ -20,7 +20,7 @@ hs-source-dirs: src other-modules: Pinch.Generate , Pinch.Generate.Pretty - build-depends: base >=4.12 && < 4.19 + build-depends: base >=4.12 && < 5 , bytestring , directory , filepath diff --git a/src/Pinch/Generate.hs b/src/Pinch/Generate.hs --- a/src/Pinch/Generate.hs +++ b/src/Pinch/Generate.hs @@ -8,7 +8,6 @@ import Control.Monad.Reader import qualified Data.ByteString as BS import Data.Char -import Data.Foldable (forM_) import qualified Data.HashMap.Strict as Map import Data.List import Data.Maybe @@ -100,7 +99,9 @@ (imports, tyMaps) <- unzip <$> traverse (gInclude s baseDir) incHeaders let tyMap = Map.unions tyMaps - let (typeDecls, clientDecls, serverDecls) = unzip3 $ runReader (traverse gDefinition defs) $ Context tyMap s + let (typeDecls, clientDecls, serverDecls, serverImports) = unzip4 $ + runReader (traverse gDefinition defs) $ + Context tyMap s headers let mkMod suffix = H.Module (H.ModuleName $ modBaseName <> suffix) [ H.PragmaLanguage "TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings" , H.PragmaOptsGhc "-w" ] @@ -123,7 +124,7 @@ mkMod ".Server" ( [ impTypes , H.ImportDecl (H.ModuleName "Pinch.Server") True H.IEverything - ] ++ imports ++ defaultImports) + ] ++ imports ++ concat serverImports ++ defaultImports) (concat serverDecls) ] @@ -140,7 +141,6 @@ , H.ImportDecl (H.ModuleName "Control.Applicative") True H.IEverything , H.ImportDecl (H.ModuleName "Control.Exception") True H.IEverything , H.ImportDecl (H.ModuleName "Pinch") True H.IEverything - , H.ImportDecl (H.ModuleName "Pinch.Server") True H.IEverything , H.ImportDecl (H.ModuleName "Pinch.Internal.RPC") True H.IEverything , H.ImportDecl (H.ModuleName "Data.Text") True H.IEverything , H.ImportDecl (H.ModuleName "Data.ByteString") True H.IEverything @@ -159,6 +159,7 @@ = Context { cModuleMap :: ModuleMap , cSettings :: Settings + , cHeaders :: [Header SourcePos] } type GenerateM = Reader Context @@ -171,10 +172,10 @@ let thriftModName = T.pack $ dropExtension $ T.unpack $ includePath i pure (H.ImportDecl modName True H.IEverything, Map.singleton thriftModName modName) -gDefinition :: Definition SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl]) +gDefinition :: Definition SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl], [H.ImportDecl]) gDefinition def = case def of - ConstDefinition c -> (\x -> (x, [], [])) <$> gConst c - TypeDefinition ty -> (\x -> (x, [], [])) <$> gType ty + ConstDefinition c -> (\x -> (x, [], [], [])) <$> gConst c + TypeDefinition ty -> (\x -> (x, [], [], [])) <$> gType ty ServiceDefinition s -> gService s gConst :: A.Const SourcePos -> GenerateM [H.Decl] @@ -439,28 +440,51 @@ pure (index, prefix <> "_" <> fieldName f, ty, req) -gService :: Service SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl]) +gService :: Service SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl], [H.ImportDecl]) gService s = do + headers <- asks cHeaders + settings <- asks cSettings (nms, tys, handlers, calls, tyDecls) <- unzip5 <$> traverse gFunction (serviceFunctions s) + + let (additionalImports, baseService, baseFunction) = case serviceExtends s of + Just baseServiceIdentifier -> do + case T.splitOn "." baseServiceIdentifier of + [importSource, baseServiceName] -> do + let importModule = (getModuleName settings headers $ T.unpack importSource) <> ".Server" + ([importModule], [("baseServer", H.TyCon $ importModule <> "." <> baseServiceName)], ".functions_" <> baseServiceName) + _ -> ([], [], "") + Nothing -> ([], [], "") + let extensionFunction = case additionalImports of + [] -> "" + imports -> head imports <> baseFunction <> " (baseServer server) `Data.HashMap.Strict.union` " let serverDecls = - [ H.DataDecl serviceTyName [ H.RecConDecl serviceConName $ zip nms tys ] [] + [ H.DataDecl serviceTyName [ H.RecConDecl serviceConName $ baseService <> zip nms tys ] [] + , H.TypeSigDecl + ("functions_" <> serviceConName) + ( H.TyLam + [H.TyCon serviceConName] + (H.TyCon "Data.HashMap.Strict.HashMap Data.Text.Text Pinch.Server.Handler") + ) + , H.FunBind + [ H.Match ("functions_" <> serviceConName) [H.PVar "server"] + ( H.EApp (H.EVar (extensionFunction <> "Data.HashMap.Strict.fromList")) [ H.EList handlers ] ) + ] , H.TypeSigDecl (prefix <> "_mkServer") (H.TyLam [H.TyCon serviceConName] (H.TyCon "Pinch.Server.ThriftServer")) , H.FunBind [ H.Match (prefix <> "_mkServer") [H.PVar "server"] - ( H.ELet "functions" - (H.EApp "Data.HashMap.Strict.fromList" [ H.EList handlers ] ) - ( H.EApp "Pinch.Server.createServer" - [ (H.ELam ["nm"] - (H.EApp "Data.HashMap.Strict.lookup" - [ "nm", "functions" ] - ) + ( H.EApp "Pinch.Server.createServer" + [ (H.ELam ["nm"] + (H.EApp "Data.HashMap.Strict.lookup" + [ "nm", H.EVar $ "functions_" <> serviceConName <> " server" ] ) - ] - ) + ) + ] ) ] ] - pure (concat tyDecls, concat calls, serverDecls) + let serverImports = (\imp -> H.ImportDecl (H.ModuleName imp) True H.IEverything) <$> additionalImports + + pure (concat tyDecls, concat calls, serverDecls, serverImports) where serviceTyName = capitalize $ serviceName s serviceConName = capitalize $ serviceName s @@ -475,11 +499,11 @@ gFunction :: Function SourcePos -> GenerateM (H.Name, H.Type, H.Exp, [H.Decl], [H.Decl]) gFunction f = do - argTys <- traverse (fmap snd . gFieldType) (functionParameters f) + argTys <- traverse (fmap snd . gFieldType) (A.functionParameters f) retType <- maybe (pure tyUnit) gTypeReference (functionReturnType f) - argDataTy <- structDatatype argDataTyNm (functionParameters f) + argDataTy <- structDatatype argDataTyNm (A.functionParameters f) let catchers = map (\e -> H.EApp "Control.Exception.Handler" [ H.EInfix "Prelude.." "Prelude.pure" (H.EVar $ dtNm <> "_" <> capitalize (fieldName e)) @@ -519,10 +543,10 @@ let clientFunTy = H.TyLam argTys (H.TyApp (H.TyCon "Pinch.Client.ThriftCall") [resultDataTy]) let callSig = H.TypeSigDecl nm $ clientFunTy let call = H.FunBind - [ H.Match nm ( map (H.PVar . fieldName) $ functionParameters f) + [ H.Match nm ( map (H.PVar . fieldName) $ A.functionParameters f) ( H.EApp (if functionOneWay f then "Pinch.Client.TOneway" else "Pinch.Client.TCall") [ H.ELit $ H.LString $ functionName f - , H.EApp (H.EVar argDataTyNm) $ map (H.EVar . fieldName) (functionParameters f) + , H.EApp (H.EVar argDataTyNm) $ map (H.EVar . fieldName) (A.functionParameters f) ] ) ] @@ -542,7 +566,7 @@ where nm = decapitalize $ functionName f dtNm = capitalize (functionName f) <> "_Result" - argVars = take (length $ functionParameters f) $ map T.singleton ['a'..] + argVars = take (length $ A.functionParameters f) $ map T.singleton ['a'..] argDataTyNm = capitalize $ functionName f <> "_Args" exceptions = concat $ maybeToList $ functionExceptions f diff --git a/src/Pinch/Generate/Pretty.hs b/src/Pinch/Generate/Pretty.hs --- a/src/Pinch/Generate/Pretty.hs +++ b/src/Pinch/Generate/Pretty.hs @@ -154,8 +154,15 @@ instance Pretty ConDecl where pretty (ConDecl n args) = hsep $ [ pretty n ] ++ map pretty args - pretty (RecConDecl n args) = hsep $ [ pretty n, "{", fields, "}" ] - where fields = cList $ map (\(f, v) -> pretty f <+> "::" <+> pretty v) args + pretty (RecConDecl n fields) = pretty n + <> case fields of + [] -> "{}" + ((f, t) : xs) -> line + <> "{" <+> pretty f <+> "::" <+> pretty t + <> line + <> vsep (map (\(f', v) -> "," <+> pretty f' <+> "::" <+> pretty v) xs) + <> line + <> "}" instance Pretty InstHead where pretty (InstHead cs n ty) = "instance" <> context <+> pretty n <+> pretty ty <+> "where"