From 65198de48d158b95ecb407fb3f922294f34d7f79 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 27 Oct 2023 00:03:17 +0100 Subject: [PATCH] Add Haddock documentation and further types Renames the `ExtraGlobal` data constructor of `InstalledPackageLocation` as `ExtraPkgDb`. Provides types `PackageDatabase` and `PackageDbVariety`. The former replaces the use of `Maybe (InstalledPackageLocation, Path Abs Dir)`, where `Nothing` was used to represent the global package database (now there is data constructor `GlobalPkgDb`). The latter replaces the use of `Maybe InstalledPackageLocation`, where `Nothing` was also used to represent the global package database (now there is data constructor `GlobalDb`). Also updates and corrects existing Haddock documentation. For example `Sink` is deprecated as a type synonym. --- src/Stack/Build/Installed.hs | 183 +++++++++++++++++++++-------------- src/Stack/PackageDump.hs | 38 +++++--- src/Stack/Types/Package.hs | 57 +++++++++-- 3 files changed, 186 insertions(+), 92 deletions(-) diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 09ebdf8847..820000ce36 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- Determine which packages are already installed module Stack.Build.Installed @@ -30,6 +31,8 @@ import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.Package ( InstallLocation (..), InstallMap, Installed (..) , InstalledMap, InstalledPackageLocation (..) + , PackageDatabase (..), PackageDbVariety (..) + , toPackageDbVariety ) import Stack.Types.SourceMap ( DepPackage (..), ProjectPackage (..), SourceMap (..) ) @@ -66,15 +69,15 @@ getInstalled {-opts-} installMap = do let loadDatabase' = loadDatabase {-opts mcache-} installMap - (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing [] + (installedLibs0, globalDumpPkgs) <- loadDatabase' GlobalPkgDb [] (installedLibs1, _extraInstalled) <- foldM (\lhs' pkgdb -> - loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs') + loadDatabase' (UserPkgDb ExtraPkgDb pkgdb) (fst lhs') ) (installedLibs0, globalDumpPkgs) extraDBPaths (installedLibs2, snapshotDumpPkgs) <- - loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1 + loadDatabase' (UserPkgDb (InstalledTo Snap) snapDBPath) installedLibs1 (installedLibs3, localDumpPkgs) <- - loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2 + loadDatabase' (UserPkgDb (InstalledTo Local) localDBPath) installedLibs2 let installedLibs = Map.fromList $ map lhPair installedLibs3 -- Add in the executables that are installed, making sure to only trust a @@ -114,71 +117,83 @@ getInstalled {-opts-} installMap = do -- -- The goal is to ascertain that the dependencies for a package are present, -- that it has profiling if necessary, and that it matches the version and --- location needed by the SourceMap +-- location needed by the SourceMap. loadDatabase :: - HasEnvConfig env - => InstallMap -- ^ to determine which installed things we should include - -> Maybe (InstalledPackageLocation, Path Abs Dir) - -- ^ package database, Nothing for global - -> [LoadHelper] -- ^ from parent databases + forall env. HasEnvConfig env + => InstallMap + -- ^ to determine which installed things we should include + -> PackageDatabase + -- ^ package database. + -> [LoadHelper] + -- ^ from parent databases -> RIO env ([LoadHelper], [DumpPackage]) -loadDatabase installMap mdb lhs0 = do +loadDatabase installMap db lhs0 = do pkgexe <- getGhcPkgExe - (lhs1', dps) <- ghcPkgDump pkgexe (fmap snd (maybeToList mdb)) $ - conduitDumpPackage .| sink - lhs1 <- mapMaybeM (processLoadResult mdb) lhs1' + (lhs1', dps) <- ghcPkgDump pkgexe pkgDb $ conduitDumpPackage .| sink + lhs1 <- mapMaybeM processLoadResult lhs1' let lhs = pruneDeps id lhId lhDeps const (lhs0 ++ lhs1) pure (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps) where - mloc = fmap fst mdb - sinkDP = CL.map (isAllowed installMap mloc &&& toLoadHelper mloc) + pkgDb = case db of + GlobalPkgDb -> [] + UserPkgDb _ fp -> [fp] + + sinkDP = CL.map (isAllowed installMap db' &&& toLoadHelper db') .| CL.consume + where + db' = toPackageDbVariety db sink = getZipSink $ (,) <$> ZipSink sinkDP <*> ZipSink CL.consume -processLoadResult :: HasLogFunc env - => Maybe (InstalledPackageLocation, Path Abs Dir) - -> (Allowed, LoadHelper) - -> RIO env (Maybe LoadHelper) -processLoadResult _ (Allowed, lh) = pure (Just lh) -processLoadResult mdb (reason, lh) = do - logDebug $ - "Ignoring package " - <> fromString (packageNameString (fst (lhPair lh))) - <> maybe - mempty - ( \db -> ", from " - <> displayShow db - <> "," - ) - mdb - <> " due to" - <> case reason of - UnknownPkg -> " it being unknown to the resolver / extra-deps." - WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc) - WrongVersion actual wanted -> - " wanting version " - <> fromString (versionString wanted) - <> " instead of " - <> fromString (versionString actual) - pure Nothing + processLoadResult :: (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper) + processLoadResult (Allowed, lh) = pure (Just lh) + processLoadResult (reason, lh) = do + logDebug $ + "Ignoring package " + <> fromString (packageNameString (fst (lhPair lh))) + <> case db of + GlobalPkgDb -> mempty + UserPkgDb loc fp -> ", from " <> displayShow (loc, fp) <> "," + <> " due to" + <> case reason of + UnknownPkg -> " it being unknown to the resolver / extra-deps." + WrongLocation db' loc -> + " wrong location: " <> displayShow (db', loc) + WrongVersion actual wanted -> + " wanting version " + <> fromString (versionString wanted) + <> " instead of " + <> fromString (versionString actual) + pure Nothing +-- | Type representing results of 'isAllowed'. data Allowed = Allowed + -- ^ The installed package can be included in the set of relevant installed + -- packages. | UnknownPkg - | WrongLocation (Maybe InstalledPackageLocation) InstallLocation + -- ^ The installed package cannot be included in the set of relevant + -- installed packages because the package is unknown. + | WrongLocation PackageDbVariety InstallLocation + -- ^ The installed package cannot be included in the set of relevant + -- installed packages because the package is in the wrong package database. | WrongVersion Version Version + -- ^ The installed package cannot be included in the set of relevant + -- installed packages because the package has the wrong version. deriving (Eq, Show) --- | Check if a can be included in the set of installed packages or not, based --- on the package selections made by the user. This does not perform any --- dirtiness or flag change checks. -isAllowed :: InstallMap - -> Maybe InstalledPackageLocation - -> DumpPackage - -> Allowed -isAllowed installMap mloc dp = case Map.lookup name installMap of +-- | Check if an installed package can be included in the set of relevant +-- installed packages or not, based on the package selections made by the user. +-- This does not perform any dirtiness or flag change checks. +isAllowed :: + InstallMap + -> PackageDbVariety + -- ^ The package database providing the installed package. + -> DumpPackage + -- ^ The installed package to check. + -> Allowed +isAllowed installMap pkgDb dp = case Map.lookup name installMap of Nothing -> -- If the sourceMap has nothing to say about this package, -- check if it represents a sub-library first @@ -195,34 +210,50 @@ isAllowed installMap mloc dp = case Map.lookup name installMap of where PackageIdentifier name version = dpPackageIdent dp -- Ensure that the installed location matches where the sourceMap says it - -- should be installed - checkLocation Snap = True -- snapshot deps could become mutable after getting - -- any mutable dependency - checkLocation Local = - mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs - -- Check if a package is allowed if it is found in the sourceMap + -- should be installed. + checkLocation Snap = + -- snapshot deps could become mutable after getting any mutable dependency. + True + checkLocation Local = case pkgDb of + GlobalDb -> False + -- 'locally' installed snapshot packages can come from 'extra' package + -- databases. + ExtraDb -> True + WriteOnlyDb -> False + MutableDb -> True + -- Check if an installed package is allowed if it is found in the sourceMap. checkFound (installLoc, installVer) - | not (checkLocation installLoc) = WrongLocation mloc installLoc + | not (checkLocation installLoc) = WrongLocation pkgDb installLoc | version /= installVer = WrongVersion version installVer | otherwise = Allowed - -- check if a package is allowed if it is not found in the sourceMap - checkNotFound = case mloc of - -- The sourceMap has nothing to say about this global package, so we can use it - Nothing -> Allowed - Just ExtraGlobal -> Allowed + -- Check if an installed package is allowed if it is not found in the + -- sourceMap. + checkNotFound = case pkgDb of + -- The sourceMap has nothing to say about this global package, so we can use + -- it. + GlobalDb -> Allowed + ExtraDb -> Allowed -- For non-global packages, don't include unknown packages. -- See: https://github.com/commercialhaskell/stack/issues/292 - Just _ -> UnknownPkg + WriteOnlyDb -> UnknownPkg + MutableDb -> UnknownPkg +-- | Type representing certain information about an installed package. data LoadHelper = LoadHelper - { lhId :: !GhcPkgId + { lhId :: !GhcPkgId + -- ^ The package's id. , lhDeps :: ![GhcPkgId] + -- ^ Unless the package's name is that of a 'wired-in' package, a list of + -- the ids of the installed packages that are the package's dependencies. , lhPair :: !(PackageName, (InstallLocation, Installed)) + -- ^ A pair of (a) the package's name and (b) a pair of the relevant + -- database (write-only or mutable) and information about the library + -- installed. } deriving Show -toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper -toLoadHelper mloc dp = LoadHelper +toLoadHelper :: PackageDbVariety -> DumpPackage -> LoadHelper +toLoadHelper pkgDb dp = LoadHelper { lhId = gid , lhDeps = -- We always want to consider the wired in packages as having all of their @@ -233,13 +264,17 @@ toLoadHelper mloc dp = LoadHelper if name `Set.member` wiredInPackages then [] else dpDepends dp - , lhPair = (name, (toPackageLocation mloc, Library ident gid (Right <$> dpLicense dp))) + , lhPair = + ( name + , (toInstallLocation pkgDb, Library ident gid (Right <$> dpLicense dp)) + ) } where gid = dpGhcPkgId dp ident@(PackageIdentifier name _) = dpPackageIdent dp -toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation -toPackageLocation Nothing = Snap -toPackageLocation (Just ExtraGlobal) = Snap -toPackageLocation (Just (InstalledTo loc)) = loc + toInstallLocation :: PackageDbVariety -> InstallLocation + toInstallLocation GlobalDb = Snap + toInstallLocation ExtraDb = Snap + toInstallLocation WriteOnlyDb = Snap + toInstallLocation MutableDb = Local diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 1162be3de4..e550614f25 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -55,35 +55,48 @@ instance Exception PackageDumpException where , "." ] --- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, --- for a single database +-- | Call @ghc-pkg dump@ with appropriate flags and stream to the given sink, +-- using either the global package database or the given package databases. ghcPkgDump :: (HasProcessContext env, HasTerm env) => GhcPkgExe - -> [Path Abs Dir] -- ^ if empty, use global + -> [Path Abs Dir] + -- ^ A list of package databases. If empty, use the global package + -- database. -> ConduitM Text Void (RIO env) a + -- ^ Sink. -> RIO env a ghcPkgDump pkgexe = ghcPkgCmdArgs pkgexe ["dump"] --- | Call ghc-pkg describe with appropriate flags and stream to the given --- @Sink@, for a single database +-- | Call @ghc-pkg describe@ with appropriate flags and stream to the given +-- sink, using either the global package database or the given package +-- databases. ghcPkgDescribe :: (HasCompiler env, HasProcessContext env, HasTerm env) => GhcPkgExe -> PackageName - -> [Path Abs Dir] -- ^ if empty, use global + -> [Path Abs Dir] + -- ^ A list of package databases. If empty, use the global package + -- database. -> ConduitM Text Void (RIO env) a + -- ^ Sink. -> RIO env a ghcPkgDescribe pkgexe pkgName' = ghcPkgCmdArgs - pkgexe ["describe", "--simple-output", packageNameString pkgName'] + pkgexe + ["describe", "--simple-output", packageNameString pkgName'] --- | Call ghc-pkg and stream to the given @Sink@, for a single database +-- | Call @ghc-pkg@ and stream to the given sink, using the either the global +-- package database or the given package databases. ghcPkgCmdArgs :: (HasProcessContext env, HasTerm env) => GhcPkgExe -> [String] - -> [Path Abs Dir] -- ^ if empty, use global + -- ^ A list of commands. + -> [Path Abs Dir] + -- ^ A list of package databases. If empty, use the global package + -- database. -> ConduitM Text Void (RIO env) a + -- ^ Sink. -> RIO env a ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = do case reverse mpkgDbs of @@ -95,8 +108,11 @@ ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = do args = concat [ case mpkgDbs of [] -> ["--global", "--no-user-package-db"] - _ -> ["--user", "--no-user-package-db"] ++ - concatMap (\pkgDb -> ["--package-db", toFilePathNoTrailingSep pkgDb]) mpkgDbs + _ -> "--user" + : "--no-user-package-db" + : concatMap + (\pkgDb -> ["--package-db", toFilePathNoTrailingSep pkgDb]) + mpkgDbs , cmd , ["--expand-pkgroot"] ] diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 8960d4befa..c2aa3a19d0 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -16,6 +16,8 @@ module Stack.Types.Package , MemoizedWith (..) , Package (..) , PackageConfig (..) + , PackageDatabase (..) + , PackageDbVariety (..) , PackageException (..) , PackageLibraries (..) , PackageSource (..) @@ -34,6 +36,7 @@ module Stack.Types.Package , packageIdentifier , psVersion , runMemoizedWith + , toPackageDbVariety ) where import Data.Aeson @@ -201,6 +204,9 @@ packageIdentifier p = PackageIdentifier (packageName p) (packageVersion p) packageDefinedFlags :: Package -> Set FlagName packageDefinedFlags = M.keysSet . packageDefaultFlags +-- | Type synonym representing dictionaries of package names for a project's +-- packages and dependencies, and pairs of their relevant database (write-only +-- or mutable) and package versions. type InstallMap = Map PackageName (InstallLocation, Version) -- | Files that the package depends on, relative to package directory. @@ -361,12 +367,14 @@ lpFilesForComponents components lp = runMemoizedWith $ do componentFiles <- lpComponentFiles lp pure $ mconcat (M.elems (M.restrictKeys componentFiles components)) --- | Type represeting databases to install a package into. +-- | Type representing user package databases that packages can be installed +-- into. data InstallLocation = Snap - -- ^ The write-only database, formerly known as the snapshot database. + -- ^ The write-only package database, formerly known as the snapshot + -- database. | Local - -- ^ The mutable database, formerly known as the local database. + -- ^ The mutable package database, formerly known as the local database. deriving (Eq, Show) instance Semigroup InstallLocation where @@ -378,10 +386,44 @@ instance Monoid InstallLocation where mempty = Snap mappend = (<>) +-- | Type representing user (non-global) package databases that can provide +-- installed packages. data InstalledPackageLocation - = InstalledTo InstallLocation | ExtraGlobal + = InstalledTo InstallLocation + -- ^ A package database that a package can be installed into. + | ExtraPkgDb + -- ^ An \'extra\' package database, specified by @extra-package-dbs@. deriving (Eq, Show) +-- | Type representing package databases that can provide installed packages. +data PackageDatabase + = GlobalPkgDb + -- ^ GHC's global package database. + | UserPkgDb InstalledPackageLocation (Path Abs Dir) + -- ^ A user package database. + deriving (Eq, Show) + +-- | Type representing varieties of package databases that can provide +-- installed packages. +data PackageDbVariety + = GlobalDb + -- ^ GHC's global package database. + | ExtraDb + -- ^ An \'extra\' package database, specified by @extra-package-dbs@. + | WriteOnlyDb + -- ^ The write-only package database, for immutable packages. + | MutableDb + -- ^ The mutable package database. + deriving (Eq, Show) + +-- | A function to yield the variety of package database for a given +-- package database that can provide installed packages. +toPackageDbVariety :: PackageDatabase -> PackageDbVariety +toPackageDbVariety GlobalPkgDb = GlobalDb +toPackageDbVariety (UserPkgDb ExtraPkgDb _) = ExtraDb +toPackageDbVariety (UserPkgDb (InstalledTo Snap) _) = WriteOnlyDb +toPackageDbVariety (UserPkgDb (InstalledTo Local) _) = MutableDb + newtype FileCacheInfo = FileCacheInfo { fciHash :: SHA256 } @@ -434,14 +476,15 @@ dotCabalGetPath dcp = DotCabalCFilePath fp -> fp -- | Type synonym representing dictionaries of package names, and a pair of in --- which database the package is installed (write-only or mutable) and what is --- installed (library or executable). +-- which package database the package is installed (write-only or mutable) and +-- information about what is installed. type InstalledMap = Map PackageName (InstallLocation, Installed) -- | Type representing information about what is installed. data Installed = Library PackageIdentifier GhcPkgId (Maybe (Either SPDX.License License)) - -- ^ A library. + -- ^ A library, including its installed package id and, optionally, its + -- license. | Executable PackageIdentifier -- ^ An executable. deriving (Eq, Show)