{-# 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 )

-------------------------------------------------------------------------------
-- Command
-------------------------------------------------------------------------------

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)
    }

-------------------------------------------------------------------------------
-- Flags
-------------------------------------------------------------------------------

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)
    ]

-------------------------------------------------------------------------------
-- Action
-------------------------------------------------------------------------------

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

    -- elaborate path, create target directory
    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 String to stdout or file, using the default TextEncoding.
        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"
        -- Write raw ByteString to stdout or file as it is, without encoding.
        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
        -- there can be pkgs which are in extra-packages:
        -- these are not SpecificSourcePackage
        --
        -- Why these packages are in localPkgs, it's confusing.
        -- Anyhow, better to be lenient here.
        --
        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."