-
Notifications
You must be signed in to change notification settings - Fork 844
/
GhcPkg.hs
188 lines (174 loc) · 6.73 KB
/
GhcPkg.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Functions for the GHC package database.
module Stack.GhcPkg
(getGlobalDB
,findGhcPkgField
,createDatabase
,unregisterGhcPkgIds
,getCabalPkgVer
,ghcPkgExeName
,ghcPkgPathEnvVar
,mkGhcPackagePath)
where
import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (parent, (</>))
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Stack.Constants
import Stack.Types.Build
import Stack.Types.GhcPkgId
import Stack.Types.Compiler
import System.FilePath (searchPathSeparator)
import RIO.Process
-- | Get the global package database
getGlobalDB :: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler -> RIO env (Path Abs Dir)
getGlobalDB wc = do
logDebug "Getting global package database location"
-- This seems like a strange way to get the global package database
-- location, but I don't know of a better one
bs <- ghcPkg wc [] ["list", "--global"] >>= either throwIO return
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO $ resolveDir' fp
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
-- | Run the ghc-pkg executable
ghcPkg :: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException S8.ByteString)
ghcPkg wc pkgDbs args = do
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase wc) pkgDbs
go
Right _ -> return eres
where
go = tryAny
$ BL.toStrict . fst
<$> proc (ghcPkgExeName wc) args' readProcess_
args' = packageDbFlags pkgDbs ++ args
-- | Create a package database in the given directory, if it doesn't exist.
createDatabase
:: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler -> Path Abs Dir -> RIO env ()
createDatabase wc db = do
exists <- doesFileExist (db </> relFilePackageCache)
unless exists $ do
-- ghc-pkg requires that the database directory does not exist
-- yet. If the directory exists but the package.cache file
-- does, we're in a corrupted state. Check for that state.
dirExists <- doesDirExist db
args <- if dirExists
then do
logWarn $
"The package database located at " <>
fromString (toFilePath db) <>
" is corrupted (missing its package.cache file)."
logWarn "Proceeding with a recache"
return ["--package-db", toFilePath db, "recache"]
else do
-- Creating the parent doesn't seem necessary, as ghc-pkg
-- seems to be sufficiently smart. But I don't feel like
-- finding out it isn't the hard way
ensureDir (parent db)
return ["init", toFilePath db]
void $ proc (ghcPkgExeName wc) args $ \pc ->
readProcess_ pc `onException`
logError ("Unable to create package database at " <> fromString (toFilePath db))
-- | Get the name to use for "ghc-pkg", given the compiler version.
ghcPkgExeName :: WhichCompiler -> String
ghcPkgExeName Ghc = "ghc-pkg"
ghcPkgExeName Ghcjs = "ghcjs-pkg"
-- | Get the environment variable to use for the package DB paths.
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"
ghcPkgPathEnvVar Ghcjs = "GHCJS_PACKAGE_PATH"
-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
-- | Get the value of a field of the package.
findGhcPkgField
:: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> [Path Abs Dir] -- ^ package databases
-> String -- ^ package identifier, or GhcPkgId
-> Text
-> RIO env (Maybe Text)
findGhcPkgField wc pkgDbs name field = do
result <-
ghcPkg
wc
pkgDbs
["field", "--simple-output", name, T.unpack field]
return $
case result of
Left{} -> Nothing
Right bs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
-- | Get the version of the package
findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> [Path Abs Dir] -- ^ package databases
-> PackageName
-> RIO env (Maybe Version)
findGhcPkgVersion wc pkgDbs name = do
mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version"
case mv of
Just !v -> return (parseVersion $ T.unpack v)
_ -> return Nothing
-- | unregister list of package ghcids, batching available from GHC 8.0.1,
-- using GHC package id where available (from GHC 7.9)
unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> Path Abs Dir -- ^ package database
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds wc pkgDb epgids = do
eres <- ghcPkg wc [pkgDb] args
case eres of
Left e -> logWarn $ displayShow e
Right _ -> return ()
where
args = "unregister" : "--user" : "--force" :
concatMap (either
(\ident -> [packageIdentifierString ident])
(\gid -> ["--ipid", ghcPkgIdString gid]))
epgids
-- | Get the version of Cabal from the global package database.
getCabalPkgVer :: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler -> RIO env Version
getCabalPkgVer wc = do
logDebug "Getting Cabal package version"
mres <- findGhcPkgVersion
wc
[] -- global DB
cabalPackageName
maybe (throwIO $ Couldn'tFindPkgId cabalPackageName) return mres
-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps extras globaldb =
T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSep localdb | locals]
, [toFilePathNoTrailingSep deps]
, [toFilePathNoTrailingSep db | db <- reverse extras]
, [toFilePathNoTrailingSep globaldb]
]