From d9e9a9b3016a05e6153de3803998877f91c6cdf4 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 15 May 2017 21:17:45 -0700
Subject: [PATCH] Fix #13703 by correctly using munged names in ghc-pkg.
Summary:
Cabal internal libraries are implemented using a trick, where the 'name'
field in ghc-pkg registration file is munged into a new form to keep
each internal library looking like a distinct package to ghc-pkg and
other tools; e.g. the internal library q from package p is named
z-p-z-q.
Later, Cabal library got refactored so that we made a closer distinction
between these "munged" package names and the true package name of a
package. Unfortunately, this is an example of a refactor for clarity in
the source code which ends up causing problems downstream, because the
point of "munging" the package name was to make it so that ghc-pkg and
similar tools transparently used MungedPackageName whereever they
previously used PackageName (in preparation for them learning proper
syntax for package name + component name). Failing to do this meant
that internal libraries from the same package (but with different
names) clobber each other.
This commit search-replaces most occurrences of PackageName in
ghc-pkg and turns them into MungedPackageName. Otherwise there
shouldn't be any functional differenes.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate
Reviewers: bgamari, austin
Subscribers: rwbarton, thomie
GHC Trac Issues: #13703
Differential Revision: https://phabricator.haskell.org/D3590
---
testsuite/.gitignore | 1 +
testsuite/tests/cabal/Makefile | 8 ++++
testsuite/tests/cabal/T13703.stdout | 4 ++
testsuite/tests/cabal/all.T | 2 +
testsuite/tests/cabal/test13703a.pkg | 20 +++++++++
testsuite/tests/cabal/test13703b.pkg | 20 +++++++++
utils/ghc-pkg/Main.hs | 66 ++++++++++++++--------------
7 files changed, 89 insertions(+), 32 deletions(-)
create mode 100644 testsuite/tests/cabal/T13703.stdout
create mode 100644 testsuite/tests/cabal/test13703a.pkg
create mode 100644 testsuite/tests/cabal/test13703b.pkg
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 21920ab4fe81..e6934f966acf 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -109,6 +109,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
/tests/boxy/T2193
/tests/cabal/1750.hs
/tests/cabal/1750.out
+/tests/cabal/T13703.package.conf/
/tests/cabal/T1750.hs
/tests/cabal/T1750.out
/tests/cabal/cabal01/dist/
diff --git a/testsuite/tests/cabal/Makefile b/testsuite/tests/cabal/Makefile
index 64034d4ac4e5..791e3269f0fd 100644
--- a/testsuite/tests/cabal/Makefile
+++ b/testsuite/tests/cabal/Makefile
@@ -287,3 +287,11 @@ ghcpkg07:
recache_reexport:
@rm -rf recache_reexport_db/package.cache
'$(GHC_PKG)' --no-user-package-db --global-package-db=recache_reexport_db recache
+
+T13703:
+ @rm -rf T13703.package.conf
+ '$(GHC_PKG)' init T13703.package.conf
+ '$(GHC_PKG)' --no-user-package-db -f T13703.package.conf register --force test13703a.pkg 2>/dev/null
+ '$(GHC_PKG)' --no-user-package-db -f T13703.package.conf register --force test13703b.pkg 2>/dev/null
+ '$(GHC_PKG)' --no-user-package-db -f T13703.package.conf field z-p-z-q lib-name
+ '$(GHC_PKG)' --no-user-package-db -f T13703.package.conf field z-p-z-r lib-name
diff --git a/testsuite/tests/cabal/T13703.stdout b/testsuite/tests/cabal/T13703.stdout
new file mode 100644
index 000000000000..5d5503b00034
--- /dev/null
+++ b/testsuite/tests/cabal/T13703.stdout
@@ -0,0 +1,4 @@
+Reading package info from "test13703a.pkg" ... done.
+Reading package info from "test13703b.pkg" ... done.
+lib-name: q
+lib-name: r
diff --git a/testsuite/tests/cabal/all.T b/testsuite/tests/cabal/all.T
index 23c4826e3504..82c1b1584bcc 100644
--- a/testsuite/tests/cabal/all.T
+++ b/testsuite/tests/cabal/all.T
@@ -52,3 +52,5 @@ test('T5442d', [extra_files(['shadow1.pkg', 'shadow2.pkg', 'shadow4.pkg'])], run
test('shadow', [], run_command, ['$MAKE -s --no-print-directory shadow'])
test('T12485a', [extra_files(['shadow1.pkg', 'shadow2.pkg', 'shadow3.pkg'])], run_command, ['$MAKE -s --no-print-directory T12485a'])
+
+test('T13703', [extra_files(['test13703a.pkg', 'test13703b.pkg'])], run_command, ['$MAKE -s --no-print-directory T13703'])
diff --git a/testsuite/tests/cabal/test13703a.pkg b/testsuite/tests/cabal/test13703a.pkg
new file mode 100644
index 000000000000..55d3b38a1f70
--- /dev/null
+++ b/testsuite/tests/cabal/test13703a.pkg
@@ -0,0 +1,20 @@
+name: z-p-z-q
+version: 1.2.3.4
+id: p-1.2.3.4-XXX-q
+key: p-1.2.3.4-XXX-q
+package-name: p
+lib-name: q
+license: BSD3
+copyright: (c) The University of Glasgow 2004
+maintainer: glasgow-haskell-users@haskell.org
+stability: stable
+homepage: http://www.haskell.org/ghc
+package-url: http://www.haskell.org/ghc
+description: A Test Package
+category: none
+author: simonmar@microsoft.com
+exposed: True
+exposed-modules: A
+import-dirs: /usr/local/lib/testpkg
+library-dirs: /usr/local/lib/testpkg
+include-dirs: /usr/local/include/testpkg
diff --git a/testsuite/tests/cabal/test13703b.pkg b/testsuite/tests/cabal/test13703b.pkg
new file mode 100644
index 000000000000..f04b7b1b2357
--- /dev/null
+++ b/testsuite/tests/cabal/test13703b.pkg
@@ -0,0 +1,20 @@
+name: z-p-z-r
+version: 1.2.3.4
+id: p-1.2.3.4-XXX-r
+key: p-1.2.3.4-XXX-r
+package-name: p
+lib-name: r
+license: BSD3
+copyright: (c) The University of Glasgow 2004
+maintainer: glasgow-haskell-users@haskell.org
+stability: stable
+homepage: http://www.haskell.org/ghc
+package-url: http://www.haskell.org/ghc
+description: A Test Package
+category: none
+author: simonmar@microsoft.com
+exposed: True
+exposed-modules: A
+import-dirs: /usr/local/lib/testpkg
+library-dirs: /usr/local/lib/testpkg
+include-dirs: /usr/local/include/testpkg
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 80ff77c24b86..9074acfd4cf5 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -42,6 +42,8 @@ import Distribution.Text
import Distribution.Version
import Distribution.Backpack
import Distribution.Types.UnqualComponentName
+import Distribution.Types.MungedPackageName
+import Distribution.Types.MungedPackageId
import Distribution.Simple.Utils (fromUTF8, toUTF8, writeUTF8File, readUTF8File)
import qualified Data.Version as Version
import System.FilePath as FilePath
@@ -509,8 +511,8 @@ parseCheck parser str what =
-- | Either an exact 'PackageIdentifier', or a glob for all packages
-- matching 'PackageName'.
data GlobPackageIdentifier
- = ExactPackageIdentifier PackageIdentifier
- | GlobPackageIdentifier PackageName
+ = ExactPackageIdentifier MungedPackageId
+ | GlobPackageIdentifier MungedPackageName
displayGlobPkgId :: GlobPackageIdentifier -> String
displayGlobPkgId (ExactPackageIdentifier pid) = display pid
@@ -1114,7 +1116,7 @@ registerPackage input verbosity my_flags multi_instance
-- report any warnings from the parse phase
_ <- reportValidateErrors verbosity [] ws
- (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+ (display (mungedId pkg) ++ ": Warning: ") Nothing
-- validate the expanded pkg, but register the unexpanded
pkgroot <- absolutePath (takeDirectory to_modify)
@@ -1135,7 +1137,7 @@ registerPackage input verbosity my_flags multi_instance
removes = [ RemovePackage p
| not multi_instance,
p <- packages db_to_operate_on,
- sourcePackageId p == sourcePackageId pkg,
+ mungedId p == mungedId pkg,
-- Only remove things that were instantiated the same way!
instantiatedWith p == instantiatedWith pkg ]
--
@@ -1357,11 +1359,11 @@ modifyPackage fn pkgarg verbosity my_flags force = do
. installedUnitId) new_broken
--
let displayQualPkgId pkg
- | [_] <- filter ((== pkgid) . sourcePackageId)
+ | [_] <- filter ((== pkgid) . mungedId)
(allPackagesInStack db_stack)
= display pkgid
| otherwise = display pkgid ++ "@" ++ display (installedUnitId pkg)
- where pkgid = sourcePackageId pkg
+ where pkgid = mungedId pkg
when (not (null newly_broken)) $
dieOrForceAll force ("unregistering would break the following packages: "
++ unwords (map displayQualPkgId newly_broken))
@@ -1401,14 +1403,14 @@ listPackages verbosity my_flags mPackageName mModuleName = do
| db <- db_stack_filtered ]
where sort_pkgs = sortBy cmpPkgIds
cmpPkgIds pkg1 pkg2 =
- case pkgName p1 `compare` pkgName p2 of
+ case mungedName p1 `compare` mungedName p2 of
LT -> LT
GT -> GT
- EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
+ EQ -> case mungedVersion p1 `compare` mungedVersion p2 of
LT -> LT
GT -> GT
EQ -> installedUnitId pkg1 `compare` installedUnitId pkg2
- where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
+ where (p1,p2) = (mungedId pkg1, mungedId pkg2)
stack = reverse db_stack_sorted
@@ -1430,7 +1432,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
where doc | verbosity >= Verbose = printf "%s (%s)" pkg (display (installedUnitId p))
| otherwise = pkg
where
- pkg = display (sourcePackageId p)
+ pkg = display (mungedId p)
show_simple = simplePackageList my_flags . allPackagesInStack
@@ -1461,7 +1463,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
| otherwise
= termText pkg
where
- pkg = display (sourcePackageId p)
+ pkg = display (mungedId p)
is_tty <- hIsTerminalDevice stdout
if not is_tty
@@ -1475,9 +1477,9 @@ listPackages verbosity my_flags mPackageName mModuleName = do
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
simplePackageList my_flags pkgs = do
- let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+ let showPkg = if FlagNamesOnly `elem` my_flags then display . mungedName
else display
- strs = map showPkg $ map sourcePackageId pkgs
+ strs = map showPkg $ map mungedId pkgs
when (not (null pkgs)) $
hPutStrLn stdout $ concat $ intersperse " " strs
@@ -1494,10 +1496,10 @@ showPackageDot verbosity myflags = do
let quote s = '"':s ++ "\""
mapM_ putStrLn [ quote from ++ " -> " ++ quote to
| p <- all_pkgs,
- let from = display (sourcePackageId p),
+ let from = display (mungedId p),
key <- depends p,
Just dep <- [PackageIndex.lookupUnitId ipix key],
- let to = display (sourcePackageId dep)
+ let to = display (mungedId dep)
]
putStrLn "}"
@@ -1515,7 +1517,7 @@ latestPackage verbosity my_flags pkgid = do
ps <- findPackages flag_db_stack (Id pkgid)
case ps of
[] -> die "no matches"
- _ -> show_pkg . maximum . map sourcePackageId $ ps
+ _ -> show_pkg . maximum . map mungedId $ ps
where
show_pkg pid = hPutStrLn stdout (display pid)
@@ -1578,17 +1580,17 @@ cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg
pkg_msg (IUId ipid) = display ipid
pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
-matches :: GlobPackageIdentifier -> PackageIdentifier -> Bool
+matches :: GlobPackageIdentifier -> MungedPackageId -> Bool
GlobPackageIdentifier pn `matches` pid'
- = (pn == pkgName pid')
+ = (pn == mungedName pid')
ExactPackageIdentifier pid `matches` pid'
- = pkgName pid == pkgName pid' &&
- (pkgVersion pid == pkgVersion pid' || pkgVersion pid == nullVersion)
+ = mungedName pid == mungedName pid' &&
+ (mungedVersion pid == mungedVersion pid' || mungedVersion pid == nullVersion)
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
-(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(Id pid) `matchesPkg` pkg = pid `matches` mungedId pkg
(IUId ipid) `matchesPkg` pkg = ipid == installedUnitId pkg
-(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
+(Substring _ m) `matchesPkg` pkg = m (display (mungedId pkg))
-- -----------------------------------------------------------------------------
-- Field
@@ -1635,7 +1637,7 @@ checkConsistency verbosity my_flags = do
return []
else do
when (not simple_output) $ do
- reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
+ reportError ("There are problems in package " ++ display (mungedId p) ++ ":")
_ <- reportValidateErrors verbosity es ws " " Nothing
return ()
return [p]
@@ -1643,8 +1645,8 @@ checkConsistency verbosity my_flags = do
broken_pkgs <- concat `fmap` mapM checkPackage pkgs
let filterOut pkgs1 pkgs2 = filter not_in pkgs2
- where not_in p = sourcePackageId p `notElem` all_ps
- all_ps = map sourcePackageId pkgs1
+ where not_in p = mungedId p `notElem` all_ps
+ all_ps = map mungedId pkgs1
let not_broken_pkgs = filterOut broken_pkgs pkgs
(_, trans_broken_pkgs) = closure [] not_broken_pkgs
@@ -1656,7 +1658,7 @@ checkConsistency verbosity my_flags = do
else do
reportError ("\nThe following packages are broken, either because they have a problem\n"++
"listed above, or because they depend on a broken package.")
- mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
+ mapM_ (hPutStrLn stderr . display . mungedId) all_broken_pkgs
when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
@@ -1750,7 +1752,7 @@ validatePackageConfig pkg verbosity db_stack
checkPackageConfig pkg verbosity db_stack
multi_instance update
ok <- reportValidateErrors verbosity es ws
- (display (sourcePackageId pkg) ++ ": ") (Just force)
+ (display (mungedId pkg) ++ ": ") (Just force)
when (not ok) $ exitWith (ExitFailure 1)
checkPackageConfig :: InstalledPackageInfo
@@ -1788,8 +1790,8 @@ checkPackageConfig pkg verbosity db_stack
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> Validate ()
checkPackageId ipi =
- let str = display (sourcePackageId ipi) in
- case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
+ let str = display (mungedId ipi) in
+ case [ x :: MungedPackageId | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
[] -> verror CannotForce ("invalid package identifier: " ++ str)
_ -> verror CannotForce ("ambiguous package identifier: " ++ str)
@@ -1813,19 +1815,19 @@ checkDuplicates :: PackageDBStack -> InstalledPackageInfo
-> Bool -> Bool-> Validate ()
checkDuplicates db_stack pkg multi_instance update = do
let
- pkgid = sourcePackageId pkg
+ pkgid = mungedId pkg
pkgs = packages (head db_stack)
--
-- Check whether this package id already exists in this DB
--
when (not update && not multi_instance
- && (pkgid `elem` map sourcePackageId pkgs)) $
+ && (pkgid `elem` map mungedId pkgs)) $
verror CannotForce $
"package " ++ display pkgid ++ " is already installed"
let
uncasep = map toLower . display
- dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
+ dups = filter ((== uncasep pkgid) . uncasep) (map mungedId pkgs)
when (not update && not multi_instance
&& not (null dups)) $ verror ForceAll $
--
GitLab