Add generate-file

Author: sol

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`

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 <https://github.com/sol/hpack#readme>
 category:       Development

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 <https://github.com/sol/hpack#readme>
 maintainer: Simon Hengel <[email protected]>

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

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

src/Hpack/Utf8.hs

@@ -2,18 +2,23 @@ module Hpack.Utf8 (
   encodeUtf8
 , readFile
 , writeFile
+, ensureFile
 , putStr
 , hPutStr
 , hPutStrLn
 ) where
 
 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

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

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)