diff --git a/CHANGELOG.md b/CHANGELOG.md index 0f71e774..17eca697 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +## Changes in 0.34.5 + - Add support for `generate-file` + ## Changes in 0.34.4 - Render `default-extensions` / `other-extensions` line-separated - Compatibility with `Cabal-3.4.0.0` diff --git a/hpack.cabal b/hpack.cabal index fbb84654..aeb7b5c7 100644 --- a/hpack.cabal +++ b/hpack.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: hpack -version: 0.34.4 +version: 0.35.0 synopsis: A modern format for Haskell packages description: See README at category: Development diff --git a/package.yaml b/package.yaml index 6ac03a37..bbf3334f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hpack -version: 0.34.4 +version: 0.35.0 synopsis: A modern format for Haskell packages description: See README at maintainer: Simon Hengel diff --git a/src/Hpack.hs b/src/Hpack.hs index 30d861c6..3fdcbbe5 100644 --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -192,7 +192,7 @@ hpackResult = hpackResultWithVersion version hpackResultWithVersion :: Version -> Options -> IO Result hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do - DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return + DecodeResult pkg (lines -> cabalVersion) cabalFileName files warnings <- readPackageConfig options >>= either die return mExistingCabalFile <- readCabalFile cabalFileName let newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg @@ -205,6 +205,13 @@ hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = Generated -> writeCabalFile options toStdout cabalFileName newCabalFile _ -> return () + let generateFiles = mapM_ (uncurry ensureFile) files + case status of + Generated -> generateFiles + OutputUnchanged -> generateFiles + AlreadyGeneratedByNewerHpack -> return () + ExistingCabalFileWasModifiedManually -> return () + return Result { resultWarnings = warnings , resultCabalFile = cabalFileName diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index aa42fe55..6b076812 100644 --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -292,8 +292,14 @@ data CommonOptions cSources cxxSources jsSources a = CommonOptions { , commonOptionsBuildTools :: Maybe BuildTools , commonOptionsSystemBuildTools :: Maybe SystemBuildTools , commonOptionsVerbatim :: Maybe (List Verbatim) +, commonOptionsGenerateFile :: Maybe (List GenerateFile) } deriving (Functor, Generic) +data GenerateFile = GenerateFile { + generateFileName :: FilePath +, generateFileContents :: String +} deriving (Generic, FromValue) + type ParseCommonOptions = CommonOptions ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseCommonOptions a) @@ -325,6 +331,7 @@ instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources, Monoid , commonOptionsBuildTools = Nothing , commonOptionsSystemBuildTools = Nothing , commonOptionsVerbatim = Nothing + , commonOptionsGenerateFile = Nothing } mappend = (<>) @@ -356,6 +363,7 @@ instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources) => Semi , commonOptionsBuildTools = commonOptionsBuildTools a <> commonOptionsBuildTools b , commonOptionsSystemBuildTools = commonOptionsSystemBuildTools b <> commonOptionsSystemBuildTools a , commonOptionsVerbatim = commonOptionsVerbatim a <> commonOptionsVerbatim b + , commonOptionsGenerateFile = commonOptionsGenerateFile a <> commonOptionsGenerateFile b } type ParseCSources = Maybe (List FilePath) @@ -644,6 +652,7 @@ data DecodeResult = DecodeResult { decodeResultPackage :: Package , decodeResultCabalVersion :: String , decodeResultCabalFile :: FilePath +, decodeResultGenerateFiles :: [(FilePath, String)] , decodeResultWarnings :: [String] } deriving (Eq, Show) @@ -656,8 +665,16 @@ readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = runE userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir toPackage programName userDataDir dir config where - addCabalFile :: ((Package, String), [String]) -> DecodeResult - addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file (packageName pkg ++ ".cabal")) warnings + addCabalFile :: ((Package, String, [GenerateFile]), [String]) -> DecodeResult + addCabalFile ((pkg, cabalVersion, generateFiles), warnings) = DecodeResult { + decodeResultPackage = pkg + , decodeResultCabalVersion = cabalVersion + , decodeResultCabalFile = addPackageDir (packageName pkg ++ ".cabal") + , decodeResultGenerateFiles = map (first addPackageDir . (generateFileName &&& generateFileContents)) $ nubOn generateFileName $ reverse generateFiles + , decodeResultWarnings = warnings + } + + addPackageDir = (takeDirectory_ file ) takeDirectory_ :: FilePath -> FilePath takeDirectory_ p @@ -997,11 +1014,14 @@ type ConfigWithDefaults = Product type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseCxxSources ParseJsSources a) type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) -toPackage :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) +toPackage :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String, [GenerateFile]) toPackage programName userDataDir dir = expandDefaultsInConfig programName userDataDir dir >=> traverseConfig (expandForeignSources dir) - >=> toPackage_ dir + >=> runGenerateFilesWithWarnings . toPackage_ dir + +runGenerateFilesWithWarnings :: Functor m => GenerateFilesWithWarnings m (a, b) -> Warnings m (a, b, [GenerateFile]) +runGenerateFilesWithWarnings = mapWriterT (fmap $ \ ((a, b), c) -> ((a, b, lefts c), rights c)) expandDefaultsInConfig :: ProgramName @@ -1090,19 +1110,19 @@ toExecutableMap name executables mExecutable = do type GlobalOptions = CommonOptions CSources CxxSources JsSources Empty -toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources CxxSources JsSources) -> Warnings m (Package, String) +toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources CxxSources JsSources) -> GenerateFilesWithWarnings m (Package, String) toPackage_ dir (Product g PackageConfig{..}) = do - executableMap <- toExecutableMap packageName_ packageConfigExecutables packageConfigExecutable + executableMap <- liftWarnings $ toExecutableMap packageName_ packageConfigExecutables packageConfigExecutable let globalVerbatim = commonOptionsVerbatim g globalOptions = g {commonOptionsVerbatim = Nothing} executableNames = maybe [] Map.keys executableMap - toSect :: (Monad m, Monoid a) => WithCommonOptions CSources CxxSources JsSources a -> Warnings m (Section a) + toSect :: (Monad m, Monoid a) => WithCommonOptions CSources CxxSources JsSources a -> GenerateFilesWithWarnings m (Section a) toSect = toSection packageName_ executableNames . first ((mempty <$ globalOptions) <>) - toSections :: (Monad m, Monoid a) => Maybe (Map String (WithCommonOptions CSources CxxSources JsSources a)) -> Warnings m (Map String (Section a)) + toSections :: (Monad m, Monoid a) => Maybe (Map String (WithCommonOptions CSources CxxSources JsSources a)) -> GenerateFilesWithWarnings m (Map String (Section a)) toSections = maybe (return mempty) (traverse toSect) toLib = liftIO . toLibrary dir packageName_ @@ -1125,12 +1145,12 @@ toPackage_ dir (Product g PackageConfig{..}) = do ++ concatMap sectionSourceDirs benchmarks ) - extraSourceFiles <- expandGlobs "extra-source-files" dir (fromMaybeList packageConfigExtraSourceFiles) - extraDocFiles <- expandGlobs "extra-doc-files" dir (fromMaybeList packageConfigExtraDocFiles) + extraSourceFiles <- liftWarnings $ expandGlobs "extra-source-files" dir (fromMaybeList packageConfigExtraSourceFiles) + extraDocFiles <- liftWarnings $ expandGlobs "extra-doc-files" dir (fromMaybeList packageConfigExtraDocFiles) let dataBaseDir = maybe dir (dir ) packageConfigDataDir - dataFiles <- expandGlobs "data-files" dataBaseDir (fromMaybeList packageConfigDataFiles) + dataFiles <- liftWarnings $ expandGlobs "data-files" dataBaseDir (fromMaybeList packageConfigDataFiles) let licenseFiles :: [String] @@ -1143,7 +1163,7 @@ toPackage_ dir (Product g PackageConfig{..}) = do input <- liftIO (tryReadFile (dir file)) case input >>= inferLicense of Nothing -> do - tell ["Inferring license from file " ++ file ++ " failed!"] + liftWarnings $ tell ["Inferring license from file " ++ file ++ " failed!"] return Nothing license -> return license _ -> return Nothing @@ -1182,8 +1202,8 @@ toPackage_ dir (Product g PackageConfig{..}) = do , packageVerbatim = fromMaybeList globalVerbatim } - tell nameWarnings - tell (formatMissingSourceDirs missingSourceDirs) + liftWarnings $ tell nameWarnings + liftWarnings $ tell (formatMissingSourceDirs missingSourceDirs) return (determineCabalVersion inferredLicense pkg) where nameWarnings :: [String] @@ -1394,13 +1414,20 @@ expandMain = flatten . expand , sectionConditionals = map (fmap flatten) sectionConditionals } -toSection :: Monad m => String -> [String] -> WithCommonOptions CSources CxxSources JsSources a -> Warnings m (Section a) +type GenerateFilesWithWarnings = WriterT [Either GenerateFile String] + +liftWarnings :: Functor m => Warnings m a -> GenerateFilesWithWarnings m a +liftWarnings = mapWriterT (fmap (fmap $ map Right)) + +toSection :: Monad m => String -> [String] -> WithCommonOptions CSources CxxSources JsSources a -> GenerateFilesWithWarnings m (Section a) toSection packageName_ executableNames = go where + go :: Monad m => WithCommonOptions CSources CxxSources JsSources a -> GenerateFilesWithWarnings m (Section a) go (Product CommonOptions{..} a) = do (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools commonOptionsBuildTools conditionals <- mapM toConditional (fromMaybeList commonOptionsWhen) + tell (map Left $ fromMaybeList commonOptionsGenerateFile) return Section { sectionData = a , sectionSourceDirs = nub $ fromMaybeList commonOptionsSourceDirs @@ -1430,15 +1457,15 @@ toSection packageName_ executableNames = go , sectionSystemBuildTools = systemBuildTools <> fromMaybe mempty commonOptionsSystemBuildTools , sectionVerbatim = fromMaybeList commonOptionsVerbatim } - toBuildTools :: Monad m => BuildTools -> Warnings m (SystemBuildTools, Map BuildTool DependencyVersion) - toBuildTools = fmap (mkSystemBuildTools &&& mkBuildTools) . mapM (toBuildTool packageName_ executableNames). unBuildTools + toBuildTools :: Monad m => BuildTools -> GenerateFilesWithWarnings m (SystemBuildTools, Map BuildTool DependencyVersion) + toBuildTools = fmap (mkSystemBuildTools &&& mkBuildTools) . mapM (liftWarnings . toBuildTool packageName_ executableNames). unBuildTools where mkSystemBuildTools :: [Either (String, VersionConstraint) b] -> SystemBuildTools mkSystemBuildTools = SystemBuildTools . Map.fromList . lefts mkBuildTools = Map.fromList . rights - toConditional :: Monad m => ConditionalSection CSources CxxSources JsSources a -> Warnings m (Conditional (Section a)) + toConditional :: Monad m => ConditionalSection CSources CxxSources JsSources a -> GenerateFilesWithWarnings m (Conditional (Section a)) toConditional x = case x of ThenElseConditional (Product (ThenElse then_ else_) c) -> conditional c <$> (go then_) <*> (Just <$> go else_) FlatConditional (Product sect c) -> conditional c <$> (go sect) <*> pure Nothing diff --git a/src/Hpack/Utf8.hs b/src/Hpack/Utf8.hs index 0ac650ff..ea4bdf38 100644 --- a/src/Hpack/Utf8.hs +++ b/src/Hpack/Utf8.hs @@ -2,6 +2,7 @@ module Hpack.Utf8 ( encodeUtf8 , readFile , writeFile +, ensureFile , putStr , hPutStr , hPutStrLn @@ -9,11 +10,15 @@ module Hpack.Utf8 ( import Prelude hiding (readFile, writeFile, putStr) +import Imports + import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Text.Encoding.Error (lenientDecode) import qualified Data.ByteString as B import System.IO (Handle, stdout, IOMode(..), withFile, Newline(..), nativeNewline) +import System.Directory +import System.FilePath encodeUtf8 :: String -> B.ByteString encodeUtf8 = Encoding.encodeUtf8 . T.pack @@ -59,3 +64,13 @@ hPutStrLn h xs = hPutStr h xs >> hPutStr h "\n" hPutStr :: Handle -> String -> IO () hPutStr h = B.hPutStr h . encodeText + +ensureFile :: FilePath -> String -> IO () +ensureFile name new = do + exists <- doesFileExist name + if exists then do + old <- readFile name + unless (old == new) $ writeFile name new + else do + createDirectoryIfMissing True (takeDirectory name) + writeFile name new diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs index 6ebabd59..24073a29 100644 --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -160,6 +160,28 @@ spec = around_ (inTempDirectoryNamed "foo") $ do data/foo/index.html |] + describe "generate-file" $ do + it "generates files" $ do + [i| + generate-file: + name: Setup.hs + contents: | + import Distribution.Simple + main = defaultMain + library: {} + |] `shouldGenerateFiles` [("Setup.hs", "import Distribution.Simple\nmain = defaultMain\n")] + + it "gives later occurrences precedence" $ do + [i| + generate-file: + name: foo + contents: bar + library: + generate-file: + name: foo + contents: baz + |] `shouldGenerateFiles` [("foo", "baz")] + describe "data-dir" $ do it "accepts data-dir" $ do touch "data/foo.html" @@ -1672,21 +1694,21 @@ spec = around_ (inTempDirectoryNamed "foo") $ do author: John Doe |] -run :: HasCallStack => FilePath -> FilePath -> String -> IO ([String], String) +run :: HasCallStack => FilePath -> FilePath -> String -> IO ([String], String, [(FilePath, String)]) run userDataDir c old = run_ userDataDir c old >>= either assertFailure return -run_ :: FilePath -> FilePath -> String -> IO (Either String ([String], String)) +run_ :: FilePath -> FilePath -> String -> IO (Either String ([String], String, [(FilePath, String)])) run_ userDataDir c old = do mPackage <- readPackageConfig defaultDecodeOptions {decodeOptionsTarget = c, decodeOptionsUserDataDir = Just userDataDir} return $ case mPackage of - Right (DecodeResult pkg cabalVersion _ warnings) -> + Right (DecodeResult pkg cabalVersion _ generateFiles warnings) -> let FormattingHints{..} = sniffFormattingHints (lines old) alignment = fromMaybe 0 formattingHintsAlignment settings = formattingHintsRenderSettings output = cabalVersion ++ Hpack.renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg in - Right (warnings, output) + Right (warnings, output, generateFiles) Left err -> Left err data RenderResult = RenderResult [String] String @@ -1701,16 +1723,22 @@ shouldRenderTo input p = do let currentDirectory = ".working-directory" createDirectory currentDirectory withCurrentDirectory currentDirectory $ do - (warnings, output) <- run ".." (".." packageConfig) expected + (warnings, output, _) <- run ".." (".." packageConfig) expected RenderResult warnings (dropEmptyLines output) `shouldBe` RenderResult (packageWarnings p) expected where expected = dropEmptyLines (renderPackage p) dropEmptyLines = unlines . filter (not . null) . lines +shouldGenerateFiles :: HasCallStack => String -> [(FilePath, String)] -> Expectation +shouldGenerateFiles input files = do + writeFile packageConfig input + (_, _, generateFiles) <- run "" packageConfig "" + generateFiles `shouldBe` files + shouldWarn :: HasCallStack => String -> [String] -> Expectation shouldWarn input expected = do writeFile packageConfig input - (warnings, _) <- run "" packageConfig "" + (warnings, _, _) <- run "" packageConfig "" sort warnings `shouldBe` sort expected shouldFailWith :: HasCallStack => String -> String -> Expectation diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs index 7179549e..8057b738 100644 --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -65,7 +65,7 @@ withPackage content beforeAction expectation = withTempDirectory $ \dir_ -> do writeFile (dir "package.yaml") content withCurrentDirectory dir beforeAction r <- readPackageConfig (testDecodeOptions $ dir "package.yaml") - either expectationFailure (\ (DecodeResult p _ _ warnings) -> expectation (p, warnings)) r + either expectationFailure (\ (DecodeResult p _ _ _ warnings) -> expectation (p, warnings)) r withPackageConfig :: String -> IO () -> (Package -> Expectation) -> Expectation withPackageConfig content beforeAction expectation = withPackage content beforeAction (expectation . fst) diff --git a/test/Hpack/Utf8Spec.hs b/test/Hpack/Utf8Spec.hs index 187e8ab7..113a3131 100644 --- a/test/Hpack/Utf8Spec.hs +++ b/test/Hpack/Utf8Spec.hs @@ -4,29 +4,44 @@ module Hpack.Utf8Spec (spec) where import Helper import qualified Data.ByteString as B +import System.Directory import qualified Hpack.Utf8 as Utf8 spec :: Spec -spec = do +spec = around_ inTempDirectory $ do describe "readFile" $ do context "with a file that uses CRLF newlines" $ do it "applies newline conversion" $ do - inTempDirectory $ do - let - name = "foo.txt" - B.writeFile name "foo\r\nbar" - Utf8.readFile name `shouldReturn` "foo\nbar" + let + name = "foo.txt" + B.writeFile name "foo\r\nbar" + Utf8.readFile name `shouldReturn` "foo\nbar" describe "writeFile" $ do it "uses system specific newline encoding" $ do - inTempDirectory $ do - let - name = "foo.txt" - c = "foo\nbar" + let + name = "foo.txt" + c = "foo\nbar" + + writeFile name c + systemSpecific <- B.readFile name + + Utf8.writeFile name c + B.readFile name `shouldReturn` systemSpecific + + describe "ensureFile" $ do + it "creates a file" $ do + Utf8.ensureFile "foo" "bar" + readFile "foo" `shouldReturn` "bar" - writeFile name c - systemSpecific <- B.readFile name + it "does not unnecessarily touch a file" $ do + Utf8.ensureFile "foo" "bar" + let t = read "2020-02-28 23:23:23 UTC" + setModificationTime "foo" t + Utf8.ensureFile "foo" "bar" + getModificationTime "foo" `shouldReturn` t - Utf8.writeFile name c - B.readFile name `shouldReturn` systemSpecific + it "creates directories as needed" $ do + Utf8.ensureFile "foo/bar/baz" "23" + readFile "foo/bar/baz" `shouldReturn` "23"