diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index c7772434060..9114102f2bf 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 6d04d401a8a..e752b573aad 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/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 -- ------------------------------------------------------------ diff --git a/cabal-testsuite/PackageTests/Path/All/cabal.out b/cabal-testsuite/PackageTests/Path/All/cabal.out new file mode 100644 index 00000000000..55d8b94bc3a --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/All/cabal.out @@ -0,0 +1,6 @@ +# cabal path +cache-dir: /cabal.dist/home/.cabal/packages +logs-dir: /cabal.dist/home/.cabal/logs +store-dir: /cabal.dist/home/.cabal/store +config-file: /cabal.dist/home/.cabal/config +installdir: /cabal.dist/home/.cabal/bin diff --git a/cabal-testsuite/PackageTests/Path/All/cabal.test.hs b/cabal-testsuite/PackageTests/Path/All/cabal.test.hs new file mode 100644 index 00000000000..b8157a83ee8 --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/All/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ cabal "path" [] diff --git a/cabal-testsuite/PackageTests/Path/Single/cabal.out b/cabal-testsuite/PackageTests/Path/Single/cabal.out new file mode 100644 index 00000000000..1ae82037846 --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/Single/cabal.out @@ -0,0 +1,2 @@ +# cabal path +/cabal.dist/home/.cabal/bin diff --git a/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs b/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs new file mode 100644 index 00000000000..8eac59024f3 --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ cabal "path" ["--installdir"] diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index e0e63ac18f6..48016765e91 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -295,6 +295,7 @@ cabalGArgs global_args cmd args input = do , "info" , "init" , "haddock-project" + , "path" ] = [ ] diff --git a/changelog.d/pr-8879 b/changelog.d/pr-8879 new file mode 100644 index 00000000000..079d642289b --- /dev/null +++ b/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. + +} diff --git a/doc/cabal-commands.rst b/doc/cabal-commands.rst index 88803232bf6..05f1666279d 100644 --- a/doc/cabal-commands.rst +++ b/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 diff --git a/doc/config.rst b/doc/config.rst index d7717ca95a8..5c85498b181 100644 --- a/doc/config.rst +++ b/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 ------------------------