A 'cabal path' command. (#8879)

* Add a 'cabal path' command.

* Formatting fix.

* Another formatting fix.

* Categorise "cabal path" as global command.

* Allow individual paths to be printed.

* Less duplication.

* Add config-file to "cabal path".

* Use sum type instead of strings.

* cabal path: support --installdir.

* Add documentation.

* Better text.

* Formatting.

* Add some tests.

* Improve tests.

* Add changelog entry.

* Mention "cabal path" in directory documentation.

---------

Co-authored-by: Artem Pelenitsyn <a.pelenitsyn@gmail.com>

cabal-install/src/Distribution/Client/Main.hs

@@ -33,6 +33,8 @@ import Distribution.Client.Setup
   , InitFlags (initHcPath, initVerbosity)
   , InstallFlags (..)
   , ListFlags (..)
+  , Path (..)
+  , PathFlags (..)
   , ReportFlags (..)
   , UploadFlags (..)
   , UserConfigFlags (..)
@@ -60,6 +62,8 @@ import Distribution.Client.Setup
   , listCommand
   , listNeedsCompiler
   , manpageCommand
+  , pathCommand
+  , pathName
   , reconfigureCommand
   , registerCommand
   , replCommand
@@ -97,7 +101,11 @@ import Prelude ()
 import Distribution.Client.Config
   ( SavedConfig (..)
   , createDefaultConfigFile
+  , defaultCacheDir
   , defaultConfigFile
+  , defaultInstallPath
+  , defaultLogsDir
+  , defaultStoreDir
   , getConfigFilePath
   , loadConfig
   , userConfigDiff
@@ -143,6 +151,7 @@ import Distribution.Client.Install (install)
 
 -- import Distribution.Client.Clean            (clean)
 
+import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (cinstInstalldir))
 import Distribution.Client.Get (get)
 import Distribution.Client.Init (initCmd)
 import Distribution.Client.Manpage (manpageCmd)
@@ -227,6 +236,7 @@ import Distribution.Simple.Utils
   , notice
   , topHandler
   , tryFindPackageDesc
+  , withOutputMarker
   )
 import Distribution.Text
   ( display
@@ -242,6 +252,7 @@ import Distribution.Version
   )
 
 import Control.Exception (AssertionFailed, assert, try)
+import Control.Monad (mapM_)
 import Data.Monoid (Any (..))
 import Distribution.Client.Errors
 import Distribution.Compat.ResponseFile
@@ -395,6 +406,7 @@ mainWorker args = do
       , regularCmd reportCommand reportAction
       , regularCmd initCommand initAction
       , regularCmd userConfigCommand userConfigAction
+      , regularCmd pathCommand pathAction
       , regularCmd genBoundsCommand genBoundsAction
       , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
       , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
@@ -1347,3 +1359,32 @@ manpageAction commands flags extraArgs _ = do
           then dropExtension pname
           else pname
   manpageCmd cabalCmd commands flags
+
+pathAction :: PathFlags -> [String] -> Action
+pathAction pathflags extraArgs globalFlags = do
+  let verbosity = fromFlag (pathVerbosity pathflags)
+  unless (null extraArgs) $
+    dieWithException verbosity $
+      ManpageAction extraArgs
+  cfg <- loadConfig verbosity mempty
+  let getDir getDefault getGlobal =
+        maybe
+          getDefault
+          pure
+          (flagToMaybe $ getGlobal $ savedGlobalFlags cfg)
+      getSomeDir PathCacheDir = getDir defaultCacheDir globalCacheDir
+      getSomeDir PathLogsDir = getDir defaultLogsDir globalLogsDir
+      getSomeDir PathStoreDir = getDir defaultStoreDir globalStoreDir
+      getSomeDir PathConfigFile = getConfigFilePath (globalConfigFile globalFlags)
+      getSomeDir PathInstallDir =
+        fromFlagOrDefault defaultInstallPath (pure <$> cinstInstalldir (savedClientInstallFlags cfg))
+      printPath p = putStrLn . withOutputMarker verbosity . ((pathName p ++ ": ") ++) =<< getSomeDir p
+  -- If no paths have been requested, print all paths with labels.
+  --
+  -- If a single path has been requested, print that path without any label.
+  --
+  -- If multiple paths have been requested, print each of them with labels.
+  case fromFlag $ pathDirs pathflags of
+    [] -> mapM_ printPath [minBound .. maxBound]
+    [d] -> putStrLn . withOutputMarker verbosity =<< getSomeDir d
+    ds -> mapM_ printPath ds

cabal-install/src/Distribution/Client/Setup.hs

@@ -85,6 +85,10 @@ module Distribution.Client.Setup
   , cleanCommand
   , copyCommand
   , registerCommand
+  , Path (..)
+  , pathName
+  , PathFlags (..)
+  , pathCommand
   , liftOptions
   , yesNoOpt
   ) where
@@ -343,6 +347,7 @@ globalCommand commands =
             ++ unlines
               ( [ startGroup "global"
                 , addCmd "user-config"
+                , addCmd "path"
                 , addCmd "help"
                 , par
                 , startGroup "package database"
@@ -3322,6 +3327,73 @@ userConfigCommand =
 
 -- ------------------------------------------------------------
 
+-- * Dirs
+
+-- ------------------------------------------------------------
+
+-- | A path that can be retrieved by the @cabal path@ command.
+data Path
+  = PathCacheDir
+  | PathLogsDir
+  | PathStoreDir
+  | PathConfigFile
+  | PathInstallDir
+  deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | The configuration name for this path.
+pathName :: Path -> String
+pathName PathCacheDir = "cache-dir"
+pathName PathLogsDir = "logs-dir"
+pathName PathStoreDir = "store-dir"
+pathName PathConfigFile = "config-file"
+pathName PathInstallDir = "installdir"
+
+data PathFlags = PathFlags
+  { pathVerbosity :: Flag Verbosity
+  , pathDirs :: Flag [Path]
+  }
+  deriving (Generic)
+
+instance Monoid PathFlags where
+  mempty =
+    PathFlags
+      { pathVerbosity = toFlag normal
+      , pathDirs = toFlag []
+      }
+  mappend = (<>)
+
+instance Semigroup PathFlags where
+  (<>) = gmappend
+
+pathCommand :: CommandUI PathFlags
+pathCommand =
+  CommandUI
+    { commandName = "path"
+    , commandSynopsis = "Display paths used by cabal"
+    , commandDescription = Just $ \_ ->
+        wrapText $
+          "This command prints the directories that are used by cabal,"
+            ++ " taking into account the contents of the configuration file and any"
+            ++ " environment variables."
+    , commandNotes = Nothing
+    , commandUsage = \pname -> "Usage: " ++ pname ++ " path\n"
+    , commandDefaultFlags = mempty
+    , commandOptions = \_ ->
+        map pathOption [minBound .. maxBound]
+          ++ [optionVerbosity pathVerbosity (\v flags -> flags{pathVerbosity = v})]
+    }
+  where
+    pathOption s =
+      option
+        []
+        [pathName s]
+        ("Print " <> pathName s)
+        pathDirs
+        (\v flags -> flags{pathDirs = Flag $ concat (flagToList (pathDirs flags) ++ flagToList v)})
+        (noArg (Flag [s]))
+
+-- ------------------------------------------------------------
+
 -- * GetOpt Utils
 
 -- ------------------------------------------------------------

cabal-testsuite/PackageTests/Path/All/cabal.out

@@ -0,0 +1,6 @@
+# cabal path
+cache-dir: <ROOT>/cabal.dist/home/.cabal/packages
+logs-dir: <ROOT>/cabal.dist/home/.cabal/logs
+store-dir: <ROOT>/cabal.dist/home/.cabal/store
+config-file: <ROOT>/cabal.dist/home/.cabal/config
+installdir: <ROOT>/cabal.dist/home/.cabal/bin

cabal-testsuite/PackageTests/Path/All/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+
+main = cabalTest . void $ cabal "path" []

cabal-testsuite/PackageTests/Path/Single/cabal.out

@@ -0,0 +1,2 @@
+# cabal path
+<ROOT>/cabal.dist/home/.cabal/bin

cabal-testsuite/PackageTests/Path/Single/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+
+main = cabalTest . void $ cabal "path" ["--installdir"]

cabal-testsuite/src/Test/Cabal/Prelude.hs

@@ -295,6 +295,7 @@ cabalGArgs global_args cmd args input = do
               , "info"
               , "init"
               , "haddock-project"
+              , "path"
               ]
           = [ ]
 

changelog.d/pr-8879

@@ -0,0 +1,12 @@
+synopsis: Add `cabal path` command
+packages: cabal-install
+prs: #8879
+
+description: {
+
+The `cabal path` command prints the file system paths used by Cabal.
+It is intended for use by tooling that needs to read or modify Cabal
+data, such that it does not need to replicate the complicated logic
+for respecting `CABAL_DIR`, `CABAL_CONFIG`, etc.
+
+}

doc/cabal-commands.rst

@@ -19,6 +19,7 @@ Commands
      [global]
       user-config            Display and update the user's global cabal configuration.
       help                   Help about commands.
+      path                   Display paths used by cabal.
 
      [package database]
       update                 Updates list of known packages.
@@ -284,6 +285,38 @@ cabal preferences. It is very useful when you are e.g. first configuring
       Note how ``--augment`` syntax follows ``cabal user-config diff``
       output.
 
+cabal path
+^^^^^^^^^^
+
+``cabal path`` prints the file system paths used by ``cabal`` for
+cache, store, installed binaries, and so on. When run without any
+options, it will show all paths, labeled with how they are namen in
+the configuration file:
+
+::
+   $ cabal path
+   cache-dir: /home/haskell/.cache/cabal/packages
+   logs-dir: /home/haskell/.cache/cabal/logs
+   store-dir: /home/haskell/.local/state/cabal/store
+   config-file: /home/haskell/.config/cabal/config
+   installdir: /home/haskell/.local/bin
+   ...
+
+If ``cabal path`` is passed a single option naming a path, then that
+path will be printed *without* any label:
+
+::
+
+   $ cabal path --installdir
+   /home/haskell/.local/bin
+
+This is a stable interface and is intended to be used for scripting.
+For example:
+
+::
+   $ ls $(cabal path --installdir)
+   ...
+
 .. _command-group-database:
 
 Package database commands

doc/config.rst

@@ -120,6 +120,9 @@ file:
 
 * ``~/.local/bin`` for executables installed with ``cabal install``.
 
+You can run ``cabal path`` to see a list of the directories that
+``cabal`` will use with the active configuration.
+
 Repository specification
 ------------------------