Skip to content

Commit

Permalink
A 'cabal path' command. (#8879)
Browse files Browse the repository at this point in the history
* 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>
  • Loading branch information
athas and ulysses4ever authored Nov 13, 2023
1 parent 2dad49a commit 1908f51
Show file tree
Hide file tree
Showing 10 changed files with 176 additions and 0 deletions.
41 changes: 41 additions & 0 deletions cabal-install/src/Distribution/Client/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,8 @@ import Distribution.Client.Setup
, InitFlags (initHcPath, initVerbosity)
, InstallFlags (..)
, ListFlags (..)
, Path (..)
, PathFlags (..)
, ReportFlags (..)
, UploadFlags (..)
, UserConfigFlags (..)
Expand Down Expand Up @@ -60,6 +62,8 @@ import Distribution.Client.Setup
, listCommand
, listNeedsCompiler
, manpageCommand
, pathCommand
, pathName
, reconfigureCommand
, registerCommand
, replCommand
Expand Down Expand Up @@ -97,7 +101,11 @@ import Prelude ()
import Distribution.Client.Config
( SavedConfig (..)
, createDefaultConfigFile
, defaultCacheDir
, defaultConfigFile
, defaultInstallPath
, defaultLogsDir
, defaultStoreDir
, getConfigFilePath
, loadConfig
, userConfigDiff
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -227,6 +236,7 @@ import Distribution.Simple.Utils
, notice
, topHandler
, tryFindPackageDesc
, withOutputMarker
)
import Distribution.Text
( display
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
72 changes: 72 additions & 0 deletions cabal-install/src/Distribution/Client/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -85,6 +85,10 @@ module Distribution.Client.Setup
, cleanCommand
, copyCommand
, registerCommand
, Path (..)
, pathName
, PathFlags (..)
, pathCommand
, liftOptions
, yesNoOpt
) where
Expand Down Expand Up @@ -343,6 +347,7 @@ globalCommand commands =
++ unlines
( [ startGroup "global"
, addCmd "user-config"
, addCmd "path"
, addCmd "help"
, par
, startGroup "package database"
Expand Down Expand Up @@ -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

-- ------------------------------------------------------------
Expand Down
6 changes: 6 additions & 0 deletions cabal-testsuite/PackageTests/Path/All/cabal.out
Original file line number Diff line number Diff line change
@@ -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
3 changes: 3 additions & 0 deletions cabal-testsuite/PackageTests/Path/All/cabal.test.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
import Test.Cabal.Prelude

main = cabalTest . void $ cabal "path" []
2 changes: 2 additions & 0 deletions cabal-testsuite/PackageTests/Path/Single/cabal.out
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
# cabal path
<ROOT>/cabal.dist/home/.cabal/bin
3 changes: 3 additions & 0 deletions cabal-testsuite/PackageTests/Path/Single/cabal.test.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
import Test.Cabal.Prelude

main = cabalTest . void $ cabal "path" ["--installdir"]
1 change: 1 addition & 0 deletions cabal-testsuite/src/Test/Cabal/Prelude.hs
Original file line number Diff line number Diff line change
Expand Up @@ -295,6 +295,7 @@ cabalGArgs global_args cmd args input = do
, "info"
, "init"
, "haddock-project"
, "path"
]
= [ ]

Expand Down
12 changes: 12 additions & 0 deletions changelog.d/pr-8879
Original file line number Diff line number Diff line change
@@ -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.

}
33 changes: 33 additions & 0 deletions doc/cabal-commands.rst
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions doc/config.rst
Original file line number Diff line number Diff line change
Expand Up @@ -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
------------------------

Expand Down

0 comments on commit 1908f51

Please sign in to comment.