{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Handy path information. 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)) -- | Print out useful path information in a human-readable format (and -- support others later). path :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m) => [Text] -> m () path keys = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. bc <- asks (getBuildConfig . getEnvConfig) -- This is the modified 'bin-path', -- including the local GHC or MSYS if not configured to operate on -- global GHC. -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. -- So it's not the *minimal* override path. 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 the chosen paths in flags (keys), -- or show all of them if no specific paths chosen. (filter (\(_,key,_) -> (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys) paths) (\(_,key,path') -> liftIO $ T.putStrLn -- If a single path type is requested, output it directly. -- Otherwise, name all the paths. ((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 -- | Passed to all the path printers as a source of info. 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 } -- | The paths of interest to a user. The first tuple string is used -- for a description that the optparse flag uses, and the second -- string as a machine-readable key and also for @--foo@ flags. The user -- can choose a specific path to list like @--stack-root@. But -- really it's mainly for the documentation aspect. -- -- When printing output we generate @PathInfo@ and pass it to the -- function to generate an appropriate string. Trailing slashes are -- removed, see #506 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") ]