Add a 'cabal path' command.

haskell · Oct 18, 2023 · 51ca1b7 · 51ca1b7
1 parent d53b4d4
commit 51ca1b7
Show file tree

Hide file tree

Showing 2 changed files with 50 additions and 1 deletion.
diff --git 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
@@ -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
 -- ------------------------------------------------------------