From 9f73a6d968ca9a3de7dcb9945433d58d7b1a25ff Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Tue, 28 Mar 2023 17:49:06 +0200 Subject: [PATCH 01/16] Add a 'cabal path' command. --- cabal-install/src/Distribution/Client/Main.hs | 17 +++++++++ .../src/Distribution/Client/Setup.hs | 38 +++++++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 1a46893c9b8..7ea4e1a0484 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -36,6 +36,7 @@ import Distribution.Client.Setup , ReportFlags (..) , UploadFlags (..) , UserConfigFlags (..) + , PathFlags (..) , actAsSetupCommand , benchmarkCommand , buildCommand @@ -69,6 +70,7 @@ import Distribution.Client.Setup , unpackCommand , uploadCommand , userConfigCommand + , pathCommand , withRepoContext ) import Distribution.Simple.Setup @@ -102,6 +104,9 @@ import Distribution.Client.Config , loadConfig , userConfigDiff , userConfigUpdate + , defaultCacheDir + , defaultLogsDir + , defaultStoreDir ) import qualified Distribution.Client.List as List ( info @@ -368,6 +373,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 @@ -1320,3 +1326,14 @@ 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) + cfg <- loadConfig verbosity mempty + putStrLn . ("cache-dir: "++) =<< maybe defaultCacheDir pure + (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) + putStrLn . ("logs-dir: "++) =<< maybe defaultLogsDir pure + (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) + putStrLn . ("store-dir: "++) =<< maybe defaultStoreDir pure + (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 6d04d401a8a..64a32a3760c 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -85,6 +85,8 @@ module Distribution.Client.Setup , cleanCommand , copyCommand , registerCommand + , PathFlags (..) + , pathCommand , liftOptions , yesNoOpt ) where @@ -3322,6 +3324,42 @@ userConfigCommand = -- ------------------------------------------------------------ +-- * Dirs + +-- ------------------------------------------------------------ + +data PathFlags = PathFlags { + pathVerbosity :: Flag Verbosity + } deriving Generic + +instance Monoid PathFlags where + mempty = PathFlags { + pathVerbosity = toFlag normal + } + mappend = (<>) + +instance Semigroup PathFlags where + (<>) = gmappend + +pathCommand :: CommandUI PathFlags +pathCommand = CommandUI { + commandName = "path", + commandSynopsis = "Display the directories 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 = \ _ -> [ + optionVerbosity pathVerbosity (\v flags -> flags { pathVerbosity = v })] + } + + +-- ------------------------------------------------------------ + -- * GetOpt Utils -- ------------------------------------------------------------ From c2c3c6086ead24bf5f76cfc0281271cb420523eb Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:15:49 +0200 Subject: [PATCH 02/16] Formatting fix. --- cabal-install/src/Distribution/Client/Main.hs | 37 +++++++++------ .../src/Distribution/Client/Setup.hs | 47 ++++++++++--------- 2 files changed, 48 insertions(+), 36 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 7ea4e1a0484..2bfecd5a337 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -33,10 +33,10 @@ import Distribution.Client.Setup , InitFlags (initHcPath, initVerbosity) , InstallFlags (..) , ListFlags (..) + , PathFlags (..) , ReportFlags (..) , UploadFlags (..) , UserConfigFlags (..) - , PathFlags (..) , actAsSetupCommand , benchmarkCommand , buildCommand @@ -61,6 +61,7 @@ import Distribution.Client.Setup , listCommand , listNeedsCompiler , manpageCommand + , pathCommand , reconfigureCommand , registerCommand , replCommand @@ -70,7 +71,6 @@ import Distribution.Client.Setup , unpackCommand , uploadCommand , userConfigCommand - , pathCommand , withRepoContext ) import Distribution.Simple.Setup @@ -99,14 +99,14 @@ import Prelude () import Distribution.Client.Config ( SavedConfig (..) , createDefaultConfigFile + , defaultCacheDir , defaultConfigFile + , defaultLogsDir + , defaultStoreDir , getConfigFilePath , loadConfig , userConfigDiff , userConfigUpdate - , defaultCacheDir - , defaultLogsDir - , defaultStoreDir ) import qualified Distribution.Client.List as List ( info @@ -436,7 +436,7 @@ hiddenCmd ui action = HiddenCommand wrapperCmd - :: Monoid flags + :: (Monoid flags) => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) @@ -445,7 +445,7 @@ wrapperCmd ui verbosity distPref = CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand wrapperAction - :: Monoid flags + :: (Monoid flags) => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) @@ -1329,11 +1329,20 @@ manpageAction commands flags extraArgs _ = do pathAction :: PathFlags -> [String] -> Action pathAction pathflags _extraArgs _globalFlags = do - let verbosity = fromFlag (pathVerbosity pathflags) + let verbosity = fromFlag (pathVerbosity pathflags) cfg <- loadConfig verbosity mempty - putStrLn . ("cache-dir: "++) =<< maybe defaultCacheDir pure - (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) - putStrLn . ("logs-dir: "++) =<< maybe defaultLogsDir pure - (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) - putStrLn . ("store-dir: "++) =<< maybe defaultStoreDir pure - (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) + putStrLn . ("cache-dir: " ++) + =<< maybe + defaultCacheDir + pure + (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) + putStrLn . ("logs-dir: " ++) + =<< maybe + defaultLogsDir + pure + (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) + putStrLn . ("store-dir: " ++) + =<< maybe + defaultStoreDir + pure + (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 64a32a3760c..fc13b847915 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -984,7 +984,7 @@ writeGhcEnvironmentFilesPolicyPrinter = \case (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] NoFlag -> [] -relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) +relaxDepsParser :: (CabalParsing m) => m (Maybe RelaxDeps) relaxDepsParser = do rs <- P.sepBy parsec (P.char ',') if null rs @@ -3328,35 +3328,38 @@ userConfigCommand = -- ------------------------------------------------------------ -data PathFlags = PathFlags { - pathVerbosity :: Flag Verbosity - } deriving Generic +data PathFlags = PathFlags + { pathVerbosity :: Flag Verbosity + } + deriving (Generic) instance Monoid PathFlags where - mempty = PathFlags { - pathVerbosity = toFlag normal - } + mempty = + PathFlags + { pathVerbosity = toFlag normal + } mappend = (<>) instance Semigroup PathFlags where (<>) = gmappend pathCommand :: CommandUI PathFlags -pathCommand = CommandUI { - commandName = "path", - commandSynopsis = "Display the directories 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 = \ _ -> [ - optionVerbosity pathVerbosity (\v flags -> flags { pathVerbosity = v })] - } - +pathCommand = + CommandUI + { commandName = "path" + , commandSynopsis = "Display the directories 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 = \_ -> + [ optionVerbosity pathVerbosity (\v flags -> flags{pathVerbosity = v}) + ] + } -- ------------------------------------------------------------ From 6e7eb10a3470bc825d70fa26012e0a2e987edb26 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:20:12 +0200 Subject: [PATCH 03/16] Another formatting fix. --- cabal-install/src/Distribution/Client/Main.hs | 4 ++-- cabal-install/src/Distribution/Client/Setup.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 2bfecd5a337..2297a78ba70 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -436,7 +436,7 @@ hiddenCmd ui action = HiddenCommand wrapperCmd - :: (Monoid flags) + :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) @@ -445,7 +445,7 @@ wrapperCmd ui verbosity distPref = CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand wrapperAction - :: (Monoid flags) + :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index fc13b847915..04c811b0aef 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -984,7 +984,7 @@ writeGhcEnvironmentFilesPolicyPrinter = \case (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] NoFlag -> [] -relaxDepsParser :: (CabalParsing m) => m (Maybe RelaxDeps) +relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) relaxDepsParser = do rs <- P.sepBy parsec (P.char ',') if null rs From 064e68db0f23a15cdc943653fbba1724e0cd496e Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:31:39 +0200 Subject: [PATCH 04/16] Categorise "cabal path" as global command. --- cabal-install/src/Distribution/Client/Setup.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 04c811b0aef..f0ac902fea4 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -346,6 +346,7 @@ globalCommand commands = ( [ startGroup "global" , addCmd "user-config" , addCmd "help" + , addCmd "path" , par , startGroup "package database" , addCmd "update" From 6ba7f48c41740b6153e50a9183281d3b10de3a8a Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:44:44 +0200 Subject: [PATCH 05/16] Allow individual paths to be printed. --- cabal-install/src/Distribution/Client/Main.hs | 53 +++++++++++++------ .../src/Distribution/Client/Setup.hs | 14 +++++ 2 files changed, 52 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 2297a78ba70..67d01352390 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -247,6 +247,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 @@ -1331,18 +1332,40 @@ pathAction :: PathFlags -> [String] -> Action pathAction pathflags _extraArgs _globalFlags = do let verbosity = fromFlag (pathVerbosity pathflags) cfg <- loadConfig verbosity mempty - putStrLn . ("cache-dir: " ++) - =<< maybe - defaultCacheDir - pure - (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) - putStrLn . ("logs-dir: " ++) - =<< maybe - defaultLogsDir - pure - (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) - putStrLn . ("store-dir: " ++) - =<< maybe - defaultStoreDir - pure - (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) + let dirs = + [ + ( "cache-dir" + , maybe + defaultCacheDir + pure + (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) + ) + , + ( "logs-dir" + , maybe + defaultLogsDir + pure + (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) + ) + , + ( "store-dir" + , maybe + defaultStoreDir + pure + (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) + ) + ] + printDir (name, m) = putStrLn . ((name ++ ": ") ++) =<< m + -- 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_ printDir dirs + [d] -> + case lookup d dirs of + Nothing -> do + error $ "Unknown directory: " <> d + Just m -> putStrLn =<< m + ds -> mapM_ printDir $ filter ((`elem` ds) . fst) dirs diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index f0ac902fea4..24f9e5a3336 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -3331,6 +3331,7 @@ userConfigCommand = data PathFlags = PathFlags { pathVerbosity :: Flag Verbosity + , pathDirs :: Flag [String] } deriving (Generic) @@ -3338,6 +3339,7 @@ instance Monoid PathFlags where mempty = PathFlags { pathVerbosity = toFlag normal + , pathDirs = toFlag [] } mappend = (<>) @@ -3359,8 +3361,20 @@ pathCommand = , commandDefaultFlags = mempty , commandOptions = \_ -> [ optionVerbosity pathVerbosity (\v flags -> flags{pathVerbosity = v}) + , pathOption "cache-dir" + , pathOption "logs-dir" + , pathOption "store-dir" ] } + where + pathOption s = + option + [] + [s] + ("Print " <> s) + pathDirs + (\v flags -> flags{pathDirs = Flag $ concat (flagToList (pathDirs flags) ++ flagToList v)}) + (noArg (Flag [s])) -- ------------------------------------------------------------ From 680dba7d0fea7115df9406e92ae47e7124ca0e59 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:51:31 +0200 Subject: [PATCH 06/16] Less duplication. --- cabal-install/src/Distribution/Client/Main.hs | 31 ++++++------------- 1 file changed, 9 insertions(+), 22 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 67d01352390..3fc3978d5d2 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -1332,28 +1332,15 @@ pathAction :: PathFlags -> [String] -> Action pathAction pathflags _extraArgs _globalFlags = do let verbosity = fromFlag (pathVerbosity pathflags) cfg <- loadConfig verbosity mempty - let dirs = - [ - ( "cache-dir" - , maybe - defaultCacheDir - pure - (flagToMaybe $ globalCacheDir $ savedGlobalFlags cfg) - ) - , - ( "logs-dir" - , maybe - defaultLogsDir - pure - (flagToMaybe $ globalLogsDir $ savedGlobalFlags cfg) - ) - , - ( "store-dir" - , maybe - defaultStoreDir - pure - (flagToMaybe $ globalStoreDir $ savedGlobalFlags cfg) - ) + let getDir getDefault getGlobal = + maybe + getDefault + pure + (flagToMaybe $ getGlobal $ savedGlobalFlags cfg) + dirs = + [ ("cache-dir", getDir defaultCacheDir globalCacheDir) + , ("logs-dir", getDir defaultLogsDir globalLogsDir) + , ("store-dir", getDir defaultStoreDir globalStoreDir) ] printDir (name, m) = putStrLn . ((name ++ ": ") ++) =<< m -- If no paths have been requested, print all paths with labels. From 556095a137289470075e4211cde539838dafe794 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 12:54:14 +0200 Subject: [PATCH 07/16] Add config-file to "cabal path". --- cabal-install/src/Distribution/Client/Main.hs | 3 ++- cabal-install/src/Distribution/Client/Setup.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 3fc3978d5d2..66e8926e3d3 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -1329,7 +1329,7 @@ manpageAction commands flags extraArgs _ = do manpageCmd cabalCmd commands flags pathAction :: PathFlags -> [String] -> Action -pathAction pathflags _extraArgs _globalFlags = do +pathAction pathflags _extraArgs globalFlags = do let verbosity = fromFlag (pathVerbosity pathflags) cfg <- loadConfig verbosity mempty let getDir getDefault getGlobal = @@ -1341,6 +1341,7 @@ pathAction pathflags _extraArgs _globalFlags = do [ ("cache-dir", getDir defaultCacheDir globalCacheDir) , ("logs-dir", getDir defaultLogsDir globalLogsDir) , ("store-dir", getDir defaultStoreDir globalStoreDir) + , ("config-file", getConfigFilePath (globalConfigFile globalFlags)) ] printDir (name, m) = putStrLn . ((name ++ ": ") ++) =<< m -- If no paths have been requested, print all paths with labels. diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 24f9e5a3336..ec452aa42ba 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -3364,6 +3364,7 @@ pathCommand = , pathOption "cache-dir" , pathOption "logs-dir" , pathOption "store-dir" + , pathOption "config-file" ] } where From c8fe2ecbdfd172a9e073efc576d4cde67fb6b76d Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Wed, 18 Oct 2023 16:17:05 +0200 Subject: [PATCH 08/16] Use sum type instead of strings. --- cabal-install/src/Distribution/Client/Main.hs | 29 +++++++++-------- .../src/Distribution/Client/Setup.hs | 31 +++++++++++++------ 2 files changed, 36 insertions(+), 24 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 66e8926e3d3..a21a5b8ee9b 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -33,6 +33,7 @@ import Distribution.Client.Setup , InitFlags (initHcPath, initVerbosity) , InstallFlags (..) , ListFlags (..) + , Path (..) , PathFlags (..) , ReportFlags (..) , UploadFlags (..) @@ -62,6 +63,7 @@ import Distribution.Client.Setup , listNeedsCompiler , manpageCommand , pathCommand + , pathName , reconfigureCommand , registerCommand , replCommand @@ -1329,31 +1331,28 @@ manpageAction commands flags extraArgs _ = do manpageCmd cabalCmd commands flags pathAction :: PathFlags -> [String] -> Action -pathAction pathflags _extraArgs globalFlags = do +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) - dirs = - [ ("cache-dir", getDir defaultCacheDir globalCacheDir) - , ("logs-dir", getDir defaultLogsDir globalLogsDir) - , ("store-dir", getDir defaultStoreDir globalStoreDir) - , ("config-file", getConfigFilePath (globalConfigFile globalFlags)) - ] - printDir (name, m) = putStrLn . ((name ++ ": ") ++) =<< m + getSomeDir PathCacheDir = getDir defaultCacheDir globalCacheDir + getSomeDir PathLogsDir = getDir defaultLogsDir globalLogsDir + getSomeDir PathStoreDir = getDir defaultStoreDir globalStoreDir + getSomeDir PathConfigFile = getConfigFilePath (globalConfigFile globalFlags) + printPath p = putStrLn . ((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_ printDir dirs - [d] -> - case lookup d dirs of - Nothing -> do - error $ "Unknown directory: " <> d - Just m -> putStrLn =<< m - ds -> mapM_ printDir $ filter ((`elem` ds) . fst) dirs + [] -> mapM_ printPath [minBound .. maxBound] + [d] -> putStrLn =<< 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 ec452aa42ba..c1e3af4b1d4 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -85,6 +85,8 @@ module Distribution.Client.Setup , cleanCommand , copyCommand , registerCommand + , Path (..) + , pathName , PathFlags (..) , pathCommand , liftOptions @@ -3329,9 +3331,24 @@ userConfigCommand = -- ------------------------------------------------------------ +-- | A path that can be retrieved by the @cabal path@ command. +data Path + = PathCacheDir + | PathLogsDir + | PathStoreDir + | PathConfigFile + 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" + data PathFlags = PathFlags { pathVerbosity :: Flag Verbosity - , pathDirs :: Flag [String] + , pathDirs :: Flag [Path] } deriving (Generic) @@ -3360,19 +3377,15 @@ pathCommand = , commandUsage = \pname -> "Usage: " ++ pname ++ " path\n" , commandDefaultFlags = mempty , commandOptions = \_ -> - [ optionVerbosity pathVerbosity (\v flags -> flags{pathVerbosity = v}) - , pathOption "cache-dir" - , pathOption "logs-dir" - , pathOption "store-dir" - , pathOption "config-file" - ] + map pathOption [minBound .. maxBound] + ++ [optionVerbosity pathVerbosity (\v flags -> flags{pathVerbosity = v})] } where pathOption s = option [] - [s] - ("Print " <> s) + [pathName s] + ("Print " <> pathName s) pathDirs (\v flags -> flags{pathDirs = Flag $ concat (flagToList (pathDirs flags) ++ flagToList v)}) (noArg (Flag [s])) From 965484c42333680f72f0b1c47ed8baca50d561a2 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 12:17:23 +0200 Subject: [PATCH 09/16] cabal path: support --installdir. --- cabal-install/src/Distribution/Client/Main.hs | 4 ++++ cabal-install/src/Distribution/Client/Setup.hs | 2 ++ 2 files changed, 6 insertions(+) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index a21a5b8ee9b..71e644a5164 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -105,6 +105,7 @@ import Distribution.Client.Config , defaultConfigFile , defaultLogsDir , defaultStoreDir + , defaultInstallPath , getConfigFilePath , loadConfig , userConfigDiff @@ -150,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) @@ -1346,6 +1348,8 @@ pathAction pathflags extraArgs globalFlags = do 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 . ((pathName p ++ ": ") ++) =<< getSomeDir p -- If no paths have been requested, print all paths with labels. -- diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index c1e3af4b1d4..d622ebf4d8b 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -3337,6 +3337,7 @@ data Path | PathLogsDir | PathStoreDir | PathConfigFile + | PathInstallDir deriving (Eq, Ord, Show, Enum, Bounded) -- | The configuration name for this path. @@ -3345,6 +3346,7 @@ 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 From c087ccd970cd561afd153256e1d3fa0550bcac18 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 12:25:16 +0200 Subject: [PATCH 10/16] Add documentation. --- doc/cabal-commands.rst | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) 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 From f7bc0a5ac37f03a8b8c8a1326c87500476ae0b9e Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 12:26:00 +0200 Subject: [PATCH 11/16] Better text. --- cabal-install/src/Distribution/Client/Setup.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index d622ebf4d8b..e752b573aad 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -347,8 +347,8 @@ globalCommand commands = ++ unlines ( [ startGroup "global" , addCmd "user-config" - , addCmd "help" , addCmd "path" + , addCmd "help" , par , startGroup "package database" , addCmd "update" @@ -3369,7 +3369,7 @@ pathCommand :: CommandUI PathFlags pathCommand = CommandUI { commandName = "path" - , commandSynopsis = "Display the directories used by cabal" + , commandSynopsis = "Display paths used by cabal" , commandDescription = Just $ \_ -> wrapText $ "This command prints the directories that are used by cabal," From bdb62ae432930cf5e1beb89adfaf1635b95e31f7 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 12:28:58 +0200 Subject: [PATCH 12/16] Formatting. --- cabal-install/src/Distribution/Client/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 71e644a5164..b91788ee90e 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -103,9 +103,9 @@ import Distribution.Client.Config , createDefaultConfigFile , defaultCacheDir , defaultConfigFile + , defaultInstallPath , defaultLogsDir , defaultStoreDir - , defaultInstallPath , getConfigFilePath , loadConfig , userConfigDiff From 434cd986e872e3b4d89449989af34f49f567bb20 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 15:16:44 +0200 Subject: [PATCH 13/16] Add some tests. --- cabal-testsuite/PackageTests/Path/All/cabal.test.hs | 10 ++++++++++ cabal-testsuite/PackageTests/Path/Single/cabal.test.hs | 7 +++++++ 2 files changed, 17 insertions(+) create mode 100644 cabal-testsuite/PackageTests/Path/All/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/Path/Single/cabal.test.hs 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..c04f06c6443 --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/All/cabal.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + res <- cabal_raw' ["path"] Nothing + + assertOutputContains "config-file:" res + assertOutputContains "installdir:" res + assertOutputContains "cache-dir:" res + assertOutputContains "logs-dir:" res + assertOutputContains "store-dir:" res 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..02f276764b1 --- /dev/null +++ b/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +main = cabalTest . void $ do + res <- cabal_raw' ["path", "--installdir"] Nothing + + assertOutputDoesNotContain "installdir:" res + assertOutputContains "cabal/cabal-testsuite/PackageTests/Path/Single/cabal.dist/home/.cabal" res From 9cf6f6602431e9cc547bb97ed7e7ae192b34d4e6 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Thu, 19 Oct 2023 15:29:32 +0200 Subject: [PATCH 14/16] Improve tests. --- cabal-install/src/Distribution/Client/Main.hs | 5 +++-- cabal-testsuite/PackageTests/Path/All/cabal.out | 6 ++++++ cabal-testsuite/PackageTests/Path/All/cabal.test.hs | 9 +-------- cabal-testsuite/PackageTests/Path/Single/cabal.out | 2 ++ cabal-testsuite/PackageTests/Path/Single/cabal.test.hs | 6 +----- cabal-testsuite/src/Test/Cabal/Prelude.hs | 1 + 6 files changed, 14 insertions(+), 15 deletions(-) create mode 100644 cabal-testsuite/PackageTests/Path/All/cabal.out create mode 100644 cabal-testsuite/PackageTests/Path/Single/cabal.out diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index b91788ee90e..b5d0effbeb7 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -236,6 +236,7 @@ import Distribution.Simple.Utils , notice , topHandler , tryFindPackageDesc + , withOutputMarker ) import Distribution.Text ( display @@ -1350,7 +1351,7 @@ pathAction pathflags extraArgs globalFlags = do getSomeDir PathConfigFile = getConfigFilePath (globalConfigFile globalFlags) getSomeDir PathInstallDir = fromFlagOrDefault defaultInstallPath (pure <$> cinstInstalldir (savedClientInstallFlags cfg)) - printPath p = putStrLn . ((pathName p ++ ": ") ++) =<< getSomeDir p + 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. @@ -1358,5 +1359,5 @@ pathAction pathflags extraArgs globalFlags = do -- If multiple paths have been requested, print each of them with labels. case fromFlag $ pathDirs pathflags of [] -> mapM_ printPath [minBound .. maxBound] - [d] -> putStrLn =<< getSomeDir d + [d] -> putStrLn . withOutputMarker verbosity =<< getSomeDir d ds -> mapM_ printPath ds 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 index c04f06c6443..b8157a83ee8 100644 --- a/cabal-testsuite/PackageTests/Path/All/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Path/All/cabal.test.hs @@ -1,10 +1,3 @@ import Test.Cabal.Prelude -main = cabalTest . void $ do - res <- cabal_raw' ["path"] Nothing - - assertOutputContains "config-file:" res - assertOutputContains "installdir:" res - assertOutputContains "cache-dir:" res - assertOutputContains "logs-dir:" res - assertOutputContains "store-dir:" res +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 index 02f276764b1..8eac59024f3 100644 --- a/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Path/Single/cabal.test.hs @@ -1,7 +1,3 @@ import Test.Cabal.Prelude -main = cabalTest . void $ do - res <- cabal_raw' ["path", "--installdir"] Nothing - - assertOutputDoesNotContain "installdir:" res - assertOutputContains "cabal/cabal-testsuite/PackageTests/Path/Single/cabal.dist/home/.cabal" res +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" ] = [ ] From 75a0735c98374fdbdf77bbad42d47963788e949f Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Sat, 28 Oct 2023 11:44:34 +0200 Subject: [PATCH 15/16] Add changelog entry. --- changelog.d/pr-8879 | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 changelog.d/pr-8879 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. + +} From 095263f14bfb150ac251a7815aa03e877e04afd4 Mon Sep 17 00:00:00 2001 From: Troels Henriksen Date: Tue, 31 Oct 2023 10:26:44 +0100 Subject: [PATCH 16/16] Mention "cabal path" in directory documentation. --- doc/config.rst | 3 +++ 1 file changed, 3 insertions(+) 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 ------------------------