{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Distribution.Client.CmdSdist
  ( sdistCommand
  , sdistAction
  , packageToSdist
  , OutputFormat (..)
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.CmdErrorMessages
  ( Plural (..)
  , renderComponentKind
  )
import Distribution.Client.DistDirLayout
  ( DistDirLayout (..)
  , ProjectRoot (..)
  )
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , updNixStyleCommonSetupFlags
  )
import Distribution.Client.ProjectConfig
  ( ProjectConfig
  , commandLineFlagsToProjectConfig
  , projectConfigConfigFile
  , projectConfigShared
  , withGlobalConfig
  , withProjectOrGlobalConfig
  )
import Distribution.Client.ProjectFlags
  ( ProjectFlags (..)
  , defaultProjectFlags
  , projectFlagsOptions
  )
import Distribution.Client.ProjectOrchestration
  ( CurrentCommand (..)
  , ProjectBaseContext (..)
  , establishProjectBaseContext
  , establishProjectBaseContextWithRoot
  )
import Distribution.Client.Setup
  ( CommonSetupFlags (..)
  , GlobalFlags (..)
  )
import Distribution.Client.TargetSelector
  ( ComponentKind
  , TargetSelector (..)
  , readTargetSelectors
  , reportTargetSelectorProblems
  )
import Distribution.Client.Types
  ( PackageLocation (..)
  , PackageSpecifier (..)
  , UnresolvedSourcePackage
  )
import Distribution.Solver.Types.SourcePackage
  ( SourcePackage (..)
  )
import Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )

import Distribution.Client.Errors
import Distribution.Client.SrcDist
  ( packageDirToSdist
  )
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
  , ShowOrParseArgs
  , liftOptionL
  , option
  , reqArg
  )
import Distribution.Simple.PreProcess
  ( knownSuffixHandlers
  )
import Distribution.Simple.Setup
  ( Flag (..)
  , flagToList
  , flagToMaybe
  , fromFlagOrDefault
  , optionDistPref
  , optionVerbosity
  , toFlag
  , trueArg
  )
import Distribution.Simple.SrcDist
  ( listPackageSourcesWithDie
  )
import Distribution.Simple.Utils
  ( dieWithException
  , notice
  , withOutputMarker
  , wrapText
  )
import Distribution.Types.ComponentName
  ( ComponentName
  , showComponentName
  )
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import Distribution.Types.PackageName
  ( PackageName
  , unPackageName
  )
import Distribution.Verbosity
  ( normal
  )

import qualified Data.ByteString.Lazy.Char8 as BSL
import System.Directory
  ( createDirectoryIfMissing
  , getCurrentDirectory
  , 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: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-sdist [FLAGS] [PACKAGES]\n"
    , commandDescription :: Maybe ([Char] -> [Char])
commandDescription = ([Char] -> [Char]) -> Maybe ([Char] -> [Char])
forall a. a -> Maybe a
Just (([Char] -> [Char]) -> Maybe ([Char] -> [Char]))
-> ([Char] -> [Char]) -> Maybe ([Char] -> [Char])
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 = Maybe ([Char] -> [Char])
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 (f :: * -> *).
Functor f =>
LensLike f (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 (f :: * -> *).
Functor f =>
LensLike f (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 (SymbolicPath Pkg ('Dir Dist))
sdistDistDir :: Flag (SymbolicPath Pkg (Dir Dist))
  , 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 = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
normal
    , sdistDistDir :: Flag (SymbolicPath Pkg ('Dir Dist))
sdistDistDir = Flag (SymbolicPath Pkg ('Dir Dist))
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 [Char]
sdistOutputPath = Flag [Char]
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 = v})
  , (SdistFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist))
    -> SdistFlags -> SdistFlags)
-> ShowOrParseArgs
-> OptionField SdistFlags
forall flags.
(flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
      SdistFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
sdistDistDir
      (\Flag (SymbolicPath Pkg ('Dir Dist))
dd SdistFlags
flags -> SdistFlags
flags{sdistDistDir = dd})
      ShowOrParseArgs
showOrParseArgs
  , [Char]
-> LFlags
-> [Char]
-> (SdistFlags -> Flag Bool)
-> (Flag Bool -> SdistFlags -> SdistFlags)
-> MkOptDescr
     (SdistFlags -> Flag Bool)
     (Flag Bool -> SdistFlags -> SdistFlags)
     SdistFlags
-> OptionField SdistFlags
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 = v})
      MkOptDescr
  (SdistFlags -> Flag Bool)
  (Flag Bool -> SdistFlags -> SdistFlags)
  SdistFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
  , [Char]
-> LFlags
-> [Char]
-> (SdistFlags -> Flag Bool)
-> (Flag Bool -> SdistFlags -> SdistFlags)
-> MkOptDescr
     (SdistFlags -> Flag Bool)
     (Flag Bool -> SdistFlags -> SdistFlags)
     SdistFlags
-> OptionField SdistFlags
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 = v})
      MkOptDescr
  (SdistFlags -> Flag Bool)
  (Flag Bool -> SdistFlags -> SdistFlags)
  SdistFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
  , [Char]
-> LFlags
-> [Char]
-> (SdistFlags -> Flag [Char])
-> (Flag [Char] -> SdistFlags -> SdistFlags)
-> MkOptDescr
     (SdistFlags -> Flag [Char])
     (Flag [Char] -> SdistFlags -> SdistFlags)
     SdistFlags
-> OptionField SdistFlags
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 = o})
      ([Char]
-> ReadE (Flag [Char])
-> (Flag [Char] -> LFlags)
-> MkOptDescr
     (SdistFlags -> Flag [Char])
     (Flag [Char] -> SdistFlags -> SdistFlags)
     SdistFlags
forall b a.
Monoid b =>
[Char]
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg [Char]
"PATH" (([Char] -> Flag [Char]) -> ReadE (Flag [Char])
forall a. ([Char] -> a) -> ReadE a
succeedReadE [Char] -> Flag [Char]
forall a. a -> Flag a
Flag) Flag [Char] -> LFlags
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]
flagProjectDir :: Flag [Char]
flagProjectFile :: Flag [Char]
flagIgnoreProject :: Flag Bool
flagProjectDir :: ProjectFlags -> Flag [Char]
flagProjectFile :: ProjectFlags -> Flag [Char]
flagIgnoreProject :: ProjectFlags -> Flag Bool
..}, SdistFlags{Flag Bool
Flag [Char]
Flag Verbosity
Flag (SymbolicPath Pkg ('Dir Dist))
sdistVerbosity :: SdistFlags -> Flag Verbosity
sdistDistDir :: SdistFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
sdistListSources :: SdistFlags -> Flag Bool
sdistNulSeparated :: SdistFlags -> Flag Bool
sdistOutputPath :: SdistFlags -> Flag [Char]
sdistVerbosity :: Flag Verbosity
sdistDistDir :: Flag (SymbolicPath Pkg ('Dir Dist))
sdistListSources :: Flag Bool
sdistNulSeparated :: Flag Bool
sdistOutputPath :: Flag [Char]
..}) LFlags
targetStrings GlobalFlags
globalFlags = do
  (ProjectBaseContext
baseCtx, DistDirLayout
distDirLayout) <-
    Flag Bool
-> IO (ProjectBaseContext, DistDirLayout)
-> IO (ProjectBaseContext, DistDirLayout)
-> IO (ProjectBaseContext, DistDirLayout)
forall a. Flag Bool -> IO a -> IO a -> IO a
withProjectOrGlobalConfig
      Flag Bool
flagIgnoreProject
      IO (ProjectBaseContext, DistDirLayout)
withProject
      (Verbosity
-> Flag [Char]
-> (ProjectConfig -> IO (ProjectBaseContext, DistDirLayout))
-> IO (ProjectBaseContext, DistDirLayout)
forall a.
Verbosity -> Flag [Char] -> (ProjectConfig -> IO a) -> IO a
withGlobalConfig Verbosity
verbosity Flag [Char]
globalConfigFlag 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 a. a -> IO a
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 [Char]
mOutputPath' <- case Maybe [Char]
mOutputPath of
    Just [Char]
"-" -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
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
      Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
abspath)
    Maybe [Char]
Nothing -> do
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (DistDirLayout -> [Char]
distSdistDirectory DistDirLayout
distDirLayout)
      Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"-" -> [Char]
"-"
          | Bool
otherwise -> [Char]
path [Char] -> [Char] -> [Char]
</> PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (pkg -> PackageIdentifier
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 (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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ LFlags -> CabalInstallException
SdistActionException (LFlags -> CabalInstallException)
-> ([TargetProblem] -> LFlags)
-> [TargetProblem]
-> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetProblem -> [Char]) -> [TargetProblem] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TargetProblem -> [Char]
renderTargetProblem ([TargetProblem] -> CabalInstallException)
-> [TargetProblem] -> CabalInstallException
forall a b. (a -> b) -> a -> b
$ [TargetProblem]
errs
    Right [UnresolvedSourcePackage]
pkgs
      | [UnresolvedSourcePackage] -> Int
forall a. [a] -> 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 [Char]
"-" <- Maybe [Char]
mOutputPath' ->
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
Can'tWriteMultipleTarballs
      | Bool
otherwise ->
          [UnresolvedSourcePackage]
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [UnresolvedSourcePackage]
pkgs ((UnresolvedSourcePackage -> IO ()) -> IO ())
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UnresolvedSourcePackage
pkg ->
            Verbosity
-> [Char]
-> OutputFormat
-> [Char]
-> UnresolvedSourcePackage
-> IO ()
packageToSdist
              Verbosity
verbosity
              (DistDirLayout -> [Char]
distProjectRootDirectory DistDirLayout
distDirLayout)
              OutputFormat
format
              (UnresolvedSourcePackage -> [Char]
forall {pkg}. Package pkg => pkg -> [Char]
outputPath UnresolvedSourcePackage
pkg)
              UnresolvedSourcePackage
pkg
  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 [Char]
mOutputPath = Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe Flag [Char]
sdistOutputPath

    prjConfig :: ProjectConfig
    prjConfig :: ProjectConfig
prjConfig =
      GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
        GlobalFlags
globalFlags
        ((CommonSetupFlags -> CommonSetupFlags)
-> NixStyleFlags () -> NixStyleFlags ()
forall a.
(CommonSetupFlags -> CommonSetupFlags)
-> NixStyleFlags a -> NixStyleFlags a
updNixStyleCommonSetupFlags (CommonSetupFlags -> CommonSetupFlags -> CommonSetupFlags
forall a b. a -> b -> a
const CommonSetupFlags
commonFlags) (NixStyleFlags () -> NixStyleFlags ())
-> NixStyleFlags () -> NixStyleFlags ()
forall a b. (a -> b) -> a -> b
$ () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ())
          { projectFlags = pf
          }
        ClientInstallFlags
forall a. Monoid a => a
mempty
    commonFlags :: CommonSetupFlags
commonFlags =
      CommonSetupFlags
forall a. Monoid a => a
mempty
        { setupVerbosity = sdistVerbosity
        , setupDistPref = sdistDistDir
        }

    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
      (ProjectBaseContext, DistDirLayout)
-> IO (ProjectBaseContext, DistDirLayout)
forall a. a -> IO a
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 ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
prjConfig) ([Char] -> ProjectRoot
ProjectRootImplicit [Char]
cwd) CurrentCommand
OtherCommand
      (ProjectBaseContext, DistDirLayout)
-> IO (ProjectBaseContext, DistDirLayout)
forall a. a -> IO a
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]
(Int -> OutputFormat -> [Char] -> [Char])
-> (OutputFormat -> [Char])
-> ([OutputFormat] -> [Char] -> [Char])
-> Show OutputFormat
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> OutputFormat -> [Char] -> [Char]
showsPrec :: Int -> OutputFormat -> [Char] -> [Char]
$cshow :: OutputFormat -> [Char]
show :: OutputFormat -> [Char]
$cshowList :: [OutputFormat] -> [Char] -> [Char]
showList :: [OutputFormat] -> [Char] -> [Char]
Show, OutputFormat -> OutputFormat -> Bool
(OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool) -> Eq OutputFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputFormat -> OutputFormat -> Bool
== :: OutputFormat -> OutputFormat -> Bool
$c/= :: OutputFormat -> OutputFormat -> Bool
/= :: 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 = Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a) -> CabalInstallException -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalInstallException
ImpossibleHappened (UnresolvedSourcePackage -> [Char]
forall a. Show a => a -> [Char]
show UnresolvedSourcePackage
pkg)
  Either [Char] [Char]
dir0 <- case UnresolvedSourcePackage -> PackageLocation (Maybe [Char])
forall loc. SourcePackage loc -> loc
srcpkgSource UnresolvedSourcePackage
pkg of
    LocalUnpackedPackage [Char]
path -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
path)
    RemoteSourceRepoPackage SourceRepoMaybe
_ (Just [Char]
tgz) -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
tgz)
    RemoteSourceRepoPackage{} -> IO (Either [Char] [Char])
forall {a}. IO a
death
    LocalTarballPackage [Char]
tgz -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
tgz)
    RemoteTarballPackage URI
_ (Just [Char]
tgz) -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
tgz)
    RemoteTarballPackage{} -> IO (Either [Char] [Char])
forall {a}. IO a
death
    RepoTarballPackage{} -> IO (Either [Char] [Char])
forall {a}. IO a
death

  let
    -- Write String to stdout or file, using the default TextEncoding.
    write :: [Char] -> IO ()
write [Char]
str
      | [Char]
outputFile [Char] -> [Char] -> Bool
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Wrote source list to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
outputFile [Char] -> [Char] -> [Char]
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 [Char] -> [Char] -> Bool
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Wrote tarball sdist to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
outputFile [Char] -> [Char] -> [Char]
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 (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO ByteString
BSL.readFile [Char]
tgz
        OutputFormat
_ -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalInstallException
CannotConvertTarballPackage (OutputFormat -> [Char]
forall a. Show a => a -> [Char]
show OutputFormat
format)
    Right [Char]
dir -> do
      case OutputFormat
format of
        SourceList Char
nulSep -> do
          let gpd :: GenericPackageDescription
              gpd :: GenericPackageDescription
gpd = UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg

          [SymbolicPath Pkg 'File]
files' <- Verbosity
-> (forall res. Verbosity -> CabalException -> IO [res])
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDescription
-> [PPSuffixHandler]
-> IO [SymbolicPath Pkg 'File]
listPackageSourcesWithDie Verbosity
verbosity Verbosity -> CabalException -> IO [res]
forall res. Verbosity -> CabalException -> IO [res]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just (SymbolicPath CWD ('Dir Pkg)
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> SymbolicPath CWD ('Dir Pkg)
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ [Char] -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
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
$ (SymbolicPath Pkg 'File -> [Char])
-> [SymbolicPath Pkg 'File] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
normalise ([Char] -> [Char])
-> (SymbolicPath Pkg 'File -> [Char])
-> SymbolicPath Pkg 'File
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath) [SymbolicPath Pkg 'File]
files'
          let prefix :: [Char]
prefix = [Char] -> [Char] -> [Char]
makeRelative ([Char] -> [Char]
normalise [Char]
projectRootDir) [Char]
dir
          [Char] -> IO ()
write ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ LFlags -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
prefix [Char] -> [Char] -> [Char]
</> [Char]
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
nulSep] | [Char]
i <- LFlags
files]
        OutputFormat
TarGzArchive -> do
          Verbosity -> GenericPackageDescription -> [Char] -> IO ByteString
packageDirToSdist Verbosity
verbosity (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg) [Char]
dir IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 m a. Monoid m => (a -> m) -> [a] -> m
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 -> [Char] -> Either a UnresolvedSourcePackage
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) = (PackageIdentifier -> Either TargetProblem UnresolvedSourcePackage)
-> [PackageIdentifier]
-> [Either TargetProblem UnresolvedSourcePackage]
forall a b. (a -> b) -> [a] -> [b]
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 -> [Char]
renderTargetProblem (AllComponentsOnly ComponentKindFilter
kind) =
  [Char]
"It is not possible to package only the "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Plural -> ComponentKindFilter -> [Char]
renderComponentKind Plural
Plural ComponentKindFilter
kind
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from a package "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"for distribution. Only entire packages may be packaged for distribution."
renderTargetProblem (ComponentsNotAllowed ComponentName
cname) =
  [Char]
"The component "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ComponentName -> [Char]
showComponentName ComponentName
cname
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be packaged for distribution on its own. "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Only entire packages may be packaged for distribution."
renderTargetProblem (NonlocalPackageNotAllowed PackageName
pname) =
  [Char]
"The package "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
unPackageName PackageName
pname
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be packaged for distribution, because it is not "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"local to this project."