1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE RecordWildCards #-} 5 6-- | Handy path information. 7module Stack.Path 8 ( path 9 , pathParser 10 ) where 11 12import Stack.Prelude 13import Data.List (intercalate) 14import qualified Data.Text as T 15import qualified Data.Text.IO as T 16import qualified Options.Applicative as OA 17import Path 18import Path.Extra 19import Stack.Constants 20import Stack.Constants.Config 21import Stack.GhcPkg as GhcPkg 22import Stack.Runners 23import Stack.Types.Config 24import qualified System.FilePath as FP 25import RIO.PrettyPrint 26import RIO.Process (HasProcessContext (..), exeSearchPathL) 27 28-- | Print out useful path information in a human-readable format (and 29-- support others later). 30path :: [Text] -> RIO Runner () 31path keys = 32 do let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys 33 forM_ deprecated $ \(oldOption, newOption) -> logWarn $ 34 "\n" <> 35 "'--" <> display oldOption <> "' will be removed in a future release.\n" <> 36 "Please use '--" <> display newOption <> "' instead.\n" <> 37 "\n" 38 let -- filter the chosen paths in flags (keys), 39 -- or show all of them if no specific paths chosen. 40 goodPaths = filter 41 (\(_,key,_) -> 42 (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys) 43 paths 44 singlePath = length goodPaths == 1 45 toEither (_, k, UseHaddocks p) = Left (k, p) 46 toEither (_, k, WithoutHaddocks p) = Right (k, p) 47 (with, without) = partitionEithers $ map toEither goodPaths 48 printKeys extractors single = do 49 pathInfo <- fillPathInfo 50 liftIO $ forM_ extractors $ \(key, extractPath) -> do 51 let prefix = if single then "" else key <> ": " 52 T.putStrLn $ prefix <> extractPath pathInfo 53 runHaddock x = local 54 (set (globalOptsL.globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just x)) . 55 withConfig YesReexec . -- FIXME this matches previous behavior, but doesn't make a lot of sense 56 withDefaultEnvConfig 57 -- MSS 2019-03-17 Not a huge fan of rerunning withConfig and 58 -- withDefaultEnvConfig each time, need to figure out what 59 -- purpose is served and whether we can achieve it without two 60 -- completely separate Config setups 61 runHaddock True $ printKeys with singlePath 62 runHaddock False $ printKeys without singlePath 63 64fillPathInfo :: HasEnvConfig env => RIO env PathInfo 65fillPathInfo = do 66 -- We must use a BuildConfig from an EnvConfig to ensure that it contains the 67 -- full environment info including GHC paths etc. 68 piBuildConfig <- view $ envConfigL.buildConfigL 69 -- This is the modified 'bin-path', 70 -- including the local GHC or MSYS if not configured to operate on 71 -- global GHC. 72 -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. 73 -- So it's not the *minimal* override path. 74 piSnapDb <- packageDatabaseDeps 75 piLocalDb <- packageDatabaseLocal 76 piExtraDbs <- packageDatabaseExtra 77 piGlobalDb <- view $ compilerPathsL.to cpGlobalDB 78 piSnapRoot <- installationRootDeps 79 piLocalRoot <- installationRootLocal 80 piToolsDir <- bindirCompilerTools 81 piHoogleRoot <- hoogleRoot 82 piDistDir <- distRelativeDir 83 piHpcDir <- hpcReportDir 84 piCompiler <- getCompilerPath 85 return PathInfo {..} 86 87pathParser :: OA.Parser [Text] 88pathParser = 89 mapMaybeA 90 (\(desc,name,_) -> 91 OA.flag Nothing 92 (Just name) 93 (OA.long (T.unpack name) <> 94 OA.help desc)) 95 paths 96 97-- | Passed to all the path printers as a source of info. 98data PathInfo = PathInfo 99 { piBuildConfig :: !BuildConfig 100 , piSnapDb :: !(Path Abs Dir) 101 , piLocalDb :: !(Path Abs Dir) 102 , piGlobalDb :: !(Path Abs Dir) 103 , piSnapRoot :: !(Path Abs Dir) 104 , piLocalRoot :: !(Path Abs Dir) 105 , piToolsDir :: !(Path Abs Dir) 106 , piHoogleRoot :: !(Path Abs Dir) 107 , piDistDir :: Path Rel Dir 108 , piHpcDir :: !(Path Abs Dir) 109 , piExtraDbs :: ![Path Abs Dir] 110 , piCompiler :: !(Path Abs File) 111 } 112 113instance HasPlatform PathInfo 114instance HasLogFunc PathInfo where 115 logFuncL = configL.logFuncL 116instance HasRunner PathInfo where 117 runnerL = configL.runnerL 118instance HasStylesUpdate PathInfo where 119 stylesUpdateL = runnerL.stylesUpdateL 120instance HasTerm PathInfo where 121 useColorL = runnerL.useColorL 122 termWidthL = runnerL.termWidthL 123instance HasGHCVariant PathInfo 124instance HasConfig PathInfo 125instance HasPantryConfig PathInfo where 126 pantryConfigL = configL.pantryConfigL 127instance HasProcessContext PathInfo where 128 processContextL = configL.processContextL 129instance HasBuildConfig PathInfo where 130 buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y }) 131 . buildConfigL 132 133data UseHaddocks a = UseHaddocks a | WithoutHaddocks a 134 135-- | The paths of interest to a user. The first tuple string is used 136-- for a description that the optparse flag uses, and the second 137-- string as a machine-readable key and also for @--foo@ flags. The user 138-- can choose a specific path to list like @--stack-root@. But 139-- really it's mainly for the documentation aspect. 140-- 141-- When printing output we generate @PathInfo@ and pass it to the 142-- function to generate an appropriate string. Trailing slashes are 143-- removed, see #506 144paths :: [(String, Text, UseHaddocks (PathInfo -> Text))] 145paths = 146 [ ( "Global stack root directory" 147 , T.pack stackRootOptionName 148 , WithoutHaddocks $ view (stackRootL.to toFilePathNoTrailingSep.to T.pack)) 149 , ( "Project root (derived from stack.yaml file)" 150 , "project-root" 151 , WithoutHaddocks $ view (projectRootL.to toFilePathNoTrailingSep.to T.pack)) 152 , ( "Configuration location (where the stack.yaml file is)" 153 , "config-location" 154 , WithoutHaddocks $ view (stackYamlL.to toFilePath.to T.pack)) 155 , ( "PATH environment variable" 156 , "bin-path" 157 , WithoutHaddocks $ T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL) 158 , ( "Install location for GHC and other core tools" 159 , "programs" 160 , WithoutHaddocks $ view (configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack)) 161 , ( "Compiler binary (e.g. ghc)" 162 , "compiler-exe" 163 , WithoutHaddocks $ T.pack . toFilePath . piCompiler ) 164 , ( "Directory containing the compiler binary (e.g. ghc)" 165 , "compiler-bin" 166 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . piCompiler ) 167 , ( "Directory containing binaries specific to a particular compiler (e.g. intero)" 168 , "compiler-tools-bin" 169 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piToolsDir ) 170 , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))" 171 , "local-bin" 172 , WithoutHaddocks $ view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack) 173 , ( "Extra include directories" 174 , "extra-include-dirs" 175 , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraIncludeDirs . view configL ) 176 , ( "Extra library directories" 177 , "extra-library-dirs" 178 , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraLibDirs . view configL ) 179 , ( "Snapshot package database" 180 , "snapshot-pkg-db" 181 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapDb ) 182 , ( "Local project package database" 183 , "local-pkg-db" 184 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalDb ) 185 , ( "Global package database" 186 , "global-pkg-db" 187 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piGlobalDb ) 188 , ( "GHC_PACKAGE_PATH environment variable" 189 , "ghc-package-path" 190 , WithoutHaddocks $ \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi')) 191 , ( "Snapshot installation root" 192 , "snapshot-install-root" 193 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapRoot ) 194 , ( "Local project installation root" 195 , "local-install-root" 196 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalRoot ) 197 , ( "Snapshot documentation root" 198 , "snapshot-doc-root" 199 , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' </> docDirSuffix))) 200 , ( "Local project documentation root" 201 , "local-doc-root" 202 , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix))) 203 , ( "Local project documentation root" 204 , "local-hoogle-root" 205 , UseHaddocks $ T.pack . toFilePathNoTrailingSep . piHoogleRoot) 206 , ( "Dist work directory, relative to package directory" 207 , "dist-dir" 208 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piDistDir ) 209 , ( "Where HPC reports and tix files are stored" 210 , "local-hpc-root" 211 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piHpcDir ) 212 , ( "DEPRECATED: Use '--local-bin' instead" 213 , "local-bin-path" 214 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalBin . view configL ) 215 , ( "DEPRECATED: Use '--programs' instead" 216 , "ghc-paths" 217 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL ) 218 , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead" 219 , T.pack deprecatedStackRootOptionName 220 , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . view stackRootL ) 221 ] 222 223deprecatedPathKeys :: [(Text, Text)] 224deprecatedPathKeys = 225 [ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName) 226 , ("ghc-paths", "programs") 227 , ("local-bin-path", "local-bin") 228 ] 229