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