pinch-gen 0.4.4.0 → 0.4.5.0
raw patch · 3 files changed
+59/−28 lines, 3 files
Files
- pinch-gen.cabal +2/−2
- src/Pinch/Generate.hs +48/−24
- src/Pinch/Generate/Pretty.hs +9/−2
pinch-gen.cabal view
@@ -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
src/Pinch/Generate.hs view
@@ -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
src/Pinch/Generate/Pretty.hs view
@@ -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"