Use ghc-local types for packages, rather than Cabal types
[ghc.git] / libraries / bin-package-db / GHC / PackageDb.hs
1 {-# LANGUAGE CPP #-}
2 -- This module deliberately defines orphan instances for now (Binary Version).
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : GHC.PackageDb
7 -- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014
8 --
9 -- Maintainer : ghc-devs@haskell.org
10 -- Portability : portable
11 --
12 -- This module provides the view of GHC's database of registered packages that
13 -- is shared between GHC the compiler\/library, and the ghc-pkg program. It
14 -- defines the database format that is shared between GHC and ghc-pkg.
15 --
16 -- The database format, and this library are constructed so that GHC does not
17 -- have to depend on the Cabal library. The ghc-pkg program acts as the
18 -- gateway between the external package format (which is defined by Cabal) and
19 -- the internal package format which is specialised just for GHC.
20 --
21 -- GHC the compiler only needs some of the information which is kept about
22 -- registerd packages, such as module names, various paths etc. On the other
23 -- hand ghc-pkg has to keep all the information from Cabal packages and be able
24 -- to regurgitate it for users and other tools.
25 --
26 -- The first trick is that we duplicate some of the information in the package
27 -- database. We essentially keep two versions of the datbase in one file, one
28 -- version used only by ghc-pkg which keeps the full information (using the
29 -- serialised form of the 'InstalledPackageInfo' type defined by the Cabal
30 -- library); and a second version written by ghc-pkg and read by GHC which has
31 -- just the subset of information that GHC needs.
32 --
33 -- The second trick is that this module only defines in detail the format of
34 -- the second version -- the bit GHC uses -- and the part managed by ghc-pkg
35 -- is kept in the file but here we treat it as an opaque blob of data. That way
36 -- this library avoids depending on Cabal.
37 --
38 module GHC.PackageDb (
39 InstalledPackageInfo(..),
40 ModuleExport(..),
41 BinaryStringRep(..),
42 emptyInstalledPackageInfo,
43 readPackageDbForGhc,
44 readPackageDbForGhcPkg,
45 writePackageDb
46 ) where
47
48 import Data.Version (Version(..))
49 import qualified Data.ByteString as BS
50 import qualified Data.ByteString.Char8 as BS.Char8
51 import qualified Data.ByteString.Lazy as BS.Lazy
52 import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
53 import Data.Binary as Bin
54 import Data.Binary.Put as Bin
55 import Data.Binary.Get as Bin
56 import Control.Exception as Exception
57 import Control.Monad (when)
58 import System.FilePath
59 import System.IO
60 import System.IO.Error
61 import GHC.IO.Exception (IOErrorType(InappropriateType))
62 import System.Directory
63
64
65 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
66 -- that GHC is interested in.
67 --
68 data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename
69 = InstalledPackageInfo {
70 installedPackageId :: instpkgid,
71 sourcePackageId :: srcpkgid,
72 packageName :: srcpkgname,
73 packageVersion :: Version,
74 packageKey :: pkgkey,
75 depends :: [instpkgid],
76 importDirs :: [FilePath],
77 hsLibraries :: [String],
78 extraLibraries :: [String],
79 extraGHCiLibraries :: [String],
80 libraryDirs :: [FilePath],
81 frameworks :: [String],
82 frameworkDirs :: [FilePath],
83 ldOptions :: [String],
84 ccOptions :: [String],
85 includes :: [String],
86 includeDirs :: [FilePath],
87 haddockInterfaces :: [FilePath],
88 haddockHTMLs :: [FilePath],
89 exposedModules :: [modulename],
90 hiddenModules :: [modulename],
91 reexportedModules :: [ModuleExport instpkgid modulename],
92 exposed :: Bool,
93 trusted :: Bool
94 }
95 deriving (Eq, Show)
96
97 class BinaryStringRep a where
98 fromStringRep :: BS.ByteString -> a
99 toStringRep :: a -> BS.ByteString
100
101 data ModuleExport instpkgid modulename
102 = ModuleExport {
103 exportModuleName :: modulename,
104 exportOriginalPackageId :: instpkgid,
105 exportOriginalModuleName :: modulename
106 }
107 deriving (Eq, Show)
108
109 emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d)
110 => InstalledPackageInfo a b c d e
111 emptyInstalledPackageInfo =
112 InstalledPackageInfo {
113 installedPackageId = fromStringRep BS.empty,
114 sourcePackageId = fromStringRep BS.empty,
115 packageName = fromStringRep BS.empty,
116 packageVersion = Version [] [],
117 packageKey = fromStringRep BS.empty,
118 depends = [],
119 importDirs = [],
120 hsLibraries = [],
121 extraLibraries = [],
122 extraGHCiLibraries = [],
123 libraryDirs = [],
124 frameworks = [],
125 frameworkDirs = [],
126 ldOptions = [],
127 ccOptions = [],
128 includes = [],
129 includeDirs = [],
130 haddockInterfaces = [],
131 haddockHTMLs = [],
132 exposedModules = [],
133 hiddenModules = [],
134 reexportedModules = [],
135 exposed = False,
136 trusted = False
137 }
138
139 -- | Read the part of the package DB that GHC is interested in.
140 --
141 readPackageDbForGhc :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
142 BinaryStringRep d, BinaryStringRep e) =>
143 FilePath -> IO [InstalledPackageInfo a b c d e]
144 readPackageDbForGhc file =
145 decodeFromFile file getDbForGhc
146 where
147 getDbForGhc = do
148 _version <- getHeader
149 _ghcPartLen <- get :: Get Word32
150 ghcPart <- get
151 -- the next part is for ghc-pkg, but we stop here.
152 return ghcPart
153
154 -- | Read the part of the package DB that ghc-pkg is interested in
155 --
156 readPackageDbForGhcPkg :: Binary pkgs => FilePath -> IO pkgs
157 readPackageDbForGhcPkg file =
158 decodeFromFile file getDbForGhcPkg
159 where
160 getDbForGhcPkg = do
161 _version <- getHeader
162 -- skip over the ghc part
163 ghcPartLen <- get :: Get Word32
164 _ghcPart <- skip (fromIntegral ghcPartLen)
165 -- the next part is for ghc-pkg
166 ghcPkgPart <- get
167 return ghcPkgPart
168
169 -- | Write the whole of the package DB, both parts.
170 --
171 writePackageDb :: (Binary pkgs, BinaryStringRep a, BinaryStringRep b,
172 BinaryStringRep c, BinaryStringRep d, BinaryStringRep e) =>
173 FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO ()
174 writePackageDb file ghcPkgs ghcPkgPart =
175 writeFileAtomic file (runPut putDbForGhcPkg)
176 where
177 putDbForGhcPkg = do
178 putHeader
179 put ghcPartLen
180 putLazyByteString ghcPart
181 put ghcPkgPart
182 where
183 ghcPartLen :: Word32
184 ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
185 ghcPart = encode ghcPkgs
186
187 getHeader :: Get (Word32, Word32)
188 getHeader = do
189 magic <- getByteString (BS.length headerMagic)
190 when (magic /= headerMagic) $
191 fail "not a ghc-pkg db file, wrong file magic number"
192
193 majorVersion <- get :: Get Word32
194 -- The major version is for incompatible changes
195
196 minorVersion <- get :: Get Word32
197 -- The minor version is for compatible extensions
198
199 when (majorVersion /= 1) $
200 fail "unsupported ghc-pkg db format version"
201 -- If we ever support multiple major versions then we'll have to change
202 -- this code
203
204 -- The header can be extended without incrementing the major version,
205 -- we ignore fields we don't know about (currently all).
206 headerExtraLen <- get :: Get Word32
207 skip (fromIntegral headerExtraLen)
208
209 return (majorVersion, minorVersion)
210
211 putHeader :: Put
212 putHeader = do
213 putByteString headerMagic
214 put majorVersion
215 put minorVersion
216 put headerExtraLen
217 where
218 majorVersion = 1 :: Word32
219 minorVersion = 0 :: Word32
220 headerExtraLen = 0 :: Word32
221
222 headerMagic :: BS.ByteString
223 headerMagic = BS.Char8.pack "\0ghcpkg\0"
224
225
226 -- | Feed a 'Get' decoder with data chunks from a file.
227 --
228 decodeFromFile :: FilePath -> Get a -> IO a
229 decodeFromFile file decoder =
230 withBinaryFile file ReadMode $ \hnd ->
231 feed hnd (runGetIncremental decoder)
232 where
233 feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
234 if BS.null chunk
235 then feed hnd (k Nothing)
236 else feed hnd (k (Just chunk))
237 feed _ (Done _ _ result) = return result
238 feed _ (Fail _ _ msg) = ioError err
239 where
240 err = mkIOError InappropriateType loc Nothing (Just file)
241 `ioeSetErrorString` msg
242 loc = "GHC.PackageDb.readPackageDb"
243
244 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
245 writeFileAtomic targetPath content = do
246 let (targetDir, targetName) = splitFileName targetPath
247 Exception.bracketOnError
248 (openBinaryTempFileWithDefaultPermissions targetDir $ targetName <.> "tmp")
249 (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
250 (\(tmpPath, handle) -> do
251 BS.Lazy.hPut handle content
252 hClose handle
253 #if mingw32_HOST_OS || mingw32_TARGET_OS
254 renameFile tmpPath targetPath
255 -- If the targetPath exists then renameFile will fail
256 `catchIO` \err -> do
257 exists <- doesFileExist targetPath
258 if exists
259 then do removeFile targetPath
260 -- Big fat hairy race condition
261 renameFile newFile targetPath
262 -- If the removeFile succeeds and the renameFile fails
263 -- then we've lost the atomic property.
264 else throwIOIO err
265 #else
266 renameFile tmpPath targetPath
267 #endif
268 )
269
270
271 instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
272 BinaryStringRep d, BinaryStringRep e) =>
273 Binary (InstalledPackageInfo a b c d e) where
274 put (InstalledPackageInfo
275 installedPackageId sourcePackageId packageName packageVersion packageKey
276 depends importDirs
277 hsLibraries extraLibraries extraGHCiLibraries libraryDirs
278 frameworks frameworkDirs
279 ldOptions ccOptions
280 includes includeDirs
281 haddockInterfaces haddockHTMLs
282 exposedModules hiddenModules reexportedModules
283 exposed trusted) = do
284 put (toStringRep installedPackageId)
285 put (toStringRep sourcePackageId)
286 put (toStringRep packageName)
287 put packageVersion
288 put (toStringRep packageKey)
289 put (map toStringRep depends)
290 put importDirs
291 put hsLibraries
292 put extraLibraries
293 put extraGHCiLibraries
294 put libraryDirs
295 put frameworks
296 put frameworkDirs
297 put ldOptions
298 put ccOptions
299 put includes
300 put includeDirs
301 put haddockInterfaces
302 put haddockHTMLs
303 put (map toStringRep exposedModules)
304 put (map toStringRep hiddenModules)
305 put reexportedModules
306 put exposed
307 put trusted
308
309 get = do
310 installedPackageId <- get
311 sourcePackageId <- get
312 packageName <- get
313 packageVersion <- get
314 packageKey <- get
315 depends <- get
316 importDirs <- get
317 hsLibraries <- get
318 extraLibraries <- get
319 extraGHCiLibraries <- get
320 libraryDirs <- get
321 frameworks <- get
322 frameworkDirs <- get
323 ldOptions <- get
324 ccOptions <- get
325 includes <- get
326 includeDirs <- get
327 haddockInterfaces <- get
328 haddockHTMLs <- get
329 exposedModules <- get
330 hiddenModules <- get
331 reexportedModules <- get
332 exposed <- get
333 trusted <- get
334 return (InstalledPackageInfo
335 (fromStringRep installedPackageId)
336 (fromStringRep sourcePackageId)
337 (fromStringRep packageName) packageVersion
338 (fromStringRep packageKey)
339 (map fromStringRep depends)
340 importDirs
341 hsLibraries extraLibraries extraGHCiLibraries libraryDirs
342 frameworks frameworkDirs
343 ldOptions ccOptions
344 includes includeDirs
345 haddockInterfaces haddockHTMLs
346 (map fromStringRep exposedModules)
347 (map fromStringRep hiddenModules)
348 reexportedModules
349 exposed trusted)
350
351 instance Binary Version where
352 put (Version a b) = do
353 put a
354 put b
355 get = do
356 a <- get
357 b <- get
358 return (Version a b)
359
360 instance (BinaryStringRep a, BinaryStringRep b) => Binary (ModuleExport a b) where
361 put (ModuleExport a b c) = do
362 put (toStringRep a)
363 put (toStringRep b)
364 put (toStringRep c)
365 get = do
366 a <- get
367 b <- get
368 c <- get
369 return (ModuleExport (fromStringRep a)
370 (fromStringRep b)
371 (fromStringRep c))