Skip to content

Commit

Permalink
Add a 'cabal dirs' command.
Browse files Browse the repository at this point in the history
  • Loading branch information
athas committed Mar 28, 2023
1 parent d53b4d4 commit f079b95
Show file tree
Hide file tree
Showing 2 changed files with 50 additions and 1 deletion.
16 changes: 15 additions & 1 deletion cabal-install/src/Distribution/Client/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,7 @@ import Distribution.Client.Setup
, InitFlags(initVerbosity, initHcPath), initCommand
, ActAsSetupFlags(..), actAsSetupCommand
, UserConfigFlags(..), userConfigCommand
, DirsFlags(..), dirsCommand
, reportCommand
, manpageCommand
, haddockCommand
Expand Down Expand Up @@ -70,7 +71,8 @@ import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff
, userConfigUpdate, createDefaultConfigFile, getConfigFilePath )
, userConfigUpdate, createDefaultConfigFile, getConfigFilePath
, defaultStoreDir, defaultCacheDir, defaultLogsDir )
import Distribution.Client.Targets
( readUserTargets )
import qualified Distribution.Client.List as List
Expand Down Expand Up @@ -270,6 +272,7 @@ mainWorker args = do
, regularCmd reportCommand reportAction
, regularCmd initCommand initAction
, regularCmd userConfigCommand userConfigAction
, regularCmd dirsCommand dirsAction
, regularCmd genBoundsCommand genBoundsAction
, regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
, wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
Expand Down Expand Up @@ -1011,3 +1014,14 @@ manpageAction commands flags extraArgs _ = do
then dropExtension pname
else pname
manpageCmd cabalCmd commands flags

dirsAction :: DirsFlags -> [String] -> Action
dirsAction dirsflags _extraArgs _globalFlags = do
let verbosity = fromFlag (dirsVerbosity dirsflags)
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)
35 changes: 35 additions & 0 deletions cabal-install/src/Distribution/Client/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,6 +48,7 @@ module Distribution.Client.Setup
, cleanCommand
, copyCommand
, registerCommand
, DirsFlags(..), dirsCommand

, liftOptions
, yesNoOpt
Expand Down Expand Up @@ -2415,6 +2416,40 @@ userConfigCommand = CommandUI {
}


-- ------------------------------------------------------------
-- * Dirs
-- ------------------------------------------------------------

data DirsFlags = DirsFlags {
dirsVerbosity :: Flag Verbosity
} deriving Generic

instance Monoid DirsFlags where
mempty = DirsFlags {
dirsVerbosity = toFlag normal
}
mappend = (<>)

instance Semigroup DirsFlags where
(<>) = gmappend

dirsCommand :: CommandUI DirsFlags
dirsCommand = CommandUI {
commandName = "dirs",
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 ++ " dirs\n",
commandDefaultFlags = mempty,
commandOptions = \ _ -> [
optionVerbosity dirsVerbosity (\v flags -> flags { dirsVerbosity = v })]
}


-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
Expand Down

0 comments on commit f079b95

Please sign in to comment.