cabal-install/src/Distribution/Client/CmdPath.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -----------------------------------------------------------------------------
   9
  10 -- |
  11 -- Module      :  Distribution.Client.CmdPath
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  portable
  14 --
  15 -- Implementation of the 'path' command. Query for project configuration
  16 -- information.
  17 module Distribution.Client.CmdPath
  18   ( pathCommand
  19   , pathAction
  20   ) where
  21
  22 import Distribution.Client.Compat.Prelude
  23 import Prelude ()
  24
  25 import Distribution.Client.CmdInstall.ClientInstallFlags
  26   ( cinstInstalldir
  27   )
  28 import Distribution.Client.Config
  29   ( defaultCacheHome
  30   , defaultInstallPath
  31   , defaultStoreDir
  32   , getConfigFilePath
  33   )
  34 import Distribution.Client.DistDirLayout (CabalDirLayout (..), distProjectRootDirectory)
  35 import Distribution.Client.Errors
  36 import Distribution.Client.GlobalFlags
  37 import Distribution.Client.NixStyleOptions
  38   ( NixStyleFlags (..)
  39   , defaultNixStyleFlags
  40   , nixStyleOptions
  41   )
  42 import Distribution.Client.ProjectConfig.Types
  43   ( ProjectConfig (..)
  44   , ProjectConfigBuildOnly (..)
  45   , ProjectConfigShared (..)
  46   )
  47 import Distribution.Client.ProjectOrchestration
  48 import Distribution.Client.ProjectPlanning
  49 import Distribution.Client.RebuildMonad (runRebuild)
  50 import Distribution.Client.ScriptUtils
  51 import Distribution.Client.Setup
  52   ( ConfigFlags (..)
  53   , yesNoOpt
  54   )
  55 import Distribution.Client.Utils.Json
  56   ( (.=)
  57   )
  58 import qualified Distribution.Client.Utils.Json as Json
  59 import Distribution.Client.Version
  60   ( cabalInstallVersion
  61   )
  62 import Distribution.ReadE
  63   ( ReadE (ReadE)
  64   )
  65 import Distribution.Simple.Command
  66   ( CommandUI (..)
  67   , OptionField
  68   , ShowOrParseArgs
  69   , noArg
  70   , option
  71   , reqArg
  72   )
  73 import Distribution.Simple.Compiler
  74 import Distribution.Simple.Flag
  75   ( Flag (..)
  76   , flagToList
  77   , fromFlagOrDefault
  78   )
  79 import Distribution.Simple.Program
  80 import Distribution.Simple.Utils
  81   ( die'
  82   , dieWithException
  83   , withOutputMarker
  84   , wrapText
  85   )
  86 import Distribution.Verbosity
  87   ( normal
  88   )
  89
  90 -------------------------------------------------------------------------------
  91 -- Command
  92 -------------------------------------------------------------------------------
  93
  94 pathCommand :: CommandUI (NixStyleFlags PathFlags)
  95 pathCommand =
  96   CommandUI
  97     { commandName = "path"
  98     , commandSynopsis = "Query for simple project information."
  99     , commandDescription = Just $ \_ ->
 100         wrapText $
 101           "Query for configuration and project information such as project GHC.\n"
 102             <> "The output order of query keys is implementation defined and should not be relied on.\n"
 103     , commandNotes = Just $ \pname ->
 104         "Examples:\n"
 105           <> "  "
 106           <> pname
 107           <> " path --store-dir\n"
 108           <> "    Print the store-dir location of cabal.\n"
 109           <> "  "
 110           <> pname
 111           <> " path --output-format=json --compiler-info\n"
 112           <> "    Print compiler information in json format.\n"
 113           <> "  "
 114           <> pname
 115           <> " path --output-format=json --installdir --compiler-info\n"
 116           <> "    Print compiler information and installation directory in json format.\n"
 117           <> "  "
 118           <> pname
 119           <> " path --output-format=key-value --installdir\n"
 120           <> "    Print the installation directory, taking project information into account.\n"
 121           <> "  "
 122           <> pname
 123           <> " path -z --output-format=key-value --installdir\n"
 124           <> "    Print the installation directory, without taking project information into account.\n"
 125     , commandUsage = \pname ->
 126         "Usage: " <> pname <> " path [FLAGS]\n"
 127     , commandDefaultFlags = defaultNixStyleFlags defaultPathFlags
 128     , commandOptions = nixStyleOptions pathOptions
 129     }
 130
 131 -------------------------------------------------------------------------------
 132 -- Flags
 133 -------------------------------------------------------------------------------
 134
 135 data PathOutputFormat
 136   = JSON
 137   | KeyValue
 138   deriving (Eq, Ord, Show, Read, Enum, Bounded)
 139
 140 data PathFlags = PathFlags
 141   { pathCompiler :: Flag Bool
 142   , pathOutputFormat :: Flag PathOutputFormat
 143   , pathDirectories :: Flag [ConfigPath]
 144   }
 145   deriving (Eq, Show)
 146
 147 defaultPathFlags :: PathFlags
 148 defaultPathFlags =
 149   PathFlags
 150     { pathCompiler = mempty
 151     , pathOutputFormat = mempty
 152     , pathDirectories = mempty
 153     }
 154
 155 pathOutputFormatParser :: ReadE (Flag PathOutputFormat)
 156 pathOutputFormatParser = ReadE $ \case
 157   "json" -> Right $ Flag JSON
 158   "key-value" -> Right $ Flag KeyValue
 159   policy ->
 160     Left $
 161       "Cannot parse the status output format '"
 162         <> policy
 163         <> "'"
 164
 165 pathOutputFormatString :: PathOutputFormat -> String
 166 pathOutputFormatString JSON = "json"
 167 pathOutputFormatString KeyValue = "key-value"
 168
 169 pathOutputFormatPrinter
 170   :: Flag PathOutputFormat -> [String]
 171 pathOutputFormatPrinter = \case
 172   (Flag format) -> [pathOutputFormatString format]
 173   NoFlag -> []
 174
 175 pathOptions :: ShowOrParseArgs -> [OptionField PathFlags]
 176 pathOptions showOrParseArgs =
 177   [ option
 178       []
 179       ["output-format"]
 180       "Output format of the requested path locations"
 181       pathOutputFormat
 182       (\v flags -> flags{pathOutputFormat = v})
 183       ( reqArg
 184           (intercalate "|" $ map pathOutputFormatString [minBound .. maxBound])
 185           pathOutputFormatParser
 186           pathOutputFormatPrinter
 187       )
 188   , option
 189       []
 190       ["compiler-info"]
 191       "Print information of the project compiler"
 192       pathCompiler
 193       (\v flags -> flags{pathCompiler = v})
 194       (yesNoOpt showOrParseArgs)
 195   ]
 196     <> map pathOption [minBound .. maxBound]
 197   where
 198     pathOption s =
 199       option
 200         []
 201         [pathName s]
 202         ("Print cabal's " <> pathName s)
 203         pathDirectories
 204         (\v flags -> flags{pathDirectories = Flag $ concat (flagToList (pathDirectories flags) <> flagToList v)})
 205         (noArg (Flag [s]))
 206
 207 -- | A path that can be retrieved by the @cabal path@ command.
 208 data ConfigPath
 209   = ConfigPathCacheHome
 210   | ConfigPathRemoteRepoCache
 211   | ConfigPathLogsDir
 212   | ConfigPathStoreDir
 213   | ConfigPathConfigFile
 214   | ConfigPathInstallDir
 215   deriving (Eq, Ord, Show, Enum, Bounded)
 216
 217 -- | The configuration name for this path.
 218 pathName :: ConfigPath -> String
 219 pathName ConfigPathCacheHome = "cache-home"
 220 pathName ConfigPathRemoteRepoCache = "remote-repo-cache"
 221 pathName ConfigPathLogsDir = "logs-dir"
 222 pathName ConfigPathStoreDir = "store-dir"
 223 pathName ConfigPathConfigFile = "config-file"
 224 pathName ConfigPathInstallDir = "installdir"
 225
 226 -------------------------------------------------------------------------------
 227 -- Action
 228 -------------------------------------------------------------------------------
 229
 230 -- | Entry point for the 'path' command.
 231 pathAction :: NixStyleFlags PathFlags -> [String] -> GlobalFlags -> IO ()
 232 pathAction flags@NixStyleFlags{extraFlags = pathFlags', ..} cliTargetStrings globalFlags = withContextAndSelectors AcceptNoTargets Nothing flags [] globalFlags OtherCommand $ \_ baseCtx _ -> do
 233   let pathFlags =
 234         if pathCompiler pathFlags' == NoFlag && pathDirectories pathFlags' == NoFlag
 235           then -- if not a single key to query is given, query everything!
 236
 237             pathFlags'
 238               { pathCompiler = Flag True
 239               , pathDirectories = Flag [minBound .. maxBound]
 240               }
 241           else pathFlags'
 242   when (not $ null cliTargetStrings) $
 243     dieWithException verbosity CmdPathAcceptsNoTargets
 244   when (buildSettingDryRun (buildSettings baseCtx)) $
 245     dieWithException verbosity CmdPathCommandDoesn'tSupportDryRun
 246
 247   compilerPathOutputs <-
 248     if not $ fromFlagOrDefault False (pathCompiler pathFlags)
 249       then pure Nothing
 250       else do
 251         (compiler, _, progDb) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
 252         compilerProg <- requireCompilerProg verbosity compiler
 253         (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb
 254         pure $ Just $ mkCompilerInfo configuredCompilerProg compiler
 255
 256   paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do
 257     t <- getPathLocation baseCtx p
 258     pure (pathName p, t)
 259
 260   let pathOutputs =
 261         PathOutputs
 262           { pathOutputsCompilerInfo = compilerPathOutputs
 263           , pathOutputsConfigPaths = paths
 264           }
 265
 266   let output = case fromFlagOrDefault KeyValue (pathOutputFormat pathFlags) of
 267         JSON ->
 268           Json.encodeToString (showAsJson pathOutputs) <> "\n"
 269         KeyValue -> do
 270           showAsKeyValuePair pathOutputs
 271
 272   putStr $ withOutputMarker verbosity output
 273   where
 274     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 275
 276 -- | Find the FilePath location for common configuration paths.
 277 --
 278 -- TODO: this should come from a common source of truth to avoid code path divergence
 279 getPathLocation :: ProjectBaseContext -> ConfigPath -> IO FilePath
 280 getPathLocation _ ConfigPathCacheHome =
 281   defaultCacheHome
 282 getPathLocation baseCtx ConfigPathRemoteRepoCache =
 283   pure $ buildSettingCacheDir (buildSettings baseCtx)
 284 getPathLocation baseCtx ConfigPathLogsDir =
 285   pure $ cabalLogsDirectory (cabalDirLayout baseCtx)
 286 getPathLocation baseCtx ConfigPathStoreDir =
 287   fromFlagOrDefault
 288     defaultStoreDir
 289     (pure <$> projectConfigStoreDir (projectConfigShared (projectConfig baseCtx)))
 290 getPathLocation baseCtx ConfigPathConfigFile =
 291   getConfigFilePath (projectConfigConfigFile (projectConfigShared (projectConfig baseCtx)))
 292 getPathLocation baseCtx ConfigPathInstallDir =
 293   fromFlagOrDefault
 294     defaultInstallPath
 295     (pure <$> cinstInstalldir (projectConfigClientInstallFlags $ projectConfigBuildOnly (projectConfig baseCtx)))
 296
 297 -- ----------------------------------------------------------------------------
 298 -- Helpers for determining compiler information
 299 -- ----------------------------------------------------------------------------
 300
 301 requireCompilerProg :: Verbosity -> Compiler -> IO Program
 302 requireCompilerProg verbosity compiler =
 303   case compilerFlavor compiler of
 304     GHC -> pure ghcProgram
 305     GHCJS -> pure ghcjsProgram
 306     flavour ->
 307       die' verbosity $
 308         "path: Unsupported compiler flavour: "
 309           <> prettyShow flavour
 310
 311 -- ----------------------------------------------------------------------------
 312 -- Output
 313 -- ----------------------------------------------------------------------------
 314
 315 data PathOutputs = PathOutputs
 316   { pathOutputsCompilerInfo :: Maybe PathCompilerInfo
 317   , pathOutputsConfigPaths :: [(String, FilePath)]
 318   }
 319   deriving (Show, Eq, Ord)
 320
 321 data PathCompilerInfo = PathCompilerInfo
 322   { pathCompilerInfoFlavour :: CompilerFlavor
 323   , pathCompilerInfoId :: CompilerId
 324   , pathCompilerInfoPath :: FilePath
 325   }
 326   deriving (Show, Eq, Ord)
 327
 328 mkCompilerInfo :: ConfiguredProgram -> Compiler -> PathCompilerInfo
 329 mkCompilerInfo compilerProgram compiler =
 330   PathCompilerInfo
 331     { pathCompilerInfoFlavour = compilerFlavor compiler
 332     , pathCompilerInfoId = compilerId compiler
 333     , pathCompilerInfoPath = programPath compilerProgram
 334     }
 335
 336 -- ----------------------------------------------------------------------------
 337 -- JSON
 338 -- ----------------------------------------------------------------------------
 339
 340 showAsJson :: PathOutputs -> Json.Value
 341 showAsJson pathOutputs =
 342   let
 343     cabalInstallJson =
 344       Json.object
 345         [ "cabal-version" .= jdisplay cabalInstallVersion
 346         ]
 347
 348     compilerInfoJson = case pathOutputsCompilerInfo pathOutputs of
 349       Nothing -> Json.object []
 350       Just pci -> compilerInfoToJson pci
 351
 352     pathsJson = Json.object $ map (\(k, v) -> k .= Json.String v) (pathOutputsConfigPaths pathOutputs)
 353    in
 354     mergeJsonObjects $
 355       [ cabalInstallJson
 356       , compilerInfoJson
 357       , pathsJson
 358       ]
 359
 360 jdisplay :: Pretty a => a -> Json.Value
 361 jdisplay = Json.String . prettyShow
 362
 363 mergeJsonObjects :: [Json.Value] -> Json.Value
 364 mergeJsonObjects = Json.object . foldl' go []
 365   where
 366     go acc (Json.Object objs) =
 367       acc <> objs
 368     go _ _ =
 369       error "mergeJsonObjects: Only objects can be merged"
 370
 371 compilerInfoToJson :: PathCompilerInfo -> Json.Value
 372 compilerInfoToJson pci =
 373   Json.object
 374     [ "compiler"
 375         .= Json.object
 376           [ "flavour" .= jdisplay (pathCompilerInfoFlavour pci)
 377           , "id" .= jdisplay (pathCompilerInfoId pci)
 378           , "path" .= Json.String (pathCompilerInfoPath pci)
 379           ]
 380     ]
 381
 382 -- ----------------------------------------------------------------------------
 383 -- Key Value Pair outputs
 384 -- ----------------------------------------------------------------------------
 385
 386 showAsKeyValuePair :: PathOutputs -> String
 387 showAsKeyValuePair pathOutputs =
 388   let
 389     cInfo = case pathOutputsCompilerInfo pathOutputs of
 390       Nothing -> []
 391       Just pci -> compilerInfoToKeyValue pci
 392
 393     paths = pathOutputsConfigPaths pathOutputs
 394
 395     pairs = cInfo <> paths
 396
 397     showPair (k, v) = k <> ": " <> v
 398    in
 399     case pairs of
 400       [(_, v)] -> v
 401       xs -> unlines $ map showPair xs
 402
 403 compilerInfoToKeyValue :: PathCompilerInfo -> [(String, String)]
 404 compilerInfoToKeyValue pci =
 405   [ ("compiler-flavour", prettyShow $ pathCompilerInfoFlavour pci)
 406   , ("compiler-id", prettyShow $ pathCompilerInfoId pci)
 407   , ("compiler-path", pathCompilerInfoPath pci)
 408   ]