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