Commit 4b648be1 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Herbert Valerio Riedel

Update Cabal submodule & ghc-pkg to use new module re-export types

Summary:
The main change is that Cabal changed the representation of module
re-exports to distinguish reexports in source .cabal files versus
re-exports in installed package registraion files.

Cabal now also does the resolution of re-exports to specific installed
packages itself, so ghc-pkg no longer has to do this. This is a cleaner
design overall because re-export resolution can fail so it is better to
do it during package configuration rather than package registration.
It also simplifies the re-export representation that ghc-pkg has to use.

Add extra ghc-pkg sanity check for module re-exports and duplicates

For re-exports, check that the defining package exists and that it
exposes the defining module (or for self-rexport exposed or hidden
modules). Also check that the defining package is actually a direct
or indirect dependency of the package doing the re-exporting.

Also add a check for duplicate modules in a package, including
re-exported modules.

Test Plan:
So far the sanity checks are totally untested. Should add some test
case to make sure the sanity checks do catch things correctly, and
don't ban legal things.

Reviewers: austin, duncan

Subscribers: angerman, simonmar, ezyang, carter

Differential Revision: https://phabricator.haskell.org/D183

GHC Trac Issues:
parent 165072b3
...@@ -767,11 +767,15 @@ findBroken pkgs = go [] Map.empty pkgs ...@@ -767,11 +767,15 @@ findBroken pkgs = go [] Map.empty pkgs
-- package name/version. Additionally, a package may be preferred if -- package name/version. Additionally, a package may be preferred if
-- it is in the transitive closure of packages selected using -package-id -- it is in the transitive closure of packages selected using -package-id
-- flags. -- flags.
type UnusablePackage = (PackageConfig, UnusablePackageReason)
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred shadowPackages pkgs preferred
= let (shadowed,_) = foldl check ([],emptyUFM) pkgs = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
in Map.fromList shadowed in Map.fromList shadowed
where where
check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
-> PackageConfig
-> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
check (shadowed,pkgmap) pkg check (shadowed,pkgmap) pkg
| Just oldpkg <- lookupUFM pkgmap pkgid | Just oldpkg <- lookupUFM pkgmap pkgid
, let , let
...@@ -785,7 +789,7 @@ shadowPackages pkgs preferred ...@@ -785,7 +789,7 @@ shadowPackages pkgs preferred
| otherwise | otherwise
= (shadowed, pkgmap') = (shadowed, pkgmap')
where where
pkgid = mkFastString (sourcePackageIdString pkg) pkgid = packageKeyFS (packageKey pkg)
pkgmap' = addToUFM pkgmap pkgid pkg pkgmap' = addToUFM pkgmap pkgid pkg
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -383,7 +383,7 @@ else ...@@ -383,7 +383,7 @@ else
# programs such as GHC and ghc-pkg, that we do not assume the stage0 # programs such as GHC and ghc-pkg, that we do not assume the stage0
# compiler already has installed (or up-to-date enough). # compiler already has installed (or up-to-date enough).
PACKAGES_STAGE0 = Cabal/Cabal hpc binary bin-package-db hoopl transformers PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers
ifeq "$(Windows_Host)" "NO" ifeq "$(Windows_Host)" "NO"
ifneq "$(HostOS_CPP)" "ios" ifneq "$(HostOS_CPP)" "ios"
PACKAGES_STAGE0 += terminfo PACKAGES_STAGE0 += terminfo
...@@ -413,8 +413,8 @@ PACKAGES_STAGE1 += process ...@@ -413,8 +413,8 @@ PACKAGES_STAGE1 += process
PACKAGES_STAGE1 += hpc PACKAGES_STAGE1 += hpc
PACKAGES_STAGE1 += pretty PACKAGES_STAGE1 += pretty
PACKAGES_STAGE1 += template-haskell PACKAGES_STAGE1 += template-haskell
PACKAGES_STAGE1 += Cabal/Cabal
PACKAGES_STAGE1 += binary PACKAGES_STAGE1 += binary
PACKAGES_STAGE1 += Cabal/Cabal
PACKAGES_STAGE1 += bin-package-db PACKAGES_STAGE1 += bin-package-db
PACKAGES_STAGE1 += hoopl PACKAGES_STAGE1 += hoopl
PACKAGES_STAGE1 += transformers PACKAGES_STAGE1 += transformers
......
Subproject commit 8d59dc9fba584a9fdb810f4d84f7f3ccb089dd08 Subproject commit 5cf626df3039c8746bff814a7b97988d25707d96
Reading package info from "test.pkg" ... done. Reading package info from "test.pkg" ... done.
Reading package info from "test7a.pkg" ... done. Reading package info from "test7a.pkg" ... done.
reexported-modules: testpkg:A (A@testpkg-1.2.3.4-XXX) reexported-modules: testpkg-1.2.3.4-XXX:A as A
testpkg:A as A1 (A@testpkg-1.2.3.4-XXX) testpkg-1.2.3.4-XXX:A as A1 testpkg7a-1.0-XXX:E as E2
E as E2 (E@testpkg7a-1.0-XXX)
Reading package info from "test7b.pkg" ... done. Reading package info from "test7b.pkg" ... done.
reexported-modules: testpkg:A as F1 (A@testpkg-1.2.3.4-XXX) reexported-modules: testpkg-1.2.3.4-XXX:A as F1
testpkg7a:A as F2 (A@testpkg-1.2.3.4-XXX) testpkg7a-1.0-XXX:A as F2 testpkg7a-1.0-XXX:A1 as F3
testpkg7a:A1 as F3 (A@testpkg-1.2.3.4-XXX) testpkg7a-1.0-XXX:E as F4 testpkg7a-1.0-XXX:E as E
testpkg7a:E as F4 (E@testpkg7a-1.0-XXX) E (E@testpkg7a-1.0-XXX) testpkg7a-1.0-XXX:E2 as E3
E2 as E3 (E@testpkg7a-1.0-XXX)
...@@ -13,6 +13,7 @@ category: none ...@@ -13,6 +13,7 @@ category: none
author: simonmar@microsoft.com author: simonmar@microsoft.com
exposed: True exposed: True
exposed-modules: E exposed-modules: E
reexported-modules: testpkg:A, testpkg:A as A1, E as E2 reexported-modules: testpkg-1.2.3.4-XXX:A as A, testpkg-1.2.3.4-XXX:A as A1,
testpkg7a-1.0-XXX:E as E2
hs-libraries: testpkg7a-1.0 hs-libraries: testpkg7a-1.0
depends: testpkg-1.2.3.4-XXX depends: testpkg-1.2.3.4-XXX
...@@ -12,7 +12,8 @@ description: A Test Package ...@@ -12,7 +12,8 @@ description: A Test Package
category: none category: none
author: simonmar@microsoft.com author: simonmar@microsoft.com
exposed: True exposed: True
reexported-modules: testpkg:A as F1, testpkg7a:A as F2, reexported-modules: testpkg-1.2.3.4-XXX:A as F1, testpkg7a-1.0-XXX:A as F2,
testpkg7a:A1 as F3, testpkg7a:E as F4, E, E2 as E3 testpkg7a-1.0-XXX:A1 as F3, testpkg7a-1.0-XXX:E as F4,
testpkg7a-1.0-XXX:E as E, testpkg7a-1.0-XXX:E2 as E3
hs-libraries: testpkg7b-1.0 hs-libraries: testpkg7b-1.0
depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX
...@@ -40,7 +40,7 @@ test('haddock.base', ...@@ -40,7 +40,7 @@ test('haddock.base',
test('haddock.Cabal', test('haddock.Cabal',
[unless(in_tree_compiler(), skip) [unless(in_tree_compiler(), skip)
,stats_num_field('bytes allocated', ,stats_num_field('bytes allocated',
[(wordsize(64), 4500376192, 5) [(wordsize(64), 5840893376, 5)
# 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-14: 3255435248 (amd64/Linux)
# 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-08-29: 3324606664 (amd64/Linux, new codegen)
# 2012-10-08: 3373401360 (amd64/Linux) # 2012-10-08: 3373401360 (amd64/Linux)
...@@ -56,6 +56,7 @@ test('haddock.Cabal', ...@@ -56,6 +56,7 @@ test('haddock.Cabal',
# 2014-08-29: 4267311856 (x86_64/Linux - w/w for INLINABLE things) # 2014-08-29: 4267311856 (x86_64/Linux - w/w for INLINABLE things)
# 2014-09-09: 4660249216 (x86_64/Linux - Applicative/Monad changes according to Austin) # 2014-09-09: 4660249216 (x86_64/Linux - Applicative/Monad changes according to Austin)
# 2014-09-10: 4500376192 (x86_64/Linux - Applicative/Monad changes according to Joachim) # 2014-09-10: 4500376192 (x86_64/Linux - Applicative/Monad changes according to Joachim)
# 2014-09-24: 5840893376 (x86_64/Linux - Cabal update)
,(platform('i386-unknown-mingw32'), 2052220292, 5) ,(platform('i386-unknown-mingw32'), 2052220292, 5)
# 2012-10-30: 1733638168 (x86/Windows) # 2012-10-30: 1733638168 (x86/Windows)
......
...@@ -347,7 +347,7 @@ generate directory distdir dll0Modules config_args ...@@ -347,7 +347,7 @@ generate directory distdir dll0Modules config_args
do cwd <- getCurrentDirectory do cwd <- getCurrentDirectory
let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace") let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
pd lib lbi clbi pd ipid lib lbi clbi
final_ipi = installedPkgInfo { final_ipi = installedPkgInfo {
Installed.installedPackageId = ipid, Installed.installedPackageId = ipid,
Installed.haddockHTMLs = [] Installed.haddockHTMLs = []
......
...@@ -42,6 +42,7 @@ $(ghc-cabal_DIST_BINARY): utils/ghc-cabal/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. b ...@@ -42,6 +42,7 @@ $(ghc-cabal_DIST_BINARY): utils/ghc-cabal/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. b
-odir bootstrapping \ -odir bootstrapping \
-hidir bootstrapping \ -hidir bootstrapping \
-ilibraries/Cabal/Cabal \ -ilibraries/Cabal/Cabal \
-ilibraries/binary/src -DGENERICS \
-ilibraries/filepath \ -ilibraries/filepath \
-ilibraries/hpc \ -ilibraries/hpc \
$(utils/ghc-cabal_dist_EXTRA_HC_OPTS) $(utils/ghc-cabal_dist_EXTRA_HC_OPTS)
......
...@@ -14,14 +14,13 @@ module Main (main) where ...@@ -14,14 +14,13 @@ module Main (main) where
import Version ( version, targetOS, targetARCH ) import Version ( version, targetOS, targetARCH )
import qualified GHC.PackageDb as GhcPkg import qualified GHC.PackageDb as GhcPkg
import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Data.Graph as Graph
import qualified Distribution.ModuleName as ModuleName import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName) import Distribution.ModuleName (ModuleName)
import Distribution.InstalledPackageInfo as Cabal import Distribution.InstalledPackageInfo as Cabal
import Distribution.License
import Distribution.Compat.ReadP hiding (get) import Distribution.Compat.ReadP hiding (get)
import Distribution.ParseUtils import Distribution.ParseUtils
import Distribution.ModuleExport import Distribution.Package hiding (depends, installedPackageId)
import Distribution.Package hiding (depends)
import Distribution.Text import Distribution.Text
import Distribution.Version import Distribution.Version
import Distribution.Simple.Utils (fromUTF8, toUTF8) import Distribution.Simple.Utils (fromUTF8, toUTF8)
...@@ -38,8 +37,6 @@ import System.Console.GetOpt ...@@ -38,8 +37,6 @@ import System.Console.GetOpt
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Data.Maybe import Data.Maybe
import qualified Data.Set as Set
import Data.Char ( isSpace, toLower ) import Data.Char ( isSpace, toLower )
import Data.Ord (comparing) import Data.Ord (comparing)
#if __GLASGOW_HASKELL__ < 709 #if __GLASGOW_HASKELL__ < 709
...@@ -58,7 +55,6 @@ import Data.List ...@@ -58,7 +55,6 @@ import Data.List
import Control.Concurrent import Control.Concurrent
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Binary as Bin
#if defined(mingw32_HOST_OS) #if defined(mingw32_HOST_OS)
-- mingw32 needs these for getExecDir -- mingw32 needs these for getExecDir
...@@ -901,9 +897,6 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance ...@@ -901,9 +897,6 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
validatePackageConfig pkg_expanded verbosity truncated_stack validatePackageConfig pkg_expanded verbosity truncated_stack
auto_ghci_libs multi_instance update force auto_ghci_libs multi_instance update force
-- postprocess the package
pkg' <- resolveReexports truncated_stack pkg
let let
-- In the normal mode, we only allow one version of each package, so we -- In the normal mode, we only allow one version of each package, so we
-- remove all instances with the same source package id as the one we're -- remove all instances with the same source package id as the one we're
...@@ -914,7 +907,7 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance ...@@ -914,7 +907,7 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
p <- packages db_to_operate_on, p <- packages db_to_operate_on,
sourcePackageId p == sourcePackageId pkg ] sourcePackageId p == sourcePackageId pkg ]
-- --
changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
parsePackageInfo parsePackageInfo
:: String :: String
...@@ -937,47 +930,6 @@ mungePackageInfo ipi = ipi { packageKey = packageKey' } ...@@ -937,47 +930,6 @@ mungePackageInfo ipi = ipi { packageKey = packageKey' }
= OldPackageKey (sourcePackageId ipi) = OldPackageKey (sourcePackageId ipi)
| otherwise = packageKey ipi | otherwise = packageKey ipi
-- | Takes the "reexported-modules" field of an InstalledPackageInfo
-- and resolves the references so they point to the original exporter
-- of a module (i.e. the module is in exposed-modules, not
-- reexported-modules). This is done by maintaining an invariant on
-- the installed package database that a reexported-module field always
-- points to the original exporter.
resolveReexports :: PackageDBStack
-> InstalledPackageInfo
-> IO InstalledPackageInfo
resolveReexports db_stack pkg = do
let dep_mask = Set.fromList (depends pkg)
deps = filter (flip Set.member dep_mask . installedPackageId)
(allPackagesInStack db_stack)
matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep))
(filter (==m) (exposedModules pkg_dep))
worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep
| pnm /= packageName (sourcePackageId pkg_dep) = []
-- Now, either the package matches, *or* we were asked to search the
-- true location ourselves.
worker ModuleExport{ exportOrigName = m } pkg_dep =
matchExposed pkg_dep m ++
map (fromMaybe (error $ "Impossible! Missing true location in " ++
display (installedPackageId pkg_dep))
. exportCachedTrueOrig)
(filter ((==m) . exportName) (reexportedModules pkg_dep))
self_reexports ModuleExport{ exportOrigPackageName = Just pnm }
| pnm /= packageName (sourcePackageId pkg) = []
self_reexports ModuleExport{ exportName = m', exportOrigName = m }
-- Self-reexport without renaming doesn't make sense
| m == m' = []
-- *Only* match against exposed modules!
| otherwise = matchExposed pkg m
r <- forM (reexportedModules pkg) $ \me -> do
case nub (concatMap (worker me) deps ++ self_reexports me) of
[c] -> return me { exportCachedTrueOrig = Just c }
[] -> die $ "Couldn't resolve reexport " ++ display me
cs -> die $ "Found multiple possible ways to resolve reexport " ++
display me ++ ": " ++ show cs
return (pkg { reexportedModules = r })
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Making changes to a package database -- Making changes to a package database
...@@ -1070,16 +1022,25 @@ convertPackageInfoToCacheFormat pkg = ...@@ -1070,16 +1022,25 @@ convertPackageInfoToCacheFormat pkg =
GhcPkg.haddockHTMLs = haddockHTMLs pkg, GhcPkg.haddockHTMLs = haddockHTMLs pkg,
GhcPkg.exposedModules = exposedModules pkg, GhcPkg.exposedModules = exposedModules pkg,
GhcPkg.hiddenModules = hiddenModules pkg, GhcPkg.hiddenModules = hiddenModules pkg,
GhcPkg.reexportedModules = [ GhcPkg.ModuleExport m ipid' m' GhcPkg.reexportedModules = map convertModuleReexport
| ModuleExport { (reexportedModules pkg),
exportName = m,
exportCachedTrueOrig =
Just (InstalledPackageId ipid', m')
} <- reexportedModules pkg
],
GhcPkg.exposed = exposed pkg, GhcPkg.exposed = exposed pkg,
GhcPkg.trusted = trusted pkg GhcPkg.trusted = trusted pkg
} }
where
convertModuleReexport :: ModuleReexport
-> GhcPkg.ModuleExport String ModuleName
convertModuleReexport
ModuleReexport {
moduleReexportName = m,
moduleReexportDefiningPackage = ipid',
moduleReexportDefiningName = m'
}
= GhcPkg.ModuleExport {
exportModuleName = m,
exportOriginalPackageId = display ipid',
exportOriginalModuleName = m'
}
instance GhcPkg.BinaryStringRep ModuleName where instance GhcPkg.BinaryStringRep ModuleName where
fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
...@@ -1559,7 +1520,9 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs ...@@ -1559,7 +1520,9 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkModules pkg checkDuplicateModules pkg
checkModuleFiles pkg
checkModuleReexports db_stack pkg
mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow? -- ToDo: check these somehow?
-- extra_libraries :: [String], -- extra_libraries :: [String],
...@@ -1693,9 +1656,8 @@ doesFileExistOnPath filenames paths = go fullFilenames ...@@ -1693,9 +1656,8 @@ doesFileExistOnPath filenames paths = go fullFilenames
go ((p, fp) : xs) = do b <- doesFileExist fp go ((p, fp) : xs) = do b <- doesFileExist fp
if b then return (Just p) else go xs if b then return (Just p) else go xs
-- XXX maybe should check reexportedModules too checkModuleFiles :: InstalledPackageInfo -> Validate ()
checkModules :: InstalledPackageInfo -> Validate () checkModuleFiles pkg = do
checkModules pkg = do
mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
where where
findModule modl = findModule modl =
...@@ -1707,6 +1669,58 @@ checkModules pkg = do ...@@ -1707,6 +1669,58 @@ checkModules pkg = do
when (isNothing m) $ when (isNothing m) $
verror ForceFiles ("cannot find any of " ++ show files) verror ForceFiles ("cannot find any of " ++ show files)
checkDuplicateModules :: InstalledPackageInfo -> Validate ()
checkDuplicateModules pkg
| null dups = return ()
| otherwise = verror ForceAll ("package has duplicate modules: " ++
unwords (map display dups))
where
dups = [ m | (m:_:_) <- group (sort mods) ]
mods = exposedModules pkg ++ hiddenModules pkg
++ map moduleReexportName (reexportedModules pkg)
checkModuleReexports :: PackageDBStack -> InstalledPackageInfo -> Validate ()
checkModuleReexports db_stack pkg =
mapM_ checkReexport (reexportedModules pkg)
where
all_pkgs = allPackagesInStack db_stack
ipix = PackageIndex.fromList all_pkgs
checkReexport ModuleReexport {
moduleReexportDefiningPackage = definingPkgId,
moduleReexportDefiningName = definingModule
} = case if definingPkgId == installedPackageId pkg
then Just pkg
else PackageIndex.lookupInstalledPackageId ipix definingPkgId of
Nothing
-> verror ForceAll ("module re-export refers to a non-existent " ++
"defining package: " ++
display definingPkgId)
Just definingPkg
| not (isIndirectDependency definingPkgId)
-> verror ForceAll ("module re-export refers to a defining " ++
"package that is not a direct (or indirect) " ++
"dependency of this package: " ++
display definingPkgId)
| definingModule `notElem` exposedModules definingPkg
-> verror ForceAll ("module (self) re-export refers to a module " ++
display definingModule ++ " " ++
"that is not defined and exposed in the " ++
"defining package " ++ display definingPkgId)
| otherwise
-> return ()
isIndirectDependency pkgid = fromMaybe False $ do
thispkg <- graphVertex (installedPackageId pkg)
otherpkg <- graphVertex pkgid
return (Graph.path depgraph thispkg otherpkg)
(depgraph, _, graphVertex) =
PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
| auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
...@@ -2002,144 +2016,3 @@ removeFileSafe fn = ...@@ -2002,144 +2016,3 @@ removeFileSafe fn =
absolutePath :: FilePath -> IO FilePath absolutePath :: FilePath -> IO FilePath
absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
-----------------------------------------------------------------------------
-- Binary instances for the Cabal InstalledPackageInfo types
--
instance Binary m => Binary (InstalledPackageInfo_ m) where
put = putInstalledPackageInfo
get = getInstalledPackageInfo
putInstalledPackageInfo :: Binary m => InstalledPackageInfo_ m -> Put
putInstalledPackageInfo ipi = do
put (sourcePackageId ipi)
put (installedPackageId ipi)
put (packageKey ipi)
put (license ipi)
put (copyright ipi)
put (maintainer ipi)
put (author ipi)
put (stability ipi)
put (homepage ipi)
put (pkgUrl ipi)
put (synopsis ipi)
put (description ipi)
put (category ipi)
put (exposed ipi)
put (exposedModules ipi)
put (reexportedModules ipi)
put (hiddenModules ipi)
put (trusted ipi)
put (importDirs ipi)
put (libraryDirs ipi)
put (hsLibraries ipi)
put (extraLibraries ipi)
put (extraGHCiLibraries ipi)
put (includeDirs ipi)
put (includes ipi)
put (depends ipi)
put (hugsOptions ipi)
put (ccOptions ipi)
put (ldOptions ipi)
put (frameworkDirs ipi)
put (frameworks ipi)
put (haddockInterfaces ipi)
put (haddockHTMLs ipi)
getInstalledPackageInfo :: Binary m => Get (InstalledPackageInfo_ m)
getInstalledPackageInfo = do
sourcePackageId <- get
installedPackageId <- get
packageKey <- get
license <- get
copyright <- get
maintainer <- get
author <- get
stability <- get
homepage <- get
pkgUrl <- get
synopsis <- get
description <- get
category <- get
exposed <- get
exposedModules <- get
reexportedModules <- get
hiddenModules <- get
trusted <- get
importDirs <- get
libraryDirs <- get
hsLibraries <- get
extraLibraries <- get
extraGHCiLibraries <- get
includeDirs <- get
includes <- get
depends <- get
hugsOptions <- get
ccOptions <- get
ldOptions <- get
frameworkDirs <- get
frameworks <- get
haddockInterfaces <- get
haddockHTMLs <- get
return InstalledPackageInfo{..}
instance Binary PackageIdentifier where
put pid = do put (pkgName pid); put (pkgVersion pid)
get = do
pkgName <- get
pkgVersion <- get
return PackageIdentifier{..}
instance Binary License where
put (GPL v) = do putWord8 0; put v
put (LGPL v) = do putWord8 1; put v
put BSD3 = do putWord8 2
put BSD4 = do putWord8 3
put MIT = do putWord8 4
put PublicDomain = do putWord8 5
put AllRightsReserved = do putWord8 6
put OtherLicense = do putWord8 7
put (Apache v) = do putWord8 8; put v
put (AGPL v) = do putWord8 9; put v
put BSD2 = do putWord8 10
put (MPL v) = do putWord8 11; put v
put (UnknownLicense str) = do putWord8 12; put str
get = do
n <- getWord8
case n of
0 -> do v <- get; return (GPL v)
1 -> do v <- get; return (LGPL v)
2 -> return BSD3
3 -> return BSD4
4 -> return MIT
5 -> return PublicDomain
6 -> return AllRightsReserved
7 -> return OtherLicense
8 -> do v <- get; return (Apache v)
9 -> do v <- get; return (AGPL v)
10 -> return BSD2
11 -> do v <- get; return (MPL v)
_ -> do str <- get; return (UnknownLicense str)
deriving instance Binary PackageName
deriving instance Binary InstalledPackageId
instance Binary ModuleName where
put = put . display
get = fmap ModuleName.fromString get
instance Binary m => Binary (ModuleExport m) where
put (ModuleExport a b c d) = do put a; put b; put c; put d
get = do a <- get; b <- get; c <- get; d <- get;
return (ModuleExport a b c d)
instance Binary PackageKey where
put (PackageKey a b c) = do putWord8 0; put a; put b; put c
put (OldPackageKey a) = do putWord8 1; put a
get = do n <- getWord8
case n of
0 -> do a <- get; b <- get; c <- get; return (PackageKey a b c)
1 -> do a <- get; return (OldPackageKey a)
_ -> fail ("Binary PackageKey: bad branch " ++ show n)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment