{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Path
( path
, pathParser
) where
import Stack.Prelude
import Data.List (intercalate)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Lens.Micro (lens)
import qualified Options.Applicative as OA
import Path
import Path.Extra
import Stack.Constants
import Stack.Constants.Config
import Stack.GhcPkg as GhcPkg
import Stack.PackageIndex (HasCabalLoader (..))
import Stack.Types.Config
import Stack.Types.Runner
import qualified System.FilePath as FP
import System.IO (stderr)
import RIO.Process (HasProcessContext (..), exeSearchPathL)
path
:: HasEnvConfig env
=> [Text]
-> RIO env ()
path keys =
do
bc <- view $ envConfigL.buildConfigL
snap <- packageDatabaseDeps
plocal <- packageDatabaseLocal
extra <- packageDatabaseExtra
whichCompiler <- view $ actualCompilerVersionL.whichCompilerL
global <- GhcPkg.getGlobalDB whichCompiler
snaproot <- installationRootDeps
localroot <- installationRootLocal
toolsDir <- bindirCompilerTools
distDir <- distRelativeDir
hpcDir <- hpcReportDir
compiler <- getCompilerPath whichCompiler
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
snap
plocal
global
snaproot
localroot
toolsDir
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
, piSnapDb :: Path Abs Dir
, piLocalDb :: Path Abs Dir
, piGlobalDb :: Path Abs Dir
, piSnapRoot :: Path Abs Dir
, piLocalRoot :: Path Abs Dir
, piToolsDir :: Path Abs Dir
, piDistDir :: Path Rel Dir
, piHpcDir :: Path Abs Dir
, piExtraDbs :: [Path Abs Dir]
, piCompiler :: Path Abs File
}
instance HasPlatform PathInfo
instance HasLogFunc PathInfo where
logFuncL = configL.logFuncL
instance HasRunner PathInfo where
runnerL = configL.runnerL
instance HasConfig PathInfo
instance HasCabalLoader PathInfo where
cabalLoaderL = configL.cabalLoaderL
instance HasProcessContext PathInfo where
processContextL = configL.processContextL
instance HasBuildConfig PathInfo where
buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y })
. buildConfigL
paths :: [(String, Text, PathInfo -> Text)]
paths =
[ ( "Global stack root directory"
, T.pack stackRootOptionName
, view $ stackRootL.to toFilePathNoTrailingSep.to T.pack)
, ( "Project root (derived from stack.yaml file)"
, "project-root"
, view $ projectRootL.to toFilePathNoTrailingSep.to T.pack)
, ( "Configuration location (where the stack.yaml file is)"
, "config-location"
, view $ stackYamlL.to toFilePath.to T.pack)
, ( "PATH environment variable"
, "bin-path"
, T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)
, ( "Install location for GHC and other core tools"
, "programs"
, view $ configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack)
, ( "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 )
, ( "Directory containing binaries specific to a particular compiler (e.g. intero)"
, "compiler-tools-bin"
, T.pack . toFilePathNoTrailingSep . piToolsDir )
, ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)"
, "local-bin"
, view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack)
, ( "Extra include directories"
, "extra-include-dirs"
, T.intercalate ", " . map T.pack . Set.elems . configExtraIncludeDirs . view configL )
, ( "Extra library directories"
, "extra-library-dirs"
, T.intercalate ", " . map T.pack . Set.elems . configExtraLibDirs . view configL )
, ( "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 . view configL )
, ( "DEPRECATED: Use '--programs' instead"
, "ghc-paths"
, T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL )
, ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
, T.pack deprecatedStackRootOptionName
, T.pack . toFilePathNoTrailingSep . view stackRootL )
]
deprecatedPathKeys :: [(Text, Text)]
deprecatedPathKeys =
[ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)
, ("ghc-paths", "programs")
, ("local-bin-path", "local-bin")
]