From 51ca1b782b4e83b20e551e12341e2bdd66e90ff7 Mon Sep 17 00:00:00 2001
From: Troels Henriksen <athas@sigkill.dk>
Date: Tue, 28 Mar 2023 17:49:06 +0200
Subject: [PATCH] Add a 'cabal path' command.

---
 cabal-install/src/Distribution/Client/Main.hs | 16 ++++++++-
 .../src/Distribution/Client/Setup.hs          | 35 +++++++++++++++++++
 2 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs
index 889fa634390..49c1c837696 100644
--- a/cabal-install/src/Distribution/Client/Main.hs
+++ b/cabal-install/src/Distribution/Client/Main.hs
@@ -43,6 +43,7 @@ import Distribution.Client.Setup
          , InitFlags(initVerbosity, initHcPath), initCommand
          , ActAsSetupFlags(..), actAsSetupCommand
          , UserConfigFlags(..), userConfigCommand
+         , PathFlags(..), pathCommand
          , reportCommand
          , manpageCommand
          , haddockCommand
@@ -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
@@ -270,6 +272,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
@@ -1011,3 +1014,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 6db91d9cf98..2774e24703b 100644
--- a/cabal-install/src/Distribution/Client/Setup.hs
+++ b/cabal-install/src/Distribution/Client/Setup.hs
@@ -48,6 +48,7 @@ module Distribution.Client.Setup
     , cleanCommand
     , copyCommand
     , registerCommand
+    , PathFlags(..), pathCommand
 
     , liftOptions
     , yesNoOpt
@@ -2415,6 +2416,40 @@ userConfigCommand = CommandUI {
   }
 
 
+-- ------------------------------------------------------------
+-- * 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
 -- ------------------------------------------------------------