pinch-gen 0.4.2.0 → 0.4.3.0
raw patch · 5 files changed
+87/−60 lines, 5 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +6/−0
- pinch-gen.cabal +3/−2
- src/Main.hs +7/−3
- src/Pinch/Generate.hs +60/−46
- src/Pinch/Generate/Pretty.hs +11/−9
CHANGELOG.md view
@@ -1,3 +1,9 @@+0.4.3 (2021-11-14)+==================++* Fix GHC 9.2 compatibility (thanks to @brandon-leapyear)+* Allow arbitrary module prefixes (#5, thanks to @brandon-leapyear)+ 0.4.2 (2021-05-31) ==================
pinch-gen.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.10 name: pinch-gen-version: 0.4.2.0+version: 0.4.3.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.16+ build-depends: base >=4.12 && < 4.17 , bytestring , directory , filepath@@ -32,6 +32,7 @@ , text , unordered-containers default-language: Haskell2010+ ghc-options: -Wall source-repository head type: git
src/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where @@ -5,9 +7,6 @@ import Pinch.Generate -import Data.Text as T-import System.FilePath- data Options = Options { inputFile :: FilePath , outputDir :: FilePath@@ -27,6 +26,11 @@ <$> strOption (long "hashable-vec-mod" <> help "Module containing hashable instances for vector") <*> flag True False (long "no-generate-arbitrary") <*> many (strOption (long "extra-import" <> metavar "IMPORT"))+ <*> strOption+ ( long "module-prefix"+ <> help "Prefix of module name for generated files, e.g. 'Gen.Agent.'"+ <> value ""+ ) main :: IO () main = do
src/Pinch/Generate.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Pinch.Generate where@@ -12,12 +13,19 @@ import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Text+import Prettyprinter+import Prettyprinter.Render.Text import Data.Void-import Language.Thrift.AST as A+import Language.Thrift.AST as A hiding ( exceptions+ , fields+ , headers+ , name+ , path+ , value+ ) import Language.Thrift.Parser import qualified Pinch.Generate.Pretty as H+import Prelude hiding (mod) import System.Directory import System.FilePath import System.IO@@ -31,6 +39,7 @@ { sHashableVectorInstanceModule :: T.Text , sGenerateArbitrary :: Bool , sExtraImports :: [T.Text]+ , sModulePrefix :: T.Text } deriving (Show) generate :: Settings -> FilePath -> FilePath -> IO ()@@ -53,19 +62,22 @@ (H.ModuleName n) = H.modName m parts = map T.unpack $ T.splitOn "." n -extractModuleName :: FilePath -> T.Text-extractModuleName f = mconcat $ map capitalize parts+getModuleName :: Settings -> [Header SourcePos] -> FilePath -> T.Text+getModuleName settings headers path =+ T.concat+ [ sModulePrefix settings+ , extractNamespace headers+ , extractName path+ ] where- fileName = dropExtension $ takeFileName f- parts = T.splitOn "_" $ T.pack fileName--extractNamespace :: [Header SourcePos] -> Maybe T.Text-extractNamespace headers =- listToMaybe $ mapMaybe (\x -> case x of- HeaderNamespace (Namespace l n _) | l == "hs" || l == "*" -> Just (n <> ".")- _ -> Nothing- ) headers+ extractNamespace = fromMaybe "" . listToMaybe . mapMaybe getNamespaceHeader+ getNamespaceHeader = \case+ HeaderNamespace (Namespace l n _)+ | l == "hs" || l == "*"+ -> Just (n <> ".")+ _ -> Nothing + extractName = T.concat . map capitalize . T.splitOn "_" . T.pack . takeBaseName loadFile :: FilePath -> IO (Program SourcePos) loadFile inp = do@@ -83,13 +95,13 @@ gProgram :: Settings -> FilePath -> Program SourcePos -> IO [H.Module] gProgram s inp (Program headers defs) = do- (imports, tyMaps) <- unzip <$> traverse (gInclude baseDir) incHeaders+ (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 mkMod suffix = H.Module (H.ModuleName $ modBaseName <> suffix) [ H.PragmaLanguage "TypeFamilies, DeriveGeneric, TypeApplications, OverloadedStrings"- , H.PragmaOptsGhc "-fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches" ]+ , H.PragmaOptsGhc "-w" ] pure $ [ -- types mkMod ".Types"@@ -113,8 +125,7 @@ ] where- ns = fromMaybe "" $ extractNamespace headers- modBaseName = ns <> extractModuleName inp+ modBaseName = getModuleName s headers inp baseDir = dropFileName inp incHeaders = mapMaybe (\x -> case x of HeaderInclude i -> Just i@@ -149,11 +160,11 @@ type GenerateM = Reader Context -gInclude :: FilePath -> Include SourcePos -> IO (H.ImportDecl, ModuleMap)-gInclude dir i = do+gInclude :: Settings -> FilePath -> Include SourcePos -> IO (H.ImportDecl, ModuleMap)+gInclude s dir i = do -- TODO handle recursive includes ... (Program headers _) <- loadFile (dir </> (T.unpack $ includePath i))- let modName = H.ModuleName $ fromMaybe "" (extractNamespace headers) <> extractModuleName (T.unpack $ includePath i) <> ".Types"+ let modName = H.ModuleName $ getModuleName s headers (T.unpack $ includePath i) <> ".Types" let thriftModName = T.pack $ dropExtension $ T.unpack $ includePath i pure (H.ImportDecl modName True H.IEverything, Map.singleton thriftModName modName) @@ -164,31 +175,31 @@ ServiceDefinition s -> gService s gConst :: A.Const SourcePos -> GenerateM [H.Decl]-gConst const = do- tyRef <- gTypeReference (constValueType const)- value <- gConstValue (constValue const)+gConst constPos = do+ tyRef <- gTypeReference (constValueType constPos)+ value <- gConstValue (constValue constPos) pure [ H.TypeSigDecl name tyRef , H.FunBind [H.Match name [] value] ] where- name = decapitalize (constName const)+ name = decapitalize (constName constPos) gConstValue :: A.ConstValue SourcePos -> GenerateM H.Exp gConstValue val = case val of ConstInt n _ -> pure (H.ELit (H.LInt n)) ConstFloat n _ -> pure (H.ELit (H.LFloat n)) ConstLiteral s _ -> pure (H.ELit (H.LString s))- ConstIdentifier id _- | xs @(_:_:_) <- T.splitOn "." id -> do- map <- asks cModuleMap- case Map.lookup (mconcat $ init xs) map of+ ConstIdentifier ident _+ | xs @(_:_:_) <- T.splitOn "." ident -> do+ moduleMap <- asks cModuleMap+ case Map.lookup (mconcat $ init xs) moduleMap of Nothing -> -- TODO this should probably be an error- pure (H.EVar (decapitalize id))+ pure (H.EVar (decapitalize ident)) Just (H.ModuleName n) -> pure $ H.EVar (n <> "." <> decapitalize (last xs))- | otherwise -> pure $ H.EVar (decapitalize id)+ | otherwise -> pure $ H.EVar (decapitalize ident) ConstList xs _ -> do elems <- traverse gConstValue xs pure (H.EApp "Data.Vector.fromList" [H.EList elems])@@ -211,6 +222,7 @@ gTypeReference :: TypeReference SourcePos -> GenerateM H.Type gTypeReference ref = case ref of StringType _ _ -> tyCon "Data.Text.Text"+ SListType _ _ -> tyCon "Data.Text.Text" -- http://thrift.apache.org/docs/idl#senum BinaryType _ _ -> tyCon "Data.ByteString.ByteString" BoolType _ _ -> tyCon "Prelude.Bool" DoubleType _ _ -> tyCon "Prelude.Double"@@ -222,9 +234,9 @@ MapType kTy vTy _ _ -> H.TyApp (H.TyCon $ "Data.HashMap.Strict.HashMap") <$> traverse gTypeReference [kTy, vTy] SetType ty _ _ -> H.TyApp (H.TyCon $ "Data.HashSet.HashSet") <$> traverse gTypeReference [ty] DefinedType ty _ -> case T.splitOn "." ty of- xs@(x1:x2:_) -> do- map <- asks cModuleMap- case Map.lookup (mconcat $ init xs) map of+ xs@(_:_:_) -> do+ moduleMap <- asks cModuleMap+ case Map.lookup (mconcat $ init xs) moduleMap of Nothing -> tyCon $ capitalize ty Just (H.ModuleName n) -> pure $ H.TyCon $ n <> "." <> capitalize (last xs) _ -> tyCon $ capitalize ty@@ -253,8 +265,6 @@ ] else []) where tyName = enumName e- unpinch = H.Match "unpinch" [H.PVar "x"]- (H.EApp "Prelude.fmap" [ "Prelude.toEnum Prelude.. Prelude.fromIntegral", H.EApp "Pinch.unpinch" [ "x" ]]) (cons, fromEnum', toEnum', pinch', unpinchAlts') = unzip5 $ map gEnumDef $ zip [0..] $ enumValues e defAlt = H.Alt (H.PVar "_")@@ -308,7 +318,7 @@ let stag = H.TypeDecl (H.TyApp tag [ H.TyCon nm ]) (H.TyCon $ "Pinch.TStruct") let pinch = H.FunBind [ H.Match "pinch" [H.PCon nm $ map H.PVar nms]- ( H.EApp "Pinch.struct" [ H.EList $ flip map fields $ \(fId, fNm, fTy, fReq) ->+ ( H.EApp "Pinch.struct" [ H.EList $ flip map fields $ \(fId, fNm, _, fReq) -> let op = if fReq then "Pinch..=" else "Pinch.?=" in H.EInfix op (H.ELit $ H.LInt fId) (H.EVar fNm)@@ -317,7 +327,7 @@ let unpinch = H.FunBind [ H.Match "unpinch" [H.PVar "value"] $ foldl'- (\acc (fId, fNm, fTy, fReq) ->+ (\acc (fId, _, _, fReq) -> H.EInfix "Prelude.<*>" acc ( H.EInfix (if fReq then "Pinch..:" else "Pinch..:?") "value"@@ -386,7 +396,7 @@ ) fields ]- let cons = map (\(_, nm, ty, _) -> H.ConDecl nm [ ty ]) fields ++ case defCon of+ let cons = map (\(_, nm', ty, _) -> H.ConDecl nm' [ ty ]) fields ++ case defCon of SRCNone -> [] SRCVoid c -> [H.ConDecl (nm <> c) []] let arbitrary = H.FunBind@@ -394,8 +404,8 @@ H.EApp "Test.QuickCheck.oneof" [ H.EList $ map- (\(_, nm, _, _) ->- H.EInfix "Prelude.<$>" (H.EVar nm) "Test.QuickCheck.arbitrary"+ (\(_, nm', _, _) ->+ H.EInfix "Prelude.<$>" (H.EVar nm') "Test.QuickCheck.arbitrary" ) fields ]@@ -464,8 +474,8 @@ ] ) exceptions let resultField = fmap (\ty -> Field (Just 0) (Just Optional) ty "success" Nothing [] Nothing (Pos.initialPos "")) (functionReturnType f)- (resultDecls, resultDataTy, resultDataCon) <- case (functionReturnType f, exceptions) of- (Nothing, []) -> pure ([], H.TyCon "Pinch.Internal.RPC.Unit", "Pinch.Internal.RPC.Unit")+ (resultDecls, resultDataTy) <- case (functionReturnType f, exceptions) of+ (Nothing, []) -> pure ([], H.TyCon $ if functionOneWay f then "()" else "Pinch.Internal.RPC.Unit") _ -> do let thriftResultInst = H.InstDecl (H.InstHead [] "Pinch.Internal.RPC.ThriftResult" (H.TyCon dtNm)) [ H.TypeDecl (H.TyApp (H.TyCon "ResultType") [ H.TyCon dtNm ]) retType@@ -490,7 +500,7 @@ Nothing -> SRCVoid "_Success" _ -> SRCNone )- pure ((thriftResultInst : dt), H.TyCon dtNm, H.EVar $ dtNm <> "_Success")+ pure ((thriftResultInst : dt), H.TyCon dtNm) let srvFunTy = H.TyLam ([H.TyCon "Pinch.Server.Context"] ++ argTys) (H.TyApp tyIO [retType])@@ -524,11 +534,14 @@ argDataTyNm = capitalize $ functionName f <> "_Args" exceptions = concat $ maybeToList $ functionExceptions f +tag, tyUnit, tyIO :: H.Type tag = H.TyCon $ "Tag"-clPinchable = "Pinch.Pinchable"-clHashable = "Data.Hashable.Hashable" tyUnit = H.TyCon $ "()" tyIO = H.TyCon $ "Prelude.IO"++clPinchable, clHashable, clException, clArbitrary :: H.ClassName+clPinchable = "Pinch.Pinchable"+clHashable = "Data.Hashable.Hashable" clException = "Control.Exception.Exception" clArbitrary = "Test.QuickCheck.Arbitrary" @@ -538,6 +551,7 @@ capitalize :: T.Text -> T.Text capitalize s = if T.null s then "" else T.singleton (toUpper $ T.head s) <> T.tail s +derivingShow, derivingEq, derivingOrd, derivingGenerics, derivingBounded :: H.Deriving derivingShow = H.DeriveClass $ H.TyCon $ "Prelude.Show" derivingEq = H.DeriveClass $ H.TyCon $ "Prelude.Eq" derivingOrd = H.DeriveClass $ H.TyCon $ "Prelude.Ord"
src/Pinch/Generate/Pretty.hs view
@@ -5,7 +5,8 @@ import Data.String import qualified Data.Text as T-import Data.Text.Prettyprint.Doc+import Prelude hiding (mod)+import Prettyprinter newtype ModuleName = ModuleName T.Text deriving (Show)@@ -120,7 +121,7 @@ instance Pretty Pragma where pretty p = case p of- PragmaLanguage p -> "{-# LANGUAGE" <+> pretty p <+> "#-}"+ PragmaLanguage p' -> "{-# LANGUAGE" <+> pretty p' <+> "#-}" PragmaOptsGhc o -> "{-# OPTIONS_GHC" <+> pretty o <+> "#-}" instance Pretty ImportDecl where@@ -138,7 +139,7 @@ DataDecl t (c:cs) ds -> nest 2 (vsep $ [ "data" <+> pretty t , "=" <+> pretty c- ] ++ (map (\c -> "|" <+> pretty c) cs) ++ [ prettyDerivings ds ]+ ] ++ (map (\c' -> "|" <+> pretty c') cs) ++ [ prettyDerivings ds ] ) <> line InstDecl h decls -> (nest 2 $ vsep $ [ pretty h ] ++ map pretty decls) <> line FunBind ms -> vsep (map pretty ms) <> line@@ -154,7 +155,7 @@ 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 (\(n, v) -> pretty n <+> "::" <+> pretty v) args+ where fields = cList $ map (\(f, v) -> pretty f <+> "::" <+> pretty v) args instance Pretty InstHead where pretty (InstHead cs n ty) = "instance" <> context <+> pretty n <+> pretty ty <+> "where"@@ -182,17 +183,17 @@ instance Pretty Exp where pretty e = case e of EVar n -> pretty n- EApp e es -> pretty e <+> hsep (map (parens . pretty) es)+ EApp e' es -> pretty e' <+> hsep (map (parens . pretty) es) ELit l -> pretty l- ETyAnn e ty -> parens $ pretty e <+> "::" <+> pretty ty- ECase e as -> nest 2 $ vsep $ ["case" <+> pretty e <+> "of"] ++ map pretty as+ ETyAnn e' ty -> parens $ pretty e' <+> "::" <+> pretty ty+ ECase e' as -> nest 2 $ vsep $ ["case" <+> pretty e' <+> "of"] ++ map pretty as EDo s -> nest 2 $ vsep $ ["do"] ++ map pretty s EInfix op e1 e2 -> parens $ hsep [ pretty e1, pretty op, pretty e2] EList es -> "[" <+> cList (map pretty es) <+> "]"- ELam ps e -> parens $ "\\" <> hsep (map pretty ps) <+> "->" <+> pretty e+ ELam ps e' -> parens $ "\\" <> hsep (map pretty ps) <+> "->" <+> pretty e' ETuple es -> nest 2 $ tupled $ map pretty es ELet nm e1 e2 -> "let" <+> pretty nm <+> "=" <+> indent 2 (pretty e1) <+> "in" <+> pretty e2- ETyApp e tys -> pretty e <+> hsep (map (("@"<>) . parens . pretty) tys)+ ETyApp e' tys -> pretty e' <+> hsep (map (("@"<>) . parens . pretty) tys) instance Pretty Alt where pretty (Alt p e) = pretty p <+> "->" <+> pretty e@@ -208,6 +209,7 @@ LFloat f -> pretty f LString t -> "\"" <> pretty t <> "\"" +cList :: [Doc ann] -> Doc ann cList = concatWith (surround (comma <> space))