diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 222b53b9967..9de6af990d5 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -3362,6 +3362,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 -- ------------------------------------------------------------