{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.SrcDist
-- Copyright   :  Simon Marlow 2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This handles the @sdist@ command. The module exports an 'sdist' action but
-- also some of the phases that make it up so that other tools can use just the
-- bits they need. In particular the preparation of the tree of files to go
-- into the source tarball is separated from actually building the source
-- tarball.
--
-- The 'createArchive' action uses the external @tar@ program and assumes that
-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.
-- The 'sdist' action now also does some distribution QA checks.

-- NOTE: FIX: we don't have a great way of testing this module, since
-- we can't easily look inside a tarball once its created.

module Distribution.Simple.SrcDist (
  -- * The top level action
  sdist,

  -- ** Parts of 'sdist'
  printPackageProblems,
  prepareTree,
  createArchive,

  -- ** Snapshots
  prepareSnapshotTree,
  snapshotPackage,
  snapshotVersion,
  dateToSnapshotNumber,

  -- * Extracting the source files
  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 (matchDirFileGlobWithDie)
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 Distribution.Utils.Path

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)

-- |Create a source distribution.
sdist :: PackageDescription     -- ^ information from the tarball
      -> SDistFlags             -- ^ verbosity & snapshot
      -> (FilePath -> FilePath) -- ^ build prefix (temp dir)
      -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)
      -> IO ()
sdist :: PackageDescription
-> SDistFlags -> (String -> String) -> [PPSuffixHandler] -> IO ()
sdist PackageDescription
pkg SDistFlags
flags String -> String
mkTmpDir [PPSuffixHandler]
pps = do

  String
distPref <- Flag String -> IO String
findDistPrefOrDefault (Flag String -> IO String) -> Flag String -> IO String
forall a b. (a -> b) -> a -> b
$ SDistFlags -> Flag String
sDistDistPref SDistFlags
flags
  let targetPref :: String
targetPref   = String
distPref
      tmpTargetDir :: String
tmpTargetDir = String -> String
mkTmpDir String
distPref

  -- When given --list-sources, just output the list of sources to a file.
  case SDistFlags -> Flag String
sDistListSources SDistFlags
flags of
    Flag String
path -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
outHandle -> do
      [String]
ordinary <- Verbosity
-> String -> PackageDescription -> [PPSuffixHandler] -> IO [String]
listPackageSources Verbosity
verbosity String
"." PackageDescription
pkg [PPSuffixHandler]
pps
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> String -> IO ()
hPutStrLn Handle
outHandle) [String]
ordinary
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"List of package sources written to file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

    Flag String
NoFlag    -> do
      -- do some QA
      Verbosity -> PackageDescription -> IO ()
printPackageProblems Verbosity
verbosity PackageDescription
pkg

      UTCTime
date <- IO UTCTime
getCurrentTime
      let pkg' :: PackageDescription
pkg' | Bool
snapshot  = UTCTime -> PackageDescription -> PackageDescription
snapshotPackage UTCTime
date PackageDescription
pkg
               | Bool
otherwise = PackageDescription
pkg

      case Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (SDistFlags -> Flag String
sDistDirectory SDistFlags
flags) of
        Just String
targetDir -> do
          String -> PackageDescription -> IO ()
generateSourceDir String
targetDir PackageDescription
pkg'
          Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Source directory created: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetDir

        Maybe String
Nothing -> do
          Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
tmpTargetDir
          Verbosity -> String -> String -> (String -> IO ()) -> IO ()
forall a. Verbosity -> String -> String -> (String -> IO a) -> IO a
withTempDirectory Verbosity
verbosity String
tmpTargetDir String
"sdist." ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tmpDir -> do
            let targetDir :: String
targetDir = String
tmpDir String -> String -> String
</> PackageDescription -> String
tarBallName PackageDescription
pkg'
            String -> PackageDescription -> IO ()
generateSourceDir String
targetDir PackageDescription
pkg'
            String
targzFile <- Verbosity -> PackageDescription -> String -> String -> IO String
createArchive Verbosity
verbosity PackageDescription
pkg' String
tmpDir String
targetPref
            Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Source tarball created: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targzFile

  where
    generateSourceDir :: FilePath -> PackageDescription -> IO ()
    generateSourceDir :: String -> PackageDescription -> IO ()
generateSourceDir String
targetDir PackageDescription
pkg' = do
      Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity String
"Building source dist for" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg')
      Verbosity
-> PackageDescription -> String -> [PPSuffixHandler] -> IO ()
prepareTree Verbosity
verbosity PackageDescription
pkg' String
targetDir [PPSuffixHandler]
pps
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
snapshot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> PackageDescription -> String -> IO ()
overwriteSnapshotPackageDesc Verbosity
verbosity PackageDescription
pkg' String
targetDir

    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (SDistFlags -> Flag Verbosity
sDistVerbosity SDistFlags
flags)
    snapshot :: Bool
snapshot  = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (SDistFlags -> Flag Bool
sDistSnapshot SDistFlags
flags)

-- | List all source files of a package.
--
-- Since @Cabal-3.4@ returns a single list. There shouldn't be any
-- executable files, they are hardly portable.
--
listPackageSources
    :: Verbosity          -- ^ verbosity
    -> FilePath           -- ^ directory with cabal file
    -> PackageDescription -- ^ info from the cabal file
    -> [PPSuffixHandler]  -- ^ extra preprocessors (include suffixes)
    -> IO [FilePath]      -- ^ relative paths
listPackageSources :: Verbosity
-> String -> PackageDescription -> [PPSuffixHandler] -> IO [String]
listPackageSources Verbosity
verbosity String
cwd PackageDescription
pkg_descr0 [PPSuffixHandler]
pps = do
    -- Call helpers that actually do all work.
    Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> PackageDescription
-> [PPSuffixHandler]
-> IO [String]
listPackageSources' Verbosity
verbosity Verbosity -> String -> IO [String]
forall a. Verbosity -> String -> IO a
die' String
cwd PackageDescription
pkg_descr [PPSuffixHandler]
pps
  where
    pkg_descr :: PackageDescription
pkg_descr = PackageDescription -> PackageDescription
filterAutogenModules PackageDescription
pkg_descr0

-- | A variant of 'listPackageSources' with configurable 'die'.
--
-- /Note:/ may still 'die' directly. For example on missing include file.
--
-- Since @3.4.0.0
listPackageSourcesWithDie
    :: Verbosity          -- ^ verbosity
    -> (Verbosity -> String -> IO [FilePath])
         -- ^ 'die'' alternative.
         -- Since 'die'' prefixes the error message with 'errorPrefix',
         -- whatever is passed in here and wants to die should do the same.
         -- See issue #7331.
    -> FilePath           -- ^ directory with cabal file
    -> PackageDescription -- ^ info from the cabal file
    -> [PPSuffixHandler]  -- ^ extra preprocessors (include suffixes)
    -> IO [FilePath]      -- ^ relative paths
listPackageSourcesWithDie :: Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> PackageDescription
-> [PPSuffixHandler]
-> IO [String]
listPackageSourcesWithDie Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd PackageDescription
pkg_descr0 [PPSuffixHandler]
pps = do
    -- Call helpers that actually do all work.
    Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> PackageDescription
-> [PPSuffixHandler]
-> IO [String]
listPackageSources' Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd PackageDescription
pkg_descr [PPSuffixHandler]
pps
  where
    pkg_descr :: PackageDescription
pkg_descr = PackageDescription -> PackageDescription
filterAutogenModules PackageDescription
pkg_descr0


listPackageSources'
  :: Verbosity
       -- ^ verbosity
  -> (Verbosity -> String -> IO [FilePath])
       -- ^ 'die'' alternative.
       -- Since 'die'' prefixes the error message with 'errorPrefix',
       -- whatever is passed in here and wants to die should do the same.
       -- See issue #7331.
  -> FilePath
       -- ^ directory with cabal file
  -> PackageDescription
       -- ^ info from the cabal file
  -> [PPSuffixHandler]
       -- ^ extra preprocessors (include suffixes)
  -> IO [FilePath]
       -- ^ relative paths
listPackageSources' :: Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> PackageDescription
-> [PPSuffixHandler]
-> IO [String]
listPackageSources' Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd PackageDescription
pkg_descr [PPSuffixHandler]
pps =
  ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[String]] -> IO [String])
-> ([IO [String]] -> IO [[String]]) -> [IO [String]] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO [String]] -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([IO [String]] -> IO [String]) -> [IO [String]] -> IO [String]
forall a b. (a -> b) -> a -> b
$
  [
    -- Library sources.
    ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((Library -> IO [String]) -> IO [[String]])
-> (Library -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Library -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(Library -> f b) -> f [b]
withAllLib ((Library -> IO [String]) -> IO [String])
-> (Library -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Library {
                      exposedModules :: Library -> [ModuleName]
exposedModules = [ModuleName]
modules,
                      signatures :: Library -> [ModuleName]
signatures     = [ModuleName]
sigs,
                      libBuildInfo :: Library -> BuildInfo
libBuildInfo   = BuildInfo
libBi
                    } ->
     Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
libBi [PPSuffixHandler]
pps ([ModuleName]
modules [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
sigs)

    -- Executables sources.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((Executable -> IO [String]) -> IO [[String]])
-> (Executable -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Executable -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(Executable -> f b) -> f [b]
withAllExe ((Executable -> IO [String]) -> IO [String])
-> (Executable -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Executable { modulePath :: Executable -> String
modulePath = String
mainPath, buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
exeBi } -> do
       [String]
biSrcs  <- Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
exeBi [PPSuffixHandler]
pps []
       String
mainSrc <- Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findMainExeFile Verbosity
verbosity String
cwd BuildInfo
exeBi [PPSuffixHandler]
pps String
mainPath
       [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
mainSrcString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
biSrcs)

    -- Foreign library sources
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((ForeignLib -> IO [String]) -> IO [[String]])
-> (ForeignLib -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ForeignLib -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(ForeignLib -> f b) -> f [b]
withAllFLib ((ForeignLib -> IO [String]) -> IO [String])
-> (ForeignLib -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \flib :: ForeignLib
flib@(ForeignLib { foreignLibBuildInfo :: ForeignLib -> BuildInfo
foreignLibBuildInfo = BuildInfo
flibBi }) -> do
       [String]
biSrcs   <- Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
flibBi [PPSuffixHandler]
pps []
       [String]
defFiles <- (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findModDefFile Verbosity
verbosity String
cwd BuildInfo
flibBi [PPSuffixHandler]
pps)
         (ForeignLib -> [String]
foreignLibModDefFile ForeignLib
flib)
       [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
defFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
biSrcs)

    -- Test suites sources.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((TestSuite -> IO [String]) -> IO [[String]])
-> (TestSuite -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestSuite -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(TestSuite -> f b) -> f [b]
withAllTest ((TestSuite -> IO [String]) -> IO [String])
-> (TestSuite -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \TestSuite
t -> do
       let bi :: BuildInfo
bi  = TestSuite -> BuildInfo
testBuildInfo TestSuite
t
       case TestSuite -> TestSuiteInterface
testInterface TestSuite
t of
         TestSuiteExeV10 Version
_ String
mainPath -> do
           [String]
biSrcs <- Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
bi [PPSuffixHandler]
pps []
           String
srcMainFile <- Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findMainExeFile Verbosity
verbosity String
cwd BuildInfo
bi [PPSuffixHandler]
pps String
mainPath
           [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
srcMainFileString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
biSrcs)
         TestSuiteLibV09 Version
_ ModuleName
m ->
           Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
bi [PPSuffixHandler]
pps [ModuleName
m]
         TestSuiteUnsupported TestType
tp ->
           Verbosity -> String -> IO [String]
rip Verbosity
verbosity (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
"Unsupported test suite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestType -> String
forall a. Show a => a -> String
show TestType
tp

    -- Benchmarks sources.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((Benchmark -> IO [String]) -> IO [[String]])
-> (Benchmark -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(Benchmark -> f b) -> f [b]
withAllBenchmark ((Benchmark -> IO [String]) -> IO [String])
-> (Benchmark -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Benchmark
bm -> do
       let  bi :: BuildInfo
bi = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bm
       case Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
bm of
         BenchmarkExeV10 Version
_ String
mainPath -> do
           [String]
biSrcs <- Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
bi [PPSuffixHandler]
pps []
           String
srcMainFile <- Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findMainExeFile Verbosity
verbosity String
cwd BuildInfo
bi [PPSuffixHandler]
pps String
mainPath
           [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
srcMainFileString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
biSrcs)
         BenchmarkUnsupported BenchmarkType
tp ->
            Verbosity -> String -> IO [String]
rip Verbosity
verbosity (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
"Unsupported benchmark type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BenchmarkType -> String
forall a. Show a => a -> String
show BenchmarkType
tp

    -- Data files.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((String -> IO [String]) -> IO [[String]])
-> (String -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> (String -> IO [String]) -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PackageDescription -> [String]
dataFiles PackageDescription
pkg_descr) ((String -> IO [String]) -> IO [String])
-> (String -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
filename -> do
        let srcDataDirRaw :: String
srcDataDirRaw                   = PackageDescription -> String
dataDir PackageDescription
pkg_descr
            srcDataDir :: String
srcDataDir | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
srcDataDirRaw = String
"."
                       | Bool
otherwise          = String
srcDataDirRaw
        Verbosity
-> (Verbosity -> String -> IO [String])
-> CabalSpecVersion
-> String
-> String
-> IO [String]
matchDirFileGlobWithDie Verbosity
verbosity Verbosity -> String -> IO [String]
rip (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) String
cwd (String
srcDataDir String -> String -> String
</> String
filename)

    -- Extra source files.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[String]] -> IO [String])
-> ((String -> IO [String]) -> IO [[String]])
-> (String -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> (String -> IO [String]) -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PackageDescription -> [String]
extraSrcFiles PackageDescription
pkg_descr) ((String -> IO [String]) -> IO [String])
-> (String -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
fpath ->
    Verbosity
-> (Verbosity -> String -> IO [String])
-> CabalSpecVersion
-> String
-> String
-> IO [String]
matchDirFileGlobWithDie Verbosity
verbosity Verbosity -> String -> IO [String]
rip (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) String
cwd String
fpath

    -- Extra doc files.
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((String -> IO [String]) -> IO [[String]])
-> (String -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> (String -> IO [String]) -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PackageDescription -> [String]
extraDocFiles PackageDescription
pkg_descr) ((String -> IO [String]) -> IO [String])
-> (String -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ String
filename ->
        Verbosity
-> (Verbosity -> String -> IO [String])
-> CabalSpecVersion
-> String
-> String
-> IO [String]
matchDirFileGlobWithDie Verbosity
verbosity Verbosity -> String -> IO [String]
rip (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) String
cwd String
filename

    -- License file(s).
  , [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SymbolicPath PackageDir LicenseFile -> String)
-> [SymbolicPath PackageDir LicenseFile] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir LicenseFile -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath ([SymbolicPath PackageDir LicenseFile] -> [String])
-> [SymbolicPath PackageDir LicenseFile] -> [String]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [SymbolicPath PackageDir LicenseFile]
licenseFiles PackageDescription
pkg_descr)

    -- Install-include files, without autogen-include files
  , ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (IO [[String]] -> IO [String])
-> ((Library -> IO [String]) -> IO [[String]])
-> (Library -> IO [String])
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Library -> IO [String]) -> IO [[String]]
forall {f :: * -> *} {b}.
Applicative f =>
(Library -> f b) -> f [b]
withAllLib ((Library -> IO [String]) -> IO [String])
-> (Library -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ Library
l -> do
       let lbi :: BuildInfo
lbi   = Library -> BuildInfo
libBuildInfo Library
l
           incls :: [String]
incls = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` BuildInfo -> [String]
autogenIncludes BuildInfo
lbi) (BuildInfo -> [String]
installIncludes BuildInfo
lbi)
           relincdirs :: [String]
relincdirs = String
"." String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isRelative (BuildInfo -> [String]
includeDirs BuildInfo
lbi)
       (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((String, String) -> String) -> IO (String, String) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, String) -> String
forall a b. (a, b) -> b
snd (IO (String, String) -> IO String)
-> (String -> IO (String, String)) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> [String] -> String -> IO (String, String)
findIncludeFile Verbosity
verbosity String
cwd [String]
relincdirs) [String]
incls

    -- Setup script, if it exists.
  , (Maybe String -> [String]) -> IO (Maybe String) -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
f -> [String
f])) (IO (Maybe String) -> IO [String])
-> IO (Maybe String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findSetupFile String
cwd

    -- The .cabal file itself.
  , (String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
d -> [String
d]) (Verbosity -> String -> String -> IO String
tryFindPackageDescCwd Verbosity
verbosity String
cwd String
".")

  ]
  where
    -- We have to deal with all libs and executables, so we have local
    -- versions of these functions that ignore the 'buildable' attribute:
    withAllLib :: (Library -> f b) -> f [b]
withAllLib       Library -> f b
action = (Library -> f b) -> [Library] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Library -> f b
action (PackageDescription -> [Library]
allLibraries PackageDescription
pkg_descr)
    withAllFLib :: (ForeignLib -> f b) -> f [b]
withAllFLib      ForeignLib -> f b
action = (ForeignLib -> f b) -> [ForeignLib] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ForeignLib -> f b
action (PackageDescription -> [ForeignLib]
foreignLibs PackageDescription
pkg_descr)
    withAllExe :: (Executable -> f b) -> f [b]
withAllExe       Executable -> f b
action = (Executable -> f b) -> [Executable] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Executable -> f b
action (PackageDescription -> [Executable]
executables PackageDescription
pkg_descr)
    withAllTest :: (TestSuite -> f b) -> f [b]
withAllTest      TestSuite -> f b
action = (TestSuite -> f b) -> [TestSuite] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TestSuite -> f b
action (PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg_descr)
    withAllBenchmark :: (Benchmark -> f b) -> f [b]
withAllBenchmark Benchmark -> f b
action = (Benchmark -> f b) -> [Benchmark] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Benchmark -> f b
action (PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg_descr)


-- |Prepare a directory tree of source files.
prepareTree :: Verbosity          -- ^ verbosity
            -> PackageDescription -- ^ info from the cabal file
            -> FilePath           -- ^ source tree to populate
            -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)
            -> IO ()
prepareTree :: Verbosity
-> PackageDescription -> String -> [PPSuffixHandler] -> IO ()
prepareTree Verbosity
verbosity PackageDescription
pkg_descr0 String
targetDir [PPSuffixHandler]
pps = do
    [String]
ordinary <- Verbosity
-> String -> PackageDescription -> [PPSuffixHandler] -> IO [String]
listPackageSources Verbosity
verbosity String
"." PackageDescription
pkg_descr [PPSuffixHandler]
pps
    Verbosity -> String -> [(String, String)] -> IO ()
installOrdinaryFiles Verbosity
verbosity String
targetDir ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
forall a. a -> [a]
repeat []) [String]
ordinary)
    String -> IO ()
maybeCreateDefaultSetupScript String
targetDir
  where
    pkg_descr :: PackageDescription
pkg_descr = PackageDescription -> PackageDescription
filterAutogenModules PackageDescription
pkg_descr0

-- | Find the setup script file, if it exists.
findSetupFile :: FilePath -> IO (Maybe FilePath)
findSetupFile :: String -> IO (Maybe String)
findSetupFile String
targetDir = do
  Bool
hsExists  <- String -> IO Bool
doesFileExist (String
targetDir String -> String -> String
</> String
setupHs)
  Bool
lhsExists <- String -> IO Bool
doesFileExist (String
targetDir String -> String -> String
</> String
setupLhs)
  if Bool
hsExists
    then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
setupHs)
    else if Bool
lhsExists
         then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
setupLhs)
         else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    where
      setupHs :: String
setupHs  = String
"Setup.hs"
      setupLhs :: String
setupLhs = String
"Setup.lhs"

-- | Create a default setup script in the target directory, if it doesn't exist.
maybeCreateDefaultSetupScript :: FilePath -> IO ()
maybeCreateDefaultSetupScript :: String -> IO ()
maybeCreateDefaultSetupScript String
targetDir = do
  Maybe String
mSetupFile <- String -> IO (Maybe String)
findSetupFile String
targetDir
  case Maybe String
mSetupFile of
    Just String
_setupFile -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe String
Nothing         -> do
      String -> String -> IO ()
writeUTF8File (String
targetDir String -> String -> String
</> String
"Setup.hs") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
        String
"import Distribution.Simple",
        String
"main = defaultMain"]

-- | Find the main executable file.
findMainExeFile
  :: Verbosity
  -> FilePath -- ^ cwd
  -> BuildInfo
  -> [PPSuffixHandler]
  -> FilePath -- ^ main-is
  -> IO FilePath
findMainExeFile :: Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findMainExeFile Verbosity
verbosity String
cwd BuildInfo
exeBi [PPSuffixHandler]
pps String
mainPath = do
  Maybe String
ppFile <- String -> [String] -> [String] -> String -> IO (Maybe String)
findFileCwdWithExtension String
cwd ([PPSuffixHandler] -> [String]
ppSuffixes [PPSuffixHandler]
pps) ((SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
exeBi))
            (String -> String
dropExtension String
mainPath)
  case Maybe String
ppFile of
    Maybe String
Nothing -> Verbosity -> String -> [String] -> String -> IO String
findFileCwd Verbosity
verbosity String
cwd ((SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
exeBi)) String
mainPath
    Just String
pp -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
pp

-- | Find a module definition file
--
-- TODO: I don't know if this is right
findModDefFile
  :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
findModDefFile :: Verbosity
-> String -> BuildInfo -> [PPSuffixHandler] -> String -> IO String
findModDefFile Verbosity
verbosity String
cwd BuildInfo
flibBi [PPSuffixHandler]
_pps String
modDefPath =
    Verbosity -> String -> [String] -> String -> IO String
findFileCwd Verbosity
verbosity String
cwd (String
"." String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
flibBi)) String
modDefPath

-- | Given a list of include paths, try to find the include file named
-- @f@. Return the name of the file and the full path, or exit with error if
-- there's no such file.
findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
findIncludeFile :: Verbosity -> String -> [String] -> String -> IO (String, String)
findIncludeFile Verbosity
verbosity String
_ [] String
f = Verbosity -> String -> IO (String, String)
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String
"can't find include file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)
findIncludeFile Verbosity
verbosity String
cwd (String
d:[String]
ds) String
f = do
  let path :: String
path = (String
d String -> String -> String
</> String
f)
  Bool
b <- String -> IO Bool
doesFileExist (String
cwd String -> String -> String
</> String
path)
  if Bool
b then (String, String) -> IO (String, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f,String
path) else Verbosity -> String -> [String] -> String -> IO (String, String)
findIncludeFile Verbosity
verbosity String
cwd [String]
ds String
f

-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules'
-- and 'other-modules'.
filterAutogenModules :: PackageDescription -> PackageDescription
filterAutogenModules :: PackageDescription -> PackageDescription
filterAutogenModules PackageDescription
pkg_descr0 = (Library -> Library) -> PackageDescription -> PackageDescription
mapLib Library -> Library
filterAutogenModuleLib (PackageDescription -> PackageDescription)
-> PackageDescription -> PackageDescription
forall a b. (a -> b) -> a -> b
$
                                 (BuildInfo -> BuildInfo)
-> PackageDescription -> PackageDescription
mapAllBuildInfo BuildInfo -> BuildInfo
filterAutogenModuleBI PackageDescription
pkg_descr0
  where
    mapLib :: (Library -> Library) -> PackageDescription -> PackageDescription
mapLib Library -> Library
f PackageDescription
pkg = PackageDescription
pkg { library      = fmap f (library pkg)
                       , subLibraries = map f (subLibraries pkg) }
    filterAutogenModuleLib :: Library -> Library
filterAutogenModuleLib Library
lib = Library
lib {
      exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
    }
    filterAutogenModuleBI :: BuildInfo -> BuildInfo
filterAutogenModuleBI BuildInfo
bi = BuildInfo
bi {
      otherModules   = filter (filterFunction bi) (otherModules bi)
    }
    pathsModule :: ModuleName
pathsModule = PackageDescription -> ModuleName
autogenPathsModuleName PackageDescription
pkg_descr0
    filterFunction :: BuildInfo -> ModuleName -> Bool
filterFunction BuildInfo
bi = \ModuleName
mn ->
                                   ModuleName
mn ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
pathsModule
                                Bool -> Bool -> Bool
&& Bool -> Bool
not (ModuleName
mn ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` BuildInfo -> [ModuleName]
autogenModules BuildInfo
bi)

-- | Prepare a directory tree of source files for a snapshot version.
-- It is expected that the appropriate snapshot version has already been set
-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
--
prepareSnapshotTree
  :: Verbosity          -- ^verbosity
  -> PackageDescription -- ^info from the cabal file
  -> FilePath           -- ^source tree to populate
  -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)
  -> IO ()
prepareSnapshotTree :: Verbosity
-> PackageDescription -> String -> [PPSuffixHandler] -> IO ()
prepareSnapshotTree Verbosity
verbosity PackageDescription
pkg String
targetDir [PPSuffixHandler]
pps = do
  Verbosity
-> PackageDescription -> String -> [PPSuffixHandler] -> IO ()
prepareTree Verbosity
verbosity PackageDescription
pkg String
targetDir [PPSuffixHandler]
pps
  Verbosity -> PackageDescription -> String -> IO ()
overwriteSnapshotPackageDesc Verbosity
verbosity PackageDescription
pkg String
targetDir

overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity
                             -> PackageDescription -- ^info from the cabal file
                             -> FilePath           -- ^source tree
                             -> IO ()
overwriteSnapshotPackageDesc :: Verbosity -> PackageDescription -> String -> IO ()
overwriteSnapshotPackageDesc Verbosity
verbosity PackageDescription
pkg String
targetDir = do
    -- We could just writePackageDescription targetDescFile pkg_descr,
    -- but that would lose comments and formatting.
    String
descFile <- Verbosity -> IO String
defaultPackageDesc Verbosity
verbosity
    String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withUTF8FileContents String
descFile ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> IO ()
writeUTF8File (String
targetDir String -> String -> String
</> String
descFile)
        (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Version -> String -> String
replaceVersion (PackageDescription -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageDescription
pkg)) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

  where
    replaceVersion :: Version -> String -> String
    replaceVersion :: Version -> String -> String
replaceVersion Version
version String
line
      | String
"version:" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
line
                  = String
"version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
version
      | Bool
otherwise = String
line

-- | Modifies a 'PackageDescription' by appending a snapshot number
-- corresponding to the given date.
--
snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage UTCTime
date PackageDescription
pkg =
  PackageDescription
pkg {
    package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
  }
  where pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg

-- | Modifies a 'Version' by appending a snapshot number corresponding
-- to the given date.
--
snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion UTCTime
date = ([Int] -> [Int]) -> Version -> Version
alterVersion ([Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [UTCTime -> Int
dateToSnapshotNumber UTCTime
date])

-- | Given a date produce a corresponding integer representation.
-- For example given a date @18/03/2008@ produce the number @20080318@.
--
dateToSnapshotNumber :: UTCTime -> Int
dateToSnapshotNumber :: UTCTime -> Int
dateToSnapshotNumber UTCTime
date = case Day -> (Year, Int, Int)
toGregorian (UTCTime -> Day
utctDay UTCTime
date) of
                            (Year
year, Int
month, Int
day) ->
                                Year -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
year Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000
                              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
month             Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100
                              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
day

-- | Create an archive from a tree of source files, and clean up the tree.
createArchive
    :: Verbosity            -- ^ verbosity
    -> PackageDescription   -- ^ info from cabal file
    -> FilePath             -- ^ source tree to archive
    -> FilePath             -- ^ name of archive to create
    -> IO FilePath
createArchive :: Verbosity -> PackageDescription -> String -> String -> IO String
createArchive Verbosity
verbosity PackageDescription
pkg_descr String
tmpDir String
targetPref = do
  let tarBallFilePath :: String
tarBallFilePath = String
targetPref String -> String -> String
</> PackageDescription -> String
tarBallName PackageDescription
pkg_descr String -> String -> String
<.> String
"tar.gz"
  (ConfiguredProgram
tarProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
tarProgram ProgramDb
defaultProgramDb
  let formatOptSupported :: Bool
formatOptSupported = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"YES") (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$
                           String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"Supports --format"
                           (ConfiguredProgram -> Map String String
programProperties ConfiguredProgram
tarProg)
  Verbosity -> ConfiguredProgram -> [String] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
tarProg ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- Hmm: I could well be skating on thinner ice here by using the -C option
    -- (=> seems to be supported at least by GNU and *BSD tar) [The
    -- prev. solution used pipes and sub-command sequences to set up the paths
    -- correctly, which is problematic in a Windows setting.]
    [String
"-czf", String
tarBallFilePath, String
"-C", String
tmpDir]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Bool
formatOptSupported then [String
"--format", String
"ustar"] else [])
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [PackageDescription -> String
tarBallName PackageDescription
pkg_descr]
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tarBallFilePath

-- | Given a buildinfo, return the names of all source files.
allSourcesBuildInfo
    :: Verbosity
    -> (Verbosity -> String -> IO [FilePath])
         -- ^ 'die'' alternative.
         -- Since 'die'' prefixes the error message with 'errorPrefix',
         -- whatever is passed in here and wants to die should do the same.
         -- See issue #7331.
    -> FilePath          -- ^ cwd -- change me to 'BuildPath Absolute PackageDir'
    -> BuildInfo
    -> [PPSuffixHandler] -- ^ Extra preprocessors
    -> [ModuleName]      -- ^ Exposed modules
    -> IO [FilePath]
allSourcesBuildInfo :: Verbosity
-> (Verbosity -> String -> IO [String])
-> String
-> BuildInfo
-> [PPSuffixHandler]
-> [ModuleName]
-> IO [String]
allSourcesBuildInfo Verbosity
verbosity Verbosity -> String -> IO [String]
rip String
cwd BuildInfo
bi [PPSuffixHandler]
pps [ModuleName]
modules = do
  let searchDirs :: [String]
searchDirs = (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi)
  [String]
sources <- ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[String]] -> IO [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [IO [String]] -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([IO [String]] -> IO [[String]]) -> [IO [String]] -> IO [[String]]
forall a b. (a -> b) -> a -> b
$
    [ let file :: String
file = ModuleName -> String
ModuleName.toFilePath ModuleName
module_
      -- NB: *Not* findFileWithExtension, because the same source
      -- file may show up in multiple paths due to a conditional;
      -- we need to package all of them.  See #367.
      in String -> [String] -> [String] -> String -> IO [String]
findAllFilesCwdWithExtension String
cwd [String]
suffixes [String]
searchDirs String
file
         IO [String] -> ([String] -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [String] -> ([String] -> IO [String]) -> [String] -> IO [String]
forall b a. b -> ([a] -> b) -> [a] -> b
nonEmpty' (ModuleName -> IO [String]
notFound ModuleName
module_) [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    | ModuleName
module_ <- [ModuleName]
modules [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [ModuleName]
otherModules BuildInfo
bi ]
  [Maybe String]
bootFiles <- [IO (Maybe String)] -> IO [Maybe String]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ let file :: String
file = ModuleName -> String
ModuleName.toFilePath ModuleName
module_
          fileExts :: [String]
fileExts = [String
"hs-boot", String
"lhs-boot"]
      in String -> [String] -> [String] -> String -> IO (Maybe String)
findFileCwdWithExtension String
cwd [String]
fileExts ((SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi)) String
file
    | ModuleName
module_ <- [ModuleName]
modules [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [ModuleName]
otherModules BuildInfo
bi ]

  [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
sources [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
bootFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
cSources BuildInfo
bi [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
cxxSources BuildInfo
bi [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
           BuildInfo -> [String]
cmmSources BuildInfo
bi [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
asmSources BuildInfo
bi [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
jsSources BuildInfo
bi

  where
    nonEmpty' :: b -> ([a] -> b) -> [a] -> b
    nonEmpty' :: forall b a. b -> ([a] -> b) -> [a] -> b
nonEmpty' b
x [a] -> b
_ [] = b
x
    nonEmpty' b
_ [a] -> b
f [a]
xs = [a] -> b
f [a]
xs

    suffixes :: [String]
suffixes = [PPSuffixHandler] -> [String]
ppSuffixes [PPSuffixHandler]
pps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"hs", String
"lhs", String
"hsig", String
"lhsig"]

    notFound :: ModuleName -> IO [FilePath]
    notFound :: ModuleName -> IO [String]
notFound ModuleName
m = Verbosity -> String -> IO [String]
rip Verbosity
verbosity (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
"Could not find module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with any suffix: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
suffixes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". If the module "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is autogenerated it should be added to 'autogen-modules'."


-- | Note: must be called with the CWD set to the directory containing
-- the '.cabal' file.
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems Verbosity
verbosity PackageDescription
pkg_descr = do
  [PackageCheck]
ioChecks      <- Verbosity -> PackageDescription -> String -> IO [PackageCheck]
checkPackageFiles Verbosity
verbosity PackageDescription
pkg_descr String
"."
  let pureChecks :: [PackageCheck]
pureChecks = PackageDescription -> [PackageCheck]
checkConfiguredPackage PackageDescription
pkg_descr
      isDistError :: PackageCheck -> Bool
isDistError (PackageDistSuspicious     CheckExplanation
_) = Bool
False
      isDistError (PackageDistSuspiciousWarn CheckExplanation
_) = Bool
False
      isDistError PackageCheck
_                             = Bool
True
      ([PackageCheck]
errors, [PackageCheck]
warnings) = (PackageCheck -> Bool)
-> [PackageCheck] -> ([PackageCheck], [PackageCheck])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition PackageCheck -> Bool
isDistError ([PackageCheck]
pureChecks [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ [PackageCheck]
ioChecks)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Distribution quality errors:\n"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PackageCheck -> String) -> [PackageCheck] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageCheck -> String
ppPackageCheck [PackageCheck]
errors)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
warnings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Distribution quality warnings:\n"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PackageCheck -> String) -> [PackageCheck] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageCheck -> String
ppPackageCheck [PackageCheck]
warnings)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
notice Verbosity
verbosity
        String
"Note: the public hackage server would reject this package."

------------------------------------------------------------

-- | The name of the tarball without extension
--
tarBallName :: PackageDescription -> String
tarBallName :: PackageDescription -> String
tarBallName = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String)
-> (PackageDescription -> PackageIdentifier)
-> PackageDescription
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId

mapAllBuildInfo :: (BuildInfo -> BuildInfo)
                -> (PackageDescription -> PackageDescription)
mapAllBuildInfo :: (BuildInfo -> BuildInfo)
-> PackageDescription -> PackageDescription
mapAllBuildInfo BuildInfo -> BuildInfo
f PackageDescription
pkg = PackageDescription
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 :: Library -> Library
mapLibBi   Library
lib  = Library
lib  { libBuildInfo        = f (libBuildInfo lib) }
    mapFLibBi :: ForeignLib -> ForeignLib
mapFLibBi  ForeignLib
flib = ForeignLib
flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }
    mapExeBi :: Executable -> Executable
mapExeBi   Executable
exe  = Executable
exe  { buildInfo           = f (buildInfo exe) }
    mapTestBi :: TestSuite -> TestSuite
mapTestBi  TestSuite
tst  = TestSuite
tst  { testBuildInfo       = f (testBuildInfo tst) }
    mapBenchBi :: Benchmark -> Benchmark
mapBenchBi Benchmark
bm   = Benchmark
bm   { benchmarkBuildInfo  = f (benchmarkBuildInfo bm) }