From 1fa9f11f1958fab1cfa44ed3dc9d6ddfd2346d23 Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Sat, 24 Feb 2018 01:02:05 +0100
Subject: [PATCH] Add `cabal get --only-package-description`
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

With this option, 'cabal get' writes to the destination directory only the
package description already available locally in one of the repository
indices.

The basename of the file name written to inside the target directory is
the package-id rather than only the package name.

This is mostly based on #1977

Co-authored-by: Miëtek Bak <mietek@bak.io>
---
 cabal-install/Distribution/Client/Get.hs   | 35 +++++++++++++++++++---
 cabal-install/Distribution/Client/Setup.hs | 12 ++++++++
 2 files changed, 43 insertions(+), 4 deletions(-)

diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs
index c8f1f6c8b88..8871f14e40d 100644
--- a/cabal-install/Distribution/Client/Get.hs
+++ b/cabal-install/Distribution/Client/Get.hs
@@ -25,11 +25,13 @@ import Distribution.Package
 import Distribution.Simple.Setup
          ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
 import Distribution.Simple.Utils
-         ( notice, die', info, rawSystemExitCode, writeFileAtomic )
+         ( notice, die', info, warn, rawSystemExitCode, writeFileAtomic )
 import Distribution.Verbosity
          ( Verbosity )
 import Distribution.Text(display)
 import qualified Distribution.PackageDescription as PD
+import Distribution.PackageDescription.PrettyPrint
+         ( writeGenericPackageDescription )
 
 import Distribution.Client.Setup
          ( GlobalFlags(..), GetFlags(..), RepoContext(..) )
@@ -98,15 +100,24 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
   unless (null prefix) $
     createDirectoryIfMissing True prefix
 
-  if useFork
-    then fork pkgs
-    else unpack pkgs
+  if onlyPkgDescr
+    then do
+      when useFork $
+        warn verbosity $
+          "Ignoring --source-repository for --only-package-description"
+
+      mapM_ (unpackOnlyPkgDescr verbosity prefix) pkgs
+    else
+      if useFork
+        then fork pkgs
+        else unpack pkgs
 
   where
     resolverParams sourcePkgDb pkgSpecifiers =
         --TODO: add command-line constraint and preference args for unpack
         standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
 
+    onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags)
     prefix = fromFlagOrDefault "" (getDestDir getFlags)
 
     fork :: [UnresolvedSourcePackage] -> IO ()
@@ -176,6 +187,22 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
                       ++ " with the latest revision from the index."
         writeFileAtomic descFilePath pkgtxt
 
+-- | Write a @pkgId.cabal@ file with the package description to the destination
+-- directory, unless one already exists.
+unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO ()
+unpackOnlyPkgDescr verbosity dstDir pkg = do
+    let pkgFile = dstDir </> display (packageId pkg) <.> "cabal"
+    existsFile <- doesFileExist pkgFile
+    when existsFile $ die' verbosity $
+      "The file \"" ++ pkgFile ++ "\" already exists, not overwriting."
+    existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile)
+    when existsDir $ die' verbosity $
+      "A directory \"" ++ pkgFile ++ "\" is in the way, not unpacking."
+    notice verbosity $ "Writing package description to " ++ pkgFile
+    case packageDescrOverride pkg of
+      Just pkgTxt -> writeFileAtomic pkgFile pkgTxt
+      Nothing ->
+        writeGenericPackageDescription pkgFile (packageDescription pkg)
 
 -- ------------------------------------------------------------
 -- * Forking the source repository
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index 2377f6d92c9..fac0fc7cecf 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -1262,6 +1262,7 @@ instance Semigroup ReportFlags where
 
 data GetFlags = GetFlags {
     getDestDir          :: Flag FilePath,
+    getOnlyPkgDescr     :: Flag Bool,
     getPristine         :: Flag Bool,
     getIndexState       :: Flag IndexState,
     getSourceRepository :: Flag (Maybe RepoKind),
@@ -1271,6 +1272,7 @@ data GetFlags = GetFlags {
 defaultGetFlags :: GetFlags
 defaultGetFlags = GetFlags {
     getDestDir          = mempty,
+    getOnlyPkgDescr     = mempty,
     getPristine         = mempty,
     getIndexState       = mempty,
     getSourceRepository = mempty,
@@ -1324,6 +1326,16 @@ getCommand = CommandUI {
                                       (toFlag `fmap` parse))
                           (flagToList . fmap display))
 
+       , option [] ["only-package-description"]
+           "Unpack only the package description file."
+           getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v })
+           trueArg
+
+       , option [] ["package-description-only"]
+           "A synonym for --only-package-description."
+           getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v })
+           trueArg
+
        , option [] ["pristine"]
            ("Unpack the original pristine tarball, rather than updating the "
            ++ ".cabal file with the latest revision from the package archive.")