module Stack.Path
( path
, pathParser
) where
import Control.Monad.Catch
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.List (intercalate)
import Data.Maybe.Extra
import Data.Monoid
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Options.Applicative as OA
import Path
import Path.Extra
import Stack.Constants
import Stack.GhcPkg as GhcPkg
import Stack.Types.Config
import qualified System.FilePath as FP
import System.IO (stderr)
import System.Process.Read (EnvOverride(eoPath))
path
:: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasEnvConfig env,
MonadCatch m, MonadLogger m)
=> [Text]
-> m ()
path keys =
do
bc <- asks (getBuildConfig . getEnvConfig)
menv <- getMinimalEnvOverride
snap <- packageDatabaseDeps
plocal <- packageDatabaseLocal
extra <- packageDatabaseExtra
global <- GhcPkg.getGlobalDB menv =<< getWhichCompiler
snaproot <- installationRootDeps
localroot <- installationRootLocal
distDir <- distRelativeDir
hpcDir <- hpcReportDir
compiler <- getCompilerPath =<< getWhichCompiler
let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys
liftIO $ forM_ deprecated $ \(oldOption, newOption) -> T.hPutStrLn stderr $ T.unlines
[ ""
, "'--" <> oldOption <> "' will be removed in a future release."
, "Please use '--" <> newOption <> "' instead."
, ""
]
forM_
(filter
(\(_,key,_) ->
(null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)
paths)
(\(_,key,path') ->
liftIO $ T.putStrLn
((if length keys == 1
then ""
else key <> ": ") <>
path'
(PathInfo
bc
menv
snap
plocal
global
snaproot
localroot
distDir
hpcDir
extra
compiler)))
pathParser :: OA.Parser [Text]
pathParser =
mapMaybeA
(\(desc,name,_) ->
OA.flag Nothing
(Just name)
(OA.long (T.unpack name) <>
OA.help desc))
paths
data PathInfo = PathInfo
{ piBuildConfig :: BuildConfig
, piEnvOverride :: EnvOverride
, piSnapDb :: Path Abs Dir
, piLocalDb :: Path Abs Dir
, piGlobalDb :: Path Abs Dir
, piSnapRoot :: Path Abs Dir
, piLocalRoot :: Path Abs Dir
, piDistDir :: Path Rel Dir
, piHpcDir :: Path Abs Dir
, piExtraDbs :: [Path Abs Dir]
, piCompiler :: Path Abs File
}
paths :: [(String, Text, PathInfo -> Text)]
paths =
[ ( "Global stack root directory"
, T.pack stackRootOptionName
, T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
, ( "Project root (derived from stack.yaml file)"
, "project-root"
, T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig )
, ( "Configuration location (where the stack.yaml file is)"
, "config-location"
, T.pack . toFilePath . bcStackYaml . piBuildConfig )
, ( "PATH environment variable"
, "bin-path"
, T.pack . intercalate [FP.searchPathSeparator] . eoPath . piEnvOverride )
, ( "Install location for GHC and other core tools"
, "programs"
, T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )
, ( "Compiler binary (e.g. ghc)"
, "compiler-exe"
, T.pack . toFilePath . piCompiler )
, ( "Directory containing the compiler binary (e.g. ghc)"
, "compiler-bin"
, T.pack . toFilePathNoTrailingSep . parent . piCompiler )
, ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)"
, "local-bin"
, T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )
, ( "Extra include directories"
, "extra-include-dirs"
, T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig )
, ( "Extra library directories"
, "extra-library-dirs"
, T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig )
, ( "Snapshot package database"
, "snapshot-pkg-db"
, T.pack . toFilePathNoTrailingSep . piSnapDb )
, ( "Local project package database"
, "local-pkg-db"
, T.pack . toFilePathNoTrailingSep . piLocalDb )
, ( "Global package database"
, "global-pkg-db"
, T.pack . toFilePathNoTrailingSep . piGlobalDb )
, ( "GHC_PACKAGE_PATH environment variable"
, "ghc-package-path"
, \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi'))
, ( "Snapshot installation root"
, "snapshot-install-root"
, T.pack . toFilePathNoTrailingSep . piSnapRoot )
, ( "Local project installation root"
, "local-install-root"
, T.pack . toFilePathNoTrailingSep . piLocalRoot )
, ( "Snapshot documentation root"
, "snapshot-doc-root"
, \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' </> docDirSuffix)))
, ( "Local project documentation root"
, "local-doc-root"
, \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix)))
, ( "Dist work directory, relative to package directory"
, "dist-dir"
, T.pack . toFilePathNoTrailingSep . piDistDir )
, ( "Where HPC reports and tix files are stored"
, "local-hpc-root"
, T.pack . toFilePathNoTrailingSep . piHpcDir )
, ( "DEPRECATED: Use '--local-bin' instead"
, "local-bin-path"
, T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )
, ( "DEPRECATED: Use '--programs' instead"
, "ghc-paths"
, T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )
, ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
, T.pack deprecatedStackRootOptionName
, T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
]
deprecatedPathKeys :: [(Text, Text)]
deprecatedPathKeys =
[ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)
, ("ghc-paths", "programs")
, ("local-bin-path", "local-bin")
]