diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) ================== 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.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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Pinch/Generate.hs b/src/Pinch/Generate.hs --- a/src/Pinch/Generate.hs +++ b/src/Pinch/Generate.hs @@ -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" 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 @@ -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))