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

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

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

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

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

    -- elaborate path, create target directory
    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 to stdout or file, using the default TextEncoding.
        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"
        -- Write raw ByteString to stdout or file as it is, without encoding.
        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
        -- 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{}) = 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."