Commit dabd9d98 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by GitHub
Browse files

Make `PackageName` type opaque (#3896)

When looking at heap-profiles of `cabal-install`, the `(:)` constructor
stands out as the most-allocated constructor on the heap.

Having to handle 10k+ package names contributes to the allocation
numbers, especially on 64bit archs where ASCII `String`s have a 24 byte
per character footprint.

This commit is a preparatory commit to pave the way for changing
`PackageName`'s internal representation to something like
`ShortByteString` (which is essentially a thin wrapper around primitive
`ByteArray#`s which themselves have have an overhead of 2 words + one
byte per ASCII character rounded up to nearest word) which would allow
to reduce the memory footprint by a full order of magnitude, as well as
reduce pointer chasing and GC overhead.
parent 2ccfce17
......@@ -133,7 +133,7 @@ instance IsNode InstalledPackageInfo where
emptyInstalledPackageInfo :: InstalledPackageInfo
emptyInstalledPackageInfo
= InstalledPackageInfo {
sourcePackageId = PackageIdentifier (PackageName "") (Version [] []),
sourcePackageId = PackageIdentifier (mkPackageName "") (Version [] []),
installedUnitId = mkUnitId "",
compatPackageKey = "",
license = UnspecifiedLicense,
......
......@@ -18,7 +18,7 @@
module Distribution.Package (
-- * Package ids
PackageName(..),
PackageName, unPackageName, mkPackageName,
PackageIdentifier(..),
PackageId,
......@@ -65,16 +65,39 @@ import Distribution.ModuleName
import Text.PrettyPrint ((<+>), text)
newtype PackageName = PackageName { unPackageName :: String }
-- | A package name.
--
-- Use 'mkPackageName' and 'unPackageName' to convert from/to a
-- 'String'.
--
-- This type is opaque since @Cabal-2.0@
--
-- @since 2.0
newtype PackageName = PackageName String
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- | Convert 'PackageName' to 'String'
unPackageName :: PackageName -> String
unPackageName (PackageName s) = s
-- | Construct a 'PackageName' from a 'String'
--
-- 'mkPackageName' is the inverse to 'unPackageName'
--
-- Note: No validations are performed to ensure that the resulting
-- 'PackageName' is valid
--
-- @since 2.0
mkPackageName :: String -> PackageName
mkPackageName = PackageName
instance Binary PackageName
instance Text PackageName where
disp (PackageName n) = Disp.text n
disp = Disp.text . unPackageName
parse = do
ns <- Parse.sepBy1 component (Parse.char '-')
return (PackageName (intercalate "-" ns))
return (mkPackageName (intercalate "-" ns))
where
component = do
cs <- Parse.munch1 isAlphaNum
......
......@@ -166,7 +166,7 @@ checkSanity :: PackageDescription -> [PackageCheck]
checkSanity pkg =
catMaybes [
check (null . (\(PackageName n) -> n) . packageName $ pkg) $
check (null . unPackageName . packageName $ pkg) $
PackageBuildImpossible "No 'name' field."
, check (null . versionBranch . packageVersion $ pkg) $
......@@ -536,7 +536,7 @@ checkFields pkg =
, name `elem` map display knownLanguages ]
testedWithImpossibleRanges =
[ Dependency (PackageName (display compiler)) vr
[ Dependency (mkPackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, isNoVersion vr ]
......@@ -1199,7 +1199,7 @@ checkCabalVersion pkg =
, usesNewVersionRangeSyntax vr ]
testedWithVersionRangeExpressions =
[ Dependency (PackageName (display compiler)) vr
[ Dependency (mkPackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, usesNewVersionRangeSyntax vr ]
......@@ -1249,7 +1249,7 @@ checkCabalVersion pkg =
, (name, _) <- Map.toList (targetBuildRenaming bi) ]
testedWithUsingWildcardSyntax =
[ Dependency (PackageName (display compiler)) vr
[ Dependency (mkPackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, usesWildcardSyntax vr ]
......@@ -1432,7 +1432,8 @@ checkPackageVersions pkg =
foldr intersectVersionRanges anyVersion baseDeps
where
baseDeps =
[ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]
[ vr | Dependency pname vr <- buildDepends pkg'
, pname == mkPackageName "base" ]
-- Just in case finalizePD fails for any reason,
-- or if the package doesn't depend on the base package at all,
......
......@@ -636,7 +636,7 @@ parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName
-- like parsePackageName but accepts symbols in components
parseBuildToolName :: ReadP r PackageName
parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')
return (PackageName (intercalate "-" ns))
return (mkPackageName (intercalate "-" ns))
where component = do
cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
if all isDigit cs then pfail else return cs
......@@ -649,7 +649,7 @@ parsePkgconfigDependency = do name <- munch1
(\c -> isAlphaNum c || c `elem` "+-._")
ver <- betweenSpaces $
parseVersionRangeQ <++ return anyVersion
return $ Dependency (PackageName name) ver
return $ Dependency (mkPackageName name) ver
parsePackageNameQ :: ReadP r PackageName
parsePackageNameQ = parseQuoted parse <++ parse
......
......@@ -461,7 +461,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
-- | The stub executable needs a new 'ComponentLocalBuildInfo'
-- that exposes the relevant test suite library.
deps = (IPI.installedUnitId ipi, packageId ipi)
: (filter (\(_, x) -> let PackageName name = pkgName x
: (filter (\(_, x) -> let name = unPackageName $ pkgName x
in name == "Cabal" || name == "base")
(componentPackageDeps clbi))
exeClbi = ExeComponentLocalBuildInfo {
......@@ -512,7 +512,7 @@ addInternalBuildTools pkg lbi bi progs =
internalExeNames = map exeName (executables pkg)
buildToolNames = map buildToolName (buildTools bi)
where
buildToolName (Dependency (PackageName name) _ ) = name
buildToolName (Dependency pname _ ) = unPackageName pname
-- TODO: build separate libs in separate dirs so that we can build
......
......@@ -244,11 +244,11 @@ writePersistBuildConfig distPref lbi = do
-- | Identifier of the current Cabal package.
currentCabalId :: PackageIdentifier
currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion
currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion
-- | Identifier of the current compiler package.
currentCompilerId :: PackageIdentifier
currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)
currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName)
System.Info.compilerVersion
-- | Parse the @setup-config@ file header, returning the package identifiers
......@@ -614,10 +614,10 @@ configure (pkg_descr0', pbi) cfg = do
[ buildTool
| let exeNames = map exeName (executables pkg_descr)
, bi <- enabledBuildInfos pkg_descr enabled
, buildTool@(Dependency (PackageName toolName) reqVer)
, buildTool@(Dependency toolPName reqVer)
<- buildTools bi
, let isInternal =
toolName `elem` exeNames
unPackageName toolPName `elem` exeNames
-- we assume all internal build-tools are
-- versioned with the package:
&& packageVersion pkg_descr `withinRange` reqVer
......@@ -855,7 +855,7 @@ getInternalPackages pkg_descr0 =
let pkg_descr = flattenPackageDescription pkg_descr0
f lib = case libName lib of
Nothing -> (packageName pkg_descr, CLibName)
Just n' -> (PackageName n', CSubLibName n')
Just n' -> (mkPackageName n', CSubLibName n')
in Map.fromList (map f (allLibraries pkg_descr))
-- | Returns true if a dependency is satisfiable. This function
......@@ -1427,7 +1427,7 @@ configureRequiredPrograms verbosity deps progdb =
configureRequiredProgram :: Verbosity -> ProgramDb -> Dependency
-> IO ProgramDb
configureRequiredProgram verbosity progdb
(Dependency (PackageName progName) verRange) =
(Dependency progPkgName verRange) =
case lookupKnownProgram progName progdb of
Nothing ->
-- Try to configure it as a 'simpleProgram' automatically
......@@ -1442,6 +1442,8 @@ configureRequiredProgram verbosity progdb
| otherwise -> do
(_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb
return progdb'
where
progName = unPackageName progPkgName
-- -----------------------------------------------------------------------------
-- Configuring pkg-config package dependencies
......@@ -1471,7 +1473,7 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled
pkgconfig = getDbProgramOutput (lessVerbose verbosity)
pkgConfigProgram progdb
requirePkg dep@(Dependency (PackageName pkg) range) = do
requirePkg dep@(Dependency pkgn range) = do
version <- pkgconfig ["--modversion", pkg]
`catchIO` (\_ -> die notFound)
`catchExit` (\_ -> die notFound)
......@@ -1494,6 +1496,8 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled
| isAnyVersion range = ""
| otherwise = " version " ++ display range
pkg = unPackageName pkgn
-- Adds pkgconfig dependencies to the build info for a component
addPkgConfigBI compBI setCompBI comp = do
bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))
......@@ -1617,11 +1621,9 @@ mkComponentsGraph enabled pkg_descr internalPackageSet =
where
-- The dependencies for the given component
componentDeps component =
[ CExeName toolname | Dependency (PackageName toolname) _
<- buildTools bi
, toolname `elem` map exeName
(executables pkg_descr) ]
[ CExeName (unPackageName toolpname)
| Dependency toolpname _ <- buildTools bi
, unPackageName toolpname `elem` map exeName (executables pkg_descr) ]
++ [ cname
| Dependency pkgname _ <- targetBuildDepends bi
, cname <- Maybe.maybeToList (Map.lookup pkgname internalPackageSet) ]
......@@ -1721,8 +1723,8 @@ computeCompatPackageName pkg_name cname
go ('-':z) _ r = go z (Just 0) ('-':r)
go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)
go (c:z) _ r = go z Nothing (c:r)
in PackageName $ "z-" ++ zdashcode (display pkg_name)
++ "-z-" ++ zdashcode cname_str
in mkPackageName $ "z-" ++ zdashcode (display pkg_name)
++ "-z-" ++ zdashcode cname_str
| otherwise
= pkg_name
......
......@@ -292,7 +292,7 @@ getInstalledPackages verbosity comp packagedbs progdb = do
where
hackRtsPackage index =
case PackageIndex.lookupPackageName index (PackageName "rts") of
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
[(_,[rts])]
-> PackageIndex.insert (removeMingwIncludeDir rts) index
_ -> index -- No (or multiple) ghc rts package is registered!!
......
......@@ -32,7 +32,7 @@ data PackageIdentifier = PackageIdentifier {
convertPackageId :: PackageIdentifier -> Current.PackageIdentifier
convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } =
Current.PackageIdentifier (Current.PackageName n) v
Current.PackageIdentifier (Current.mkPackageName n) v
data License = GPL | LGPL | BSD3 | BSD4
| PublicDomain | AllRightsReserved | OtherLicense
......
......@@ -593,7 +593,7 @@ haddockPackagePaths ipkgs mkHtmlPath = do
where
-- Don't warn about missing documentation for these packages. See #1231.
noHaddockWhitelist = map PackageName [ "rts" ]
noHaddockWhitelist = map mkPackageName [ "rts" ]
-- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
interfaceAndHtmlPath :: InstalledPackageInfo
......
......@@ -467,11 +467,11 @@ lookupDependency index (Dependency name versionRange) =
--
searchByName :: PackageIndex a -> String -> SearchResult [a]
searchByName index name =
case [ pkgs | pkgs@(PackageName name',_) <- Map.toList (packageIdIndex index)
, lowercase name' == lname ] of
case [ pkgs | pkgs@(pname,_) <- Map.toList (packageIdIndex index)
, lowercase (unPackageName pname) == lname ] of
[] -> None
[(_,pvers)] -> Unambiguous (concat (Map.elems pvers))
pkgss -> case find ((PackageName name==) . fst) pkgss of
pkgss -> case find ((mkPackageName name ==) . fst) pkgss of
Just (_,pvers) -> Unambiguous (concat (Map.elems pvers))
Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss)
where lname = lowercase name
......@@ -485,8 +485,8 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a]
searchByNameSubstring :: PackageIndex a -> String -> [a]
searchByNameSubstring index searchterm =
[ pkg
| (PackageName name, pvers) <- Map.toList (packageIdIndex index)
, lsearchterm `isInfixOf` lowercase name
| (pname, pvers) <- Map.toList (packageIdIndex index)
, lsearchterm `isInfixOf` lowercase (unPackageName pname)
, pkgs <- Map.elems pvers
, pkg <- pkgs ]
where lsearchterm = lowercase searchterm
......
......@@ -450,7 +450,7 @@ ppHsc2hs bi lbi clbi =
-- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the
-- ldOptions for GHC's rts package:
hackRtsPackage index =
case PackageIndex.lookupPackageName index (PackageName "rts") of
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
[(_, [rts])]
-> PackageIndex.insert rts { Installed.ldOptions = [] } index
_ -> error "No (or multiple) ghc rts package is registered!!"
......
......@@ -171,7 +171,7 @@ descCabalVersion pkg = case specVersionRaw pkg of
emptyPackageDescription :: PackageDescription
emptyPackageDescription
= PackageDescription {
package = PackageIdentifier (PackageName "")
package = PackageIdentifier (mkPackageName "")
(Version [] []),
license = UnspecifiedLicense,
licenseFiles = [],
......
......@@ -46,6 +46,9 @@
If you only need to test if a component is buildable
(i.e., it is marked buildable in the Cabal file)
use the new function 'componentBuildable'.
* Backwards incompatible change to 'PackageName' (#3896):
'PackageName' is now opaque; conversion to/from 'String' now works
via (old) 'unPackageName' and (new) 'mkPackageName' functions.
* Add support for `--allow-older` (dual to `--allow-newer`) (#3466)
* Improved an error message for process output decoding errors
(#3408).
......
......@@ -19,7 +19,7 @@ suite = do
"dummy.hs"
, benchmarkBuildInfo = emptyBuildInfo
{ targetBuildDepends =
[ Dependency (PackageName "base") anyVersion ]
[ Dependency (mkPackageName "base") anyVersion ]
, hsSourceDirs = ["."]
}
}
......
......@@ -20,9 +20,9 @@ suite = do
{ libBuildInfo = emptyBuildInfo
{ defaultLanguage = Just Haskell2010
, targetBuildDepends =
[ Dependency (PackageName{unPackageName = "base"})
[ Dependency (mkPackageName "base")
(withinVersion (Version [4] []))
, Dependency (PackageName{unPackageName = "pretty"})
, Dependency (mkPackageName "pretty")
(majorBoundVersion (Version [1,1,1,0] []))
]
, hsSourceDirs = ["."]
......
......@@ -18,7 +18,7 @@ suite = do
, testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"
, testBuildInfo = emptyBuildInfo
{ targetBuildDepends =
[ Dependency (PackageName "base") anyVersion ]
[ Dependency (mkPackageName "base") anyVersion ]
, hsSourceDirs = ["."]
}
}
......
......@@ -34,7 +34,7 @@ import Distribution.Client.Utils
import qualified Paths_cabal_install (version)
import Distribution.Package
( PackageIdentifier(..), PackageName(..) )
( PackageIdentifier(..), mkPackageName )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
--import Distribution.Version
......@@ -159,7 +159,7 @@ new os' arch' comp pkgid flags deps result =
cabalInstallID :: PackageIdentifier
cabalInstallID =
PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version
PackageIdentifier (mkPackageName "cabal-install") Paths_cabal_install.version
-- ------------------------------------------------------------
-- * External format
......
......@@ -74,7 +74,7 @@ import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Targets
import Distribution.Package
( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId
( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId
, Package(..), packageName, packageVersion
, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
......@@ -347,9 +347,9 @@ dontUpgradeNonUpgradeablePackages params =
[ LabeledPackageConstraint
(PackageConstraintInstalled pkgname)
ConstraintSourceNonUpgradeablePackage
| Set.notMember (PackageName "base") (depResolverTargets params)
, pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple" ]
| Set.notMember (mkPackageName "base") (depResolverTargets params)
, pkgname <- map mkPackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple" ]
, isInstalled pkgname ]
isInstalled = not . null
......@@ -520,7 +520,7 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
-- Force Cabal >= 1.24 dep when the package is affected by #3199.
mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
mkDefaultSetupDeps srcpkg | affected =
Just [Dependency (PackageName "Cabal")
Just [Dependency (mkPackageName "Cabal")
(orLaterVersion $ Version [1,24] [])]
| otherwise = Nothing
where
......
......@@ -25,7 +25,7 @@ import Distribution.Client.Sandbox.Types
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), RepoContext )
import Distribution.Package
( Package(..), Dependency(..), PackageName(..)
( Package(..), Dependency(..), unPackageName
, packageName, packageVersion )
import Distribution.PackageDescription
( buildDepends )
......@@ -139,7 +139,7 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs
depName :: Dependency -> String
depName (Dependency (PackageName nm) _) = nm
depName (Dependency pn _) = unPackageName pn
depVersion :: Dependency -> VersionRange
depVersion (Dependency _ vr) = vr
......
......@@ -47,7 +47,7 @@ import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.Types
import Distribution.Package
( PackageId, PackageIdentifier(..), PackageName(..)
( PackageId, PackageIdentifier(..), mkPackageName
, Package(..), packageVersion, packageName
, Dependency(Dependency) )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
......@@ -434,7 +434,7 @@ extractPkg entry blockNo = case Tar.entryContent entry of
[pkgname,vers,_] -> case simpleParse vers of
Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
where
pkgid = PackageIdentifier (PackageName pkgname) ver
pkgid = PackageIdentifier (mkPackageName pkgname) ver
parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack
$ content
descr = case parsed of
......@@ -871,7 +871,7 @@ read00IndexCacheEntry = \line ->
where
parseName str
| BSS.all (\c -> isAlphaNum c || c == '-') str
= Just (PackageName (BSS.unpack str))
= Just (mkPackageName (BSS.unpack str))
| otherwise = Nothing
parseVer str vs =
......
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