{-# 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"

, "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")

]