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