{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Distribution.Client.CmdSdist
( sdistCommand, sdistAction, packageToSdist
, OutputFormat(..)) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.CmdErrorMessages
( Plural(..), renderComponentKind )
import Distribution.Client.ProjectOrchestration
( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), defaultNixStyleFlags )
import Distribution.Client.TargetSelector
( TargetSelector(..), ComponentKind
, readTargetSelectors, reportTargetSelectorProblems )
import Distribution.Client.Setup
( GlobalFlags(..) )
import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) )
import Distribution.Client.Types
( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
import Distribution.Client.DistDirLayout
( DistDirLayout(..), ProjectRoot (..) )
import Distribution.Client.ProjectConfig
( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )
import Distribution.Client.ProjectFlags
( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )
import Distribution.Compat.Lens
( _1, _2 )
import Distribution.Package
( Package(packageId) )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.ReadE
( succeedReadE )
import Distribution.Simple.Command
( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )
import Distribution.Simple.PreProcess
( knownSuffixHandlers )
import Distribution.Simple.Setup
( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
, optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref
)
import Distribution.Simple.SrcDist
( listPackageSourcesWithDie )
import Distribution.Client.SrcDist
( packageDirToSdist )
import Distribution.Simple.Utils
( die', notice, withOutputMarker, wrapText )
import Distribution.Types.ComponentName
( ComponentName, showComponentName )
import Distribution.Types.PackageName
( PackageName, unPackageName )
import Distribution.Verbosity
( normal )
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import qualified Data.ByteString.Lazy.Char8 as BSL
import System.Directory
( getCurrentDirectory
, createDirectoryIfMissing, makeAbsolute
)
import System.FilePath
( (</>), (<.>), makeRelative, normalise )
sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
sdistCommand = CommandUI
{ commandName :: [Char]
commandName = [Char]
"v2-sdist"
, commandSynopsis :: [Char]
commandSynopsis = [Char]
"Generate a source distribution file (.tar.gz)."
, commandUsage :: [Char] -> [Char]
commandUsage = \[Char]
pname ->
[Char]
"Usage: " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-sdist [FLAGS] [PACKAGES]\n"
, commandDescription :: Maybe ([Char] -> [Char])
commandDescription = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \[Char]
_ -> [Char] -> [Char]
wrapText
[Char]
"Generates tarballs of project packages suitable for upload to Hackage."
, commandNotes :: Maybe ([Char] -> [Char])
commandNotes = forall a. Maybe a
Nothing
, commandDefaultFlags :: (ProjectFlags, SdistFlags)
commandDefaultFlags = (ProjectFlags
defaultProjectFlags, SdistFlags
defaultSdistFlags)
, commandOptions :: ShowOrParseArgs -> [OptionField (ProjectFlags, SdistFlags)]
commandOptions = \ShowOrParseArgs
showOrParseArgs ->
forall a b. (a -> b) -> [a] -> [b]
map (forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL forall a c b. Lens (a, c) (b, c) a b
_1) (ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions ShowOrParseArgs
showOrParseArgs) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL forall c a b. Lens (c, a) (c, b) a b
_2) (ShowOrParseArgs -> [OptionField SdistFlags]
sdistOptions ShowOrParseArgs
showOrParseArgs)
}
data SdistFlags = SdistFlags
{ SdistFlags -> Flag Verbosity
sdistVerbosity :: Flag Verbosity
, SdistFlags -> Flag [Char]
sdistDistDir :: Flag FilePath
, SdistFlags -> Flag Bool
sdistListSources :: Flag Bool
, SdistFlags -> Flag Bool
sdistNulSeparated :: Flag Bool
, SdistFlags -> Flag [Char]
sdistOutputPath :: Flag FilePath
}
defaultSdistFlags :: SdistFlags
defaultSdistFlags :: SdistFlags
defaultSdistFlags = SdistFlags
{ sdistVerbosity :: Flag Verbosity
sdistVerbosity = forall a. a -> Flag a
toFlag Verbosity
normal
, sdistDistDir :: Flag [Char]
sdistDistDir = forall a. Monoid a => a
mempty
, sdistListSources :: Flag Bool
sdistListSources = forall a. a -> Flag a
toFlag Bool
False
, sdistNulSeparated :: Flag Bool
sdistNulSeparated = forall a. a -> Flag a
toFlag Bool
False
, sdistOutputPath :: Flag [Char]
sdistOutputPath = forall a. Monoid a => a
mempty
}
sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
sdistOptions ShowOrParseArgs
showOrParseArgs =
[ forall flags.
(flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags) -> OptionField flags
optionVerbosity
SdistFlags -> Flag Verbosity
sdistVerbosity (\Flag Verbosity
v SdistFlags
flags -> SdistFlags
flags { sdistVerbosity :: Flag Verbosity
sdistVerbosity = Flag Verbosity
v })
, forall flags.
(flags -> Flag [Char])
-> (Flag [Char] -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
SdistFlags -> Flag [Char]
sdistDistDir (\Flag [Char]
dd SdistFlags
flags -> SdistFlags
flags { sdistDistDir :: Flag [Char]
sdistDistDir = Flag [Char]
dd })
ShowOrParseArgs
showOrParseArgs
, forall get set a.
[Char]
-> LFlags
-> [Char]
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [Char
'l'] [[Char]
"list-only"]
[Char]
"Just list the sources, do not make a tarball"
SdistFlags -> Flag Bool
sdistListSources (\Flag Bool
v SdistFlags
flags -> SdistFlags
flags { sdistListSources :: Flag Bool
sdistListSources = Flag Bool
v })
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
, forall get set a.
[Char]
-> LFlags
-> [Char]
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [] [[Char]
"null-sep"]
[Char]
"Separate the source files with NUL bytes rather than newlines."
SdistFlags -> Flag Bool
sdistNulSeparated (\Flag Bool
v SdistFlags
flags -> SdistFlags
flags { sdistNulSeparated :: Flag Bool
sdistNulSeparated = Flag Bool
v })
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
, forall get set a.
[Char]
-> LFlags
-> [Char]
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [Char
'o'] [[Char]
"output-directory", [Char]
"outputdir"]
[Char]
"Choose the output directory of this command. '-' sends all output to stdout"
SdistFlags -> Flag [Char]
sdistOutputPath (\Flag [Char]
o SdistFlags
flags -> SdistFlags
flags { sdistOutputPath :: Flag [Char]
sdistOutputPath = Flag [Char]
o })
(forall b a.
Monoid b =>
[Char]
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg [Char]
"PATH" (forall a. ([Char] -> a) -> ReadE a
succeedReadE forall a. a -> Flag a
Flag) forall a. Flag a -> [a]
flagToList)
]
sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
sdistAction :: (ProjectFlags, SdistFlags) -> LFlags -> GlobalFlags -> IO ()
sdistAction (pf :: ProjectFlags
pf@ProjectFlags{Flag Bool
Flag [Char]
flagIgnoreProject :: ProjectFlags -> Flag Bool
flagProjectFileName :: ProjectFlags -> Flag [Char]
flagIgnoreProject :: Flag Bool
flagProjectFileName :: Flag [Char]
..}, SdistFlags{Flag Bool
Flag [Char]
Flag Verbosity
sdistOutputPath :: Flag [Char]
sdistNulSeparated :: Flag Bool
sdistListSources :: Flag Bool
sdistDistDir :: Flag [Char]
sdistVerbosity :: Flag Verbosity
sdistOutputPath :: SdistFlags -> Flag [Char]
sdistNulSeparated :: SdistFlags -> Flag Bool
sdistListSources :: SdistFlags -> Flag Bool
sdistDistDir :: SdistFlags -> Flag [Char]
sdistVerbosity :: SdistFlags -> Flag Verbosity
..}) LFlags
targetStrings GlobalFlags
globalFlags = do
(ProjectBaseContext
baseCtx, DistDirLayout
distDirLayout) <- forall a.
Verbosity
-> Flag Bool
-> Flag [Char]
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
flagIgnoreProject Flag [Char]
globalConfigFlag IO (ProjectBaseContext, DistDirLayout)
withProject ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
withoutProject
let localPkgs :: [PackageSpecifier UnresolvedSourcePackage]
localPkgs = ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
baseCtx
[TargetSelector]
targetSelectors <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> LFlags
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors [PackageSpecifier UnresolvedSourcePackage]
localPkgs forall a. Maybe a
Nothing LFlags
targetStrings
Maybe [Char]
mOutputPath' <- case Maybe [Char]
mOutputPath of
Just [Char]
"-" -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Char]
"-")
Just [Char]
path -> do
[Char]
abspath <- [Char] -> IO [Char]
makeAbsolute [Char]
path
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
abspath
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Char]
abspath)
Maybe [Char]
Nothing -> do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (DistDirLayout -> [Char]
distSdistDirectory DistDirLayout
distDirLayout)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
let format :: OutputFormat
format :: OutputFormat
format =
if | Bool
listSources, Bool
nulSeparated -> Char -> OutputFormat
SourceList Char
'\0'
| Bool
listSources -> Char -> OutputFormat
SourceList Char
'\n'
| Bool
otherwise -> OutputFormat
TarGzArchive
ext :: [Char]
ext = case OutputFormat
format of
SourceList Char
_ -> [Char]
"list"
OutputFormat
TarGzArchive -> [Char]
"tar.gz"
outputPath :: pkg -> [Char]
outputPath pkg
pkg = case Maybe [Char]
mOutputPath' of
Just [Char]
path
| [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"-" -> [Char]
"-"
| Bool
otherwise -> [Char]
path [Char] -> [Char] -> [Char]
</> forall a. Pretty a => a -> [Char]
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg) [Char] -> [Char] -> [Char]
<.> [Char]
ext
Maybe [Char]
Nothing
| Bool
listSources -> [Char]
"-"
| Bool
otherwise -> DistDirLayout -> PackageIdentifier -> [Char]
distSdistFile DistDirLayout
distDirLayout (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg)
case [PackageSpecifier UnresolvedSourcePackage]
-> [TargetSelector]
-> Either [TargetProblem] [UnresolvedSourcePackage]
reifyTargetSelectors [PackageSpecifier UnresolvedSourcePackage]
localPkgs [TargetSelector]
targetSelectors of
Left [TargetProblem]
errs -> forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFlags -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TargetProblem -> [Char]
renderTargetProblem forall a b. (a -> b) -> a -> b
$ [TargetProblem]
errs
Right [UnresolvedSourcePackage]
pkgs
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnresolvedSourcePackage]
pkgs forall a. Ord a => a -> a -> Bool
> Int
1, Bool -> Bool
not Bool
listSources, Just [Char]
"-" <- Maybe [Char]
mOutputPath' ->
forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity [Char]
"Can't write multiple tarballs to standard output!"
| Bool
otherwise ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\UnresolvedSourcePackage
pkg -> Verbosity
-> [Char]
-> OutputFormat
-> [Char]
-> UnresolvedSourcePackage
-> IO ()
packageToSdist Verbosity
verbosity (DistDirLayout -> [Char]
distProjectRootDirectory DistDirLayout
distDirLayout) OutputFormat
format (forall {pkg}. Package pkg => pkg -> [Char]
outputPath UnresolvedSourcePackage
pkg) UnresolvedSourcePackage
pkg) [UnresolvedSourcePackage]
pkgs
where
verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
sdistVerbosity
listSources :: Bool
listSources = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False Flag Bool
sdistListSources
nulSeparated :: Bool
nulSeparated = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False Flag Bool
sdistNulSeparated
mOutputPath :: Maybe [Char]
mOutputPath = forall a. Flag a -> Maybe a
flagToMaybe Flag [Char]
sdistOutputPath
prjConfig :: ProjectConfig
prjConfig :: ProjectConfig
prjConfig = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
GlobalFlags
globalFlags
(forall a. a -> NixStyleFlags a
defaultNixStyleFlags ())
{ configFlags :: ConfigFlags
configFlags = (forall a. NixStyleFlags a -> ConfigFlags
configFlags forall a b. (a -> b) -> a -> b
$ forall a. a -> NixStyleFlags a
defaultNixStyleFlags ())
{ configVerbosity :: Flag Verbosity
configVerbosity = Flag Verbosity
sdistVerbosity
, configDistPref :: Flag [Char]
configDistPref = Flag [Char]
sdistDistDir
}
, projectFlags :: ProjectFlags
projectFlags = ProjectFlags
pf
}
forall a. Monoid a => a
mempty
globalConfigFlag :: Flag [Char]
globalConfigFlag = ProjectConfigShared -> Flag [Char]
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
prjConfig)
withProject :: IO (ProjectBaseContext, DistDirLayout)
withProject :: IO (ProjectBaseContext, DistDirLayout)
withProject = do
ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
prjConfig CurrentCommand
OtherCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx)
withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
withoutProject ProjectConfig
config = do
[Char]
cwd <- IO [Char]
getCurrentDirectory
ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
verbosity (ProjectConfig
config forall a. Semigroup a => a -> a -> a
<> ProjectConfig
prjConfig) ([Char] -> ProjectRoot
ProjectRootImplicit [Char]
cwd) CurrentCommand
OtherCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx)
data OutputFormat = SourceList Char
| TarGzArchive
deriving (Int -> OutputFormat -> [Char] -> [Char]
[OutputFormat] -> [Char] -> [Char]
OutputFormat -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [OutputFormat] -> [Char] -> [Char]
$cshowList :: [OutputFormat] -> [Char] -> [Char]
show :: OutputFormat -> [Char]
$cshow :: OutputFormat -> [Char]
showsPrec :: Int -> OutputFormat -> [Char] -> [Char]
$cshowsPrec :: Int -> OutputFormat -> [Char] -> [Char]
Show, OutputFormat -> OutputFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputFormat -> OutputFormat -> Bool
$c/= :: OutputFormat -> OutputFormat -> Bool
== :: OutputFormat -> OutputFormat -> Bool
$c== :: OutputFormat -> OutputFormat -> Bool
Eq)
packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
packageToSdist :: Verbosity
-> [Char]
-> OutputFormat
-> [Char]
-> UnresolvedSourcePackage
-> IO ()
packageToSdist Verbosity
verbosity [Char]
projectRootDir OutputFormat
format [Char]
outputFile UnresolvedSourcePackage
pkg = do
let death :: IO a
death = forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity ([Char]
"The impossible happened: a local package isn't local" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show UnresolvedSourcePackage
pkg))
Either [Char] [Char]
dir0 <- case forall loc. SourcePackage loc -> loc
srcpkgSource UnresolvedSourcePackage
pkg of
LocalUnpackedPackage [Char]
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right [Char]
path)
RemoteSourceRepoPackage SourceRepoMaybe
_ (Just [Char]
tgz) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left [Char]
tgz)
RemoteSourceRepoPackage {} -> forall {a}. IO a
death
LocalTarballPackage [Char]
tgz -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left [Char]
tgz)
RemoteTarballPackage URI
_ (Just [Char]
tgz) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left [Char]
tgz)
RemoteTarballPackage {} -> forall {a}. IO a
death
RepoTarballPackage {} -> forall {a}. IO a
death
let
write :: [Char] -> IO ()
write [Char]
str
| [Char]
outputFile forall a. Eq a => a -> a -> Bool
== [Char]
"-" = [Char] -> IO ()
putStr (Verbosity -> [Char] -> [Char]
withOutputMarker Verbosity
verbosity [Char]
str)
| Bool
otherwise = do
[Char] -> [Char] -> IO ()
writeFile [Char]
outputFile [Char]
str
Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Wrote source list to " forall a. [a] -> [a] -> [a]
++ [Char]
outputFile forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
writeLBS :: ByteString -> IO ()
writeLBS ByteString
lbs
| [Char]
outputFile forall a. Eq a => a -> a -> Bool
== [Char]
"-" = ByteString -> IO ()
BSL.putStr ByteString
lbs
| Bool
otherwise = do
[Char] -> ByteString -> IO ()
BSL.writeFile [Char]
outputFile ByteString
lbs
Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Wrote tarball sdist to " forall a. [a] -> [a] -> [a]
++ [Char]
outputFile forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
case Either [Char] [Char]
dir0 of
Left [Char]
tgz -> do
case OutputFormat
format of
OutputFormat
TarGzArchive -> do
ByteString -> IO ()
writeLBS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO ByteString
BSL.readFile [Char]
tgz
OutputFormat
_ -> forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity ([Char]
"cannot convert tarball package to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show OutputFormat
format)
Right [Char]
dir -> case OutputFormat
format of
SourceList Char
nulSep -> do
let gpd :: GenericPackageDescription
gpd :: GenericPackageDescription
gpd = forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg
let thisDie :: Verbosity -> String -> IO a
thisDie :: forall a. Verbosity -> [Char] -> IO a
thisDie Verbosity
v [Char]
s = forall a. Verbosity -> [Char] -> IO a
die' Verbosity
v forall a b. (a -> b) -> a -> b
$ [Char]
"sdist of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd) forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
s
LFlags
files' <- Verbosity
-> (Verbosity -> [Char] -> IO LFlags)
-> [Char]
-> PackageDescription
-> [PPSuffixHandler]
-> IO LFlags
listPackageSourcesWithDie Verbosity
verbosity forall a. Verbosity -> [Char] -> IO a
thisDie [Char]
dir (GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd) [PPSuffixHandler]
knownSuffixHandlers
let files :: LFlags
files = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
normalise LFlags
files'
let prefix :: [Char]
prefix = [Char] -> [Char] -> [Char]
makeRelative [Char]
projectRootDir [Char]
dir
[Char] -> IO ()
write forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
prefix [Char] -> [Char] -> [Char]
</> [Char]
i forall a. [a] -> [a] -> [a]
++ [Char
nulSep] | [Char]
i <- LFlags
files]
OutputFormat
TarGzArchive -> do
Verbosity -> GenericPackageDescription -> [Char] -> IO ByteString
packageDirToSdist Verbosity
verbosity (forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg) [Char]
dir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
writeLBS
reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]
reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage]
-> [TargetSelector]
-> Either [TargetProblem] [UnresolvedSourcePackage]
reifyTargetSelectors [PackageSpecifier UnresolvedSourcePackage]
pkgs [TargetSelector]
sels =
case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
go [TargetSelector]
sels) of
([], [UnresolvedSourcePackage]
sels') -> forall a b. b -> Either a b
Right [UnresolvedSourcePackage]
sels'
([TargetProblem]
errs, [UnresolvedSourcePackage]
_) -> forall a b. a -> Either a b
Left [TargetProblem]
errs
where
flatten :: PackageSpecifier (SourcePackage loc) -> Maybe (SourcePackage loc)
flatten (SpecificSourcePackage pkg :: SourcePackage loc
pkg@SourcePackage{}) = forall a. a -> Maybe a
Just SourcePackage loc
pkg
flatten PackageSpecifier (SourcePackage loc)
_ = forall a. Maybe a
Nothing
pkgs' :: [UnresolvedSourcePackage]
pkgs' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {loc}.
PackageSpecifier (SourcePackage loc) -> Maybe (SourcePackage loc)
flatten [PackageSpecifier UnresolvedSourcePackage]
pkgs
getPkg :: PackageIdentifier -> Either a UnresolvedSourcePackage
getPkg PackageIdentifier
pid = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [UnresolvedSourcePackage]
pkgs' of
Just UnresolvedSourcePackage
pkg -> forall a b. b -> Either a b
Right UnresolvedSourcePackage
pkg
Maybe UnresolvedSourcePackage
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened: we have a reference to a local package that isn't in localPackages."
go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
go (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
pids Maybe ComponentKindFilter
Nothing) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. PackageIdentifier -> Either a UnresolvedSourcePackage
getPkg [PackageIdentifier]
pids
go (TargetAllPackages Maybe ComponentKindFilter
Nothing) = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnresolvedSourcePackage]
pkgs'
go (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
_ (Just ComponentKindFilter
kind)) = [forall a b. a -> Either a b
Left (ComponentKindFilter -> TargetProblem
AllComponentsOnly ComponentKindFilter
kind)]
go (TargetAllPackages (Just ComponentKindFilter
kind)) = [forall a b. a -> Either a b
Left (ComponentKindFilter -> TargetProblem
AllComponentsOnly ComponentKindFilter
kind)]
go (TargetPackageNamed PackageName
pname Maybe ComponentKindFilter
_) = [forall a b. a -> Either a b
Left (PackageName -> TargetProblem
NonlocalPackageNotAllowed PackageName
pname)]
go (TargetComponentUnknown PackageName
pname Either UnqualComponentName ComponentName
_ SubComponentTarget
_) = [forall a b. a -> Either a b
Left (PackageName -> TargetProblem
NonlocalPackageNotAllowed PackageName
pname)]
go (TargetComponent PackageIdentifier
_ ComponentName
cname SubComponentTarget
_) = [forall a b. a -> Either a b
Left (ComponentName -> TargetProblem
ComponentsNotAllowed ComponentName
cname)]
data TargetProblem = AllComponentsOnly ComponentKind
| NonlocalPackageNotAllowed PackageName
| ComponentsNotAllowed ComponentName
renderTargetProblem :: TargetProblem -> String
renderTargetProblem :: TargetProblem -> [Char]
renderTargetProblem (AllComponentsOnly ComponentKindFilter
kind) =
[Char]
"It is not possible to package only the " forall a. [a] -> [a] -> [a]
++ Plural -> ComponentKindFilter -> [Char]
renderComponentKind Plural
Plural ComponentKindFilter
kind forall a. [a] -> [a] -> [a]
++ [Char]
" from a package "
forall a. [a] -> [a] -> [a]
++ [Char]
"for distribution. Only entire packages may be packaged for distribution."
renderTargetProblem (ComponentsNotAllowed ComponentName
cname) =
[Char]
"The component " forall a. [a] -> [a] -> [a]
++ ComponentName -> [Char]
showComponentName ComponentName
cname forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be packaged for distribution on its own. "
forall a. [a] -> [a] -> [a]
++ [Char]
"Only entire packages may be packaged for distribution."
renderTargetProblem (NonlocalPackageNotAllowed PackageName
pname) =
[Char]
"The package " forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
unPackageName PackageName
pname forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be packaged for distribution, because it is not "
forall a. [a] -> [a] -> [a]
++ [Char]
"local to this project."