Commit 65e22158 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Update cabal sdist to follow the changes in the Cabal lib

parent c1f455f1
......@@ -5,20 +5,21 @@ module Distribution.Client.SrcDist (
sdist
) where
import Distribution.Simple.SrcDist
( printPackageProblems, prepareTree
, prepareSnapshotTree, snapshotPackage )
( printPackageProblems, prepareTree, snapshotPackage )
import Distribution.Client.Tar (createTarGzFile)
import Distribution.Package
( Package(..) )
( Package(..), packageVersion )
import Distribution.PackageDescription
( PackageDescription )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.Simple.Utils
( defaultPackageDesc, warn, notice, setupMessage
, createDirectoryIfMissingVerbose, withTempDirectory )
import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
, createDirectoryIfMissingVerbose, withTempDirectory
, withUTF8FileContents, writeUTF8File )
import Distribution.Simple.Setup
( SDistFlags(..), fromFlag, flagToMaybe )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.BuildPaths ( srcPref)
......@@ -26,11 +27,15 @@ import Distribution.Simple.Configure(maybeGetPersistBuildConfig)
import Distribution.PackageDescription.Configuration ( flattenPackageDescription )
import Distribution.Text
( display )
import Distribution.Version
( Version )
import System.Time (getClockTime, toCalendarTime)
import System.FilePath ((</>), (<.>))
import Control.Monad (when)
import Data.Maybe (isNothing)
import Data.Char (toLower)
import Data.List (isPrefixOf)
-- |Create a source distribution.
sdist :: SDistFlags -> IO ()
......@@ -39,7 +44,6 @@ sdist flags = do
=<< readPackageDescription verbosity
=<< defaultPackageDesc verbosity
mb_lbi <- maybeGetPersistBuildConfig distPref
let tmpTargetDir = srcPref distPref
-- do some QA
printPackageProblems verbosity pkg
......@@ -47,25 +51,59 @@ sdist flags = do
when (isNothing mb_lbi) $
warn verbosity "Cannot run preprocessors. Run 'configure' command first."
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
date <- toCalendarTime =<< getClockTime
let pkg' | snapshot = snapshotPackage date pkg
| otherwise = pkg
date <- toCalendarTime =<< getClockTime
let pkg' | snapshot = snapshotPackage date pkg
| otherwise = pkg
setupMessage verbosity "Building source dist for" (packageId pkg')
case flagToMaybe (sDistDirectory flags) of
Just targetDir -> do
generateSourceDir targetDir pkg' mb_lbi
notice verbosity $ "Source directory created: " ++ targetDir
_ <- if snapshot
then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps
else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps
targzFile <- createArchive verbosity pkg' tmpDir distPref
notice verbosity $ "Source tarball created: " ++ targzFile
Nothing -> do
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg' mb_lbi
targzFile <- createArchive verbosity pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
where
generateSourceDir targetDir pkg' mb_lbi = do
setupMessage verbosity "Building source dist for" (packageId pkg')
prepareTree verbosity pkg' mb_lbi distPref targetDir pps
when snapshot $
overwriteSnapshotPackageDesc verbosity pkg' targetDir
verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags)
distPref = fromFlag (sDistDistPref flags)
pps = knownSuffixHandlers
distPref = fromFlag $ sDistDistPref flags
targetPref = distPref
tmpTargetDir = srcPref distPref
tarBallName :: PackageDescription -> String
tarBallName = display . packageId
overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity
-> PackageDescription -- ^info from the cabal file
-> FilePath -- ^source tree
-> IO ()
overwriteSnapshotPackageDesc verbosity pkg targetDir = do
-- We could just writePackageDescription targetDescFile pkg_descr,
-- but that would lose comments and formatting.
descFile <- defaultPackageDesc verbosity
withUTF8FileContents descFile $
writeUTF8File (targetDir </> descFile)
. unlines . map (replaceVersion (packageVersion pkg)) . lines
where
replaceVersion :: Version -> String -> String
replaceVersion version line
| "version:" `isPrefixOf` map toLower line
= "version: " ++ display version
| otherwise = line
-- |Create an archive from a tree of source files, and clean up the tree.
createArchive :: Verbosity
......@@ -74,7 +112,7 @@ createArchive :: Verbosity
-> FilePath
-> IO FilePath
createArchive _verbosity pkg tmpDir targetPref = do
let tarBallName = display (packageId pkg)
tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"
createTarGzFile tarBallFilePath tmpDir tarBallName
return tarBallFilePath
createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)
return tarBallFilePath
where
tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment