module Distribution.Simple.SrcDist (
sdist,
printPackageProblems,
prepareTree,
createArchive,
prepareSnapshotTree,
snapshotPackage,
snapshotVersion,
dateToSnapshotNumber,
listPackageSources,
listPackageSourcesWithDie,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.PackageDescription
import Distribution.PackageDescription.Check hiding (doesFileExist)
import Distribution.Package
import Distribution.ModuleName
import qualified Distribution.ModuleName as ModuleName
import Distribution.Version
import Distribution.Simple.Configure (findDistPrefOrDefault)
import Distribution.Simple.Glob
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import Distribution.Simple.PreProcess
import Distribution.Simple.BuildPaths
import Distribution.Simple.Program
import Distribution.Pretty
import Distribution.Verbosity
import qualified Data.Map as Map
import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
import System.Directory ( doesFileExist )
import System.IO (IOMode(WriteMode), hPutStrLn, withFile)
import System.FilePath ((</>), (<.>), dropExtension, isRelative)
sdist :: PackageDescription
-> SDistFlags
-> (FilePath -> FilePath)
-> [PPSuffixHandler]
-> IO ()
sdist pkg flags mkTmpDir pps = do
distPref <- findDistPrefOrDefault $ sDistDistPref flags
let targetPref = distPref
tmpTargetDir = mkTmpDir distPref
case sDistListSources flags of
Flag path -> withFile path WriteMode $ \outHandle -> do
ordinary <- listPackageSources verbosity "." pkg pps
traverse_ (hPutStrLn outHandle) ordinary
notice verbosity $ "List of package sources written to file '" ++ path ++ "'"
NoFlag -> do
printPackageProblems verbosity pkg
date <- getCurrentTime
let pkg' | snapshot = snapshotPackage date pkg
| otherwise = pkg
case flagToMaybe (sDistDirectory flags) of
Just targetDir -> do
generateSourceDir targetDir pkg'
info verbosity $ "Source directory created: " ++ targetDir
Nothing -> do
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg'
targzFile <- createArchive verbosity pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
where
generateSourceDir :: FilePath -> PackageDescription -> IO ()
generateSourceDir targetDir pkg' = do
setupMessage verbosity "Building source dist for" (packageId pkg')
prepareTree verbosity pkg' targetDir pps
when snapshot $
overwriteSnapshotPackageDesc verbosity pkg' targetDir
verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags)
listPackageSources
:: Verbosity
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSources verbosity cwd pkg_descr0 pps = do
listPackageSources' verbosity die' cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
listPackageSourcesWithDie
:: Verbosity
-> (Verbosity -> String -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do
listPackageSources' verbosity rip cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
listPackageSources'
:: Verbosity
-> (Verbosity -> String -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSources' verbosity rip cwd pkg_descr pps =
fmap concat . sequenceA $
[
fmap concat
. withAllLib $ \Library {
exposedModules = modules,
signatures = sigs,
libBuildInfo = libBi
} ->
allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
, fmap concat
. withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
return (mainSrc:biSrcs)
, fmap concat
. withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
defFiles <- traverse (findModDefFile verbosity cwd flibBi pps)
(foreignLibModDefFile flib)
return (defFiles ++ biSrcs)
, fmap concat
. withAllTest $ \t -> do
let bi = testBuildInfo t
case testInterface t of
TestSuiteExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile:biSrcs)
TestSuiteLibV09 _ m ->
allSourcesBuildInfo verbosity rip cwd bi pps [m]
TestSuiteUnsupported tp ->
rip verbosity $ "Unsupported test suite type: " ++ show tp
, fmap concat
. withAllBenchmark $ \bm -> do
let bi = benchmarkBuildInfo bm
case benchmarkInterface bm of
BenchmarkExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile:biSrcs)
BenchmarkUnsupported tp ->
rip verbosity $ "Unsupported benchmark type: " ++ show tp
, fmap concat
. for (dataFiles pkg_descr) $ \filename -> do
let srcDataDirRaw = dataDir pkg_descr
srcDataDir | null srcDataDirRaw = "."
| otherwise = srcDataDirRaw
matchDirFileGlob verbosity (specVersion pkg_descr) cwd (srcDataDir </> filename)
, fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
matchDirFileGlob verbosity (specVersion pkg_descr) cwd fpath
, fmap concat
. for (extraDocFiles pkg_descr) $ \ filename ->
matchDirFileGlob verbosity (specVersion pkg_descr) cwd filename
, return (licenseFiles pkg_descr)
, fmap concat
. withAllLib $ \ l -> do
let lbi = libBuildInfo l
incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
relincdirs = "." : filter isRelative (includeDirs lbi)
traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls
, fmap (maybe [] (\f -> [f])) $ findSetupFile cwd
, fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")
]
where
withAllLib action = traverse action (allLibraries pkg_descr)
withAllFLib action = traverse action (foreignLibs pkg_descr)
withAllExe action = traverse action (executables pkg_descr)
withAllTest action = traverse action (testSuites pkg_descr)
withAllBenchmark action = traverse action (benchmarks pkg_descr)
prepareTree :: Verbosity
-> PackageDescription
-> FilePath
-> [PPSuffixHandler]
-> IO ()
prepareTree verbosity pkg_descr0 targetDir pps = do
ordinary <- listPackageSources verbosity "." pkg_descr pps
installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
maybeCreateDefaultSetupScript targetDir
where
pkg_descr = filterAutogenModules pkg_descr0
findSetupFile :: FilePath -> IO (Maybe FilePath)
findSetupFile targetDir = do
hsExists <- doesFileExist (targetDir </> setupHs)
lhsExists <- doesFileExist (targetDir </> setupLhs)
if hsExists
then return (Just setupHs)
else if lhsExists
then return (Just setupLhs)
else return Nothing
where
setupHs = "Setup.hs"
setupLhs = "Setup.lhs"
maybeCreateDefaultSetupScript :: FilePath -> IO ()
maybeCreateDefaultSetupScript targetDir = do
mSetupFile <- findSetupFile targetDir
case mSetupFile of
Just _setupFile -> return ()
Nothing -> do
writeUTF8File (targetDir </> "Setup.hs") $ unlines [
"import Distribution.Simple",
"main = defaultMain"]
findMainExeFile
:: Verbosity
-> FilePath
-> BuildInfo
-> [PPSuffixHandler]
-> FilePath
-> IO FilePath
findMainExeFile verbosity cwd exeBi pps mainPath = do
ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (hsSourceDirs exeBi)
(dropExtension mainPath)
case ppFile of
Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath
Just pp -> return pp
findModDefFile
:: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
findModDefFile verbosity cwd flibBi _pps modDefPath =
findFileCwd verbosity cwd (".":hsSourceDirs flibBi) modDefPath
findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f)
findIncludeFile verbosity cwd (d:ds) f = do
let path = (d </> f)
b <- doesFileExist (cwd </> path)
if b then return (f,path) else findIncludeFile verbosity cwd ds f
filterAutogenModules :: PackageDescription -> PackageDescription
filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $
mapAllBuildInfo filterAutogenModuleBI pkg_descr0
where
mapLib f pkg = pkg { library = fmap f (library pkg)
, subLibraries = map f (subLibraries pkg) }
filterAutogenModuleLib lib = lib {
exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
}
filterAutogenModuleBI bi = bi {
otherModules = filter (filterFunction bi) (otherModules bi)
}
pathsModule = autogenPathsModuleName pkg_descr0
filterFunction bi = \mn ->
mn /= pathsModule
&& not (mn `elem` autogenModules bi)
prepareSnapshotTree
:: Verbosity
-> PackageDescription
-> FilePath
-> [PPSuffixHandler]
-> IO ()
prepareSnapshotTree verbosity pkg targetDir pps = do
prepareTree verbosity pkg targetDir pps
overwriteSnapshotPackageDesc verbosity pkg targetDir
overwriteSnapshotPackageDesc :: Verbosity
-> PackageDescription
-> FilePath
-> IO ()
overwriteSnapshotPackageDesc verbosity pkg targetDir = do
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: " ++ prettyShow version
| otherwise = line
snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage date pkg =
pkg {
package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
}
where pkgid = packageId pkg
snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])
dateToSnapshotNumber :: UTCTime -> Int
dateToSnapshotNumber date = case toGregorian (utctDay date) of
(year, month, day) ->
fromIntegral year * 10000
+ month * 100
+ day
createArchive
:: Verbosity
-> PackageDescription
-> FilePath
-> FilePath
-> IO FilePath
createArchive verbosity pkg_descr tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb
let formatOptSupported = maybe False (== "YES") $
Map.lookup "Supports --format"
(programProperties tarProg)
runProgram verbosity tarProg $
["-czf", tarBallFilePath, "-C", tmpDir]
++ (if formatOptSupported then ["--format", "ustar"] else [])
++ [tarBallName pkg_descr]
return tarBallFilePath
allSourcesBuildInfo
:: Verbosity
-> (Verbosity -> String -> IO [FilePath])
-> FilePath
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [FilePath]
allSourcesBuildInfo verbosity rip cwd bi pps modules = do
let searchDirs = hsSourceDirs bi
sources <- fmap concat $ sequenceA $
[ let file = ModuleName.toFilePath module_
in findAllFilesCwdWithExtension cwd suffixes searchDirs file
>>= nonEmpty (notFound module_) return
| module_ <- modules ++ otherModules bi ]
bootFiles <- sequenceA
[ let file = ModuleName.toFilePath module_
fileExts = ["hs-boot", "lhs-boot"]
in findFileCwdWithExtension cwd fileExts (hsSourceDirs bi) file
| module_ <- modules ++ otherModules bi ]
return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++
cmmSources bi ++ asmSources bi ++ jsSources bi
where
nonEmpty x _ [] = x
nonEmpty _ f xs = f xs
suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]
notFound :: ModuleName -> IO [FilePath]
notFound m = rip verbosity $ "Error: Could not find module: " ++ prettyShow m
++ " with any suffix: " ++ show suffixes ++ ". If the module "
++ "is autogenerated it should be added to 'autogen-modules'."
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems verbosity pkg_descr = do
ioChecks <- checkPackageFiles verbosity pkg_descr "."
let pureChecks = checkConfiguredPackage pkg_descr
isDistError (PackageDistSuspicious _) = False
isDistError (PackageDistSuspiciousWarn _) = False
isDistError _ = True
(errors, warnings) = partition isDistError (pureChecks ++ ioChecks)
unless (null errors) $
notice verbosity $ "Distribution quality errors:\n"
++ unlines (map explanation errors)
unless (null warnings) $
notice verbosity $ "Distribution quality warnings:\n"
++ unlines (map explanation warnings)
unless (null errors) $
notice verbosity
"Note: the public hackage server would reject this package."
tarBallName :: PackageDescription -> String
tarBallName = prettyShow . packageId
mapAllBuildInfo :: (BuildInfo -> BuildInfo)
-> (PackageDescription -> PackageDescription)
mapAllBuildInfo f pkg = pkg {
library = fmap mapLibBi (library pkg),
subLibraries = fmap mapLibBi (subLibraries pkg),
foreignLibs = fmap mapFLibBi (foreignLibs pkg),
executables = fmap mapExeBi (executables pkg),
testSuites = fmap mapTestBi (testSuites pkg),
benchmarks = fmap mapBenchBi (benchmarks pkg)
}
where
mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }
mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }
mapExeBi exe = exe { buildInfo = f (buildInfo exe) }
mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) }
mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }