diff --git a/.hlint.yaml b/.hlint.yaml index 7a4337ca0e..02f1a89d42 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -74,6 +74,7 @@ # Stack's code generally avoids the use of C preprocessor (CPP) directives. - name: CPP within: + - GHC.Utils.GhcPkg.Main.Compat - Stack.BuildInfo - Stack.Constants # The following list provides an inventory of the small number of modules @@ -91,6 +92,14 @@ name: - CPP - PackageImports + # GHC.Utils.GhcPkg.Main.Compat's code largely comes from the GHC repository. + - within: GHC.Utils.GhcPkg.Main.Compat + name: + - FlexibleInstances + - KindSignatures + - MultiParamTypeClasses + - ScopedTypeVariables + - TupleSections # Not considered useful hints - ignore: diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 80cec52914..12f8b93801 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -5,7 +5,18 @@ In connection with considering Stack's support of the [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks to take stock of the errors that Stack itself can raise, by reference to the -`master` branch of the Stack repository. Last updated: 2023-07-24. +`master` branch of the Stack repository. Last updated: 2023-09-02. + +* `GHC.GHC.Utils.GhcPkg.Main.Compat` + + ~~~haskell + [S-6512] = CannotParse String String String + [S-3384] | CannotOpenDBForModification FilePath IOException + [S-1430] | SingleFileDBUnsupported FilePath + [S-5996] | ParsePackageInfoExceptions String + [S-3189] | CannotFindPackage PackageArg (Maybe FilePath) + + ~~~ * `Stack.main`: catches exceptions from action `commandLineHandler`. @@ -122,6 +133,10 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-2483] | ExecutableToRunNotFound ~~~ + - `Stack.GhcPkg` + + `[S-6716]` used in `unregisterGhcPkgIds` + - `Stack.Ghci.GhciException` ~~~haskell diff --git a/package.yaml b/package.yaml index ec5ebf0e6c..f23f4120b4 100644 --- a/package.yaml +++ b/package.yaml @@ -82,6 +82,7 @@ dependencies: - filepath - fsnotify >= 0.4.1 - generic-deriving +- ghc-boot - hi-file-parser >= 0.1.4.0 - hpack >= 0.35.3 - hpc @@ -110,7 +111,7 @@ dependencies: - project-template - random - rio >= 0.1.22.0 -- rio-prettyprint >= 0.1.4.0 +- rio-prettyprint >= 0.1.5.0 - split - stm - tar diff --git a/src/GHC/Utils/GhcPkg/Main/Compat.hs b/src/GHC/Utils/GhcPkg/Main/Compat.hs new file mode 100644 index 0000000000..fe0a46526e --- /dev/null +++ b/src/GHC/Utils/GhcPkg/Main/Compat.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- This module is based on GHC's utils\ghc-pkg\Main.hs at +-- commit f66fc15f2e6849125074bcfeb44334a663323ca6 (see GHC merge request +-- !11142), with: +-- * changeDBDir' does not perform an effective @ghc-pkg recache@, +-- * the cache is not used, +-- * consistency checks are not performed, +-- * use Stack program name, +-- * use "Stack.Prelude" rather than "Prelude", +-- * use 'RIO' @env@ monad, +-- * use well-typed representations of paths from the @path@ package, +-- * add pretty messages and exceptions, +-- * redundant code deleted, +-- * Hlint applied, and +-- * explicit import lists. +-- +-- The version of the ghc-pkg executable supplied with GHCs published before +-- 28 August 2023 does not efficiently bulk unregister. This module exports a +-- function that does efficiently bulk unregister. + +module GHC.Utils.GhcPkg.Main.Compat + ( ghcPkgUnregisterForce + ) where + +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2004-2009. +-- +-- Package management tool +-- +----------------------------------------------------------------------------- + +import qualified Data.Foldable as F +import Data.List ( init, isPrefixOf, isSuffixOf, last ) +import qualified Data.Traversable as F +import Distribution.InstalledPackageInfo as Cabal +import Distribution.Package ( UnitId, mungedId ) +import qualified Distribution.Parsec as Cabal +import Distribution.Text ( display ) +import Distribution.Version ( nullVersion ) +import GHC.IO.Exception (IOErrorType(InappropriateType)) +import qualified GHC.Unit.Database as GhcPkg +import Path + ( SomeBase (..), fileExtension, mapSomeBase, parseRelFile + , parseSomeDir, prjSomeBase + ) +import qualified Path as P +import Path.IO + ( createDirIfMissing, doesDirExist, listDir, removeFile ) +import qualified RIO.ByteString as BS +import RIO.Partial ( fromJust ) +import Stack.Constants ( relFilePackageCache ) +import Stack.Prelude hiding ( display ) +import System.Environment ( getEnv ) +import System.FilePath as FilePath +import System.IO ( readFile ) +import System.IO.Error + ( ioeGetErrorType, ioError, isDoesNotExistError ) + +-- | Function equivalent to: +-- +-- > ghc-pkg --no-user-package-db --package-db= unregister [--ipid]

+-- +ghcPkgUnregisterForce :: + HasTerm env + => Path Abs Dir -- ^ Path to the global package database + -> Path Abs Dir -- ^ Path to the package database + -> Bool -- ^ Apply ghc-pkg's --ipid, --unit-id flag? + -> [String] -- ^ Packages to unregister + -> RIO env () +ghcPkgUnregisterForce globalDb pkgDb hasIpid pkgarg_strs = do + pkgargs <- forM pkgarg_strs $ readPackageArg as_arg + prettyDebugL + $ flow "Unregistering from" + : (pretty pkgDb <> ":") + : mkNarrativeList (Just Current) False + (map (fromString . show) pkgargs :: [StyleDoc]) + unregisterPackages globalDb pkgargs pkgDb + where + as_arg = if hasIpid then AsUnitId else AsDefault + +-- | Type representing \'pretty\' exceptions thrown by functions exported by the +-- "GHC.Utils.GhcPkg.Main.Compat" module. +data GhcPkgPrettyException + = CannotParse !String !String !String + | CannotOpenDBForModification !(SomeBase Dir) !IOException + | SingleFileDBUnsupported !(SomeBase Dir) + | ParsePackageInfoExceptions !String + | CannotFindPackage !PackageArg !(Maybe (SomeBase Dir)) + deriving (Show, Typeable) + +instance Pretty GhcPkgPrettyException where + pretty (CannotParse str what e) = + "[S-6512]" + <> line + <> fillSep + [ flow "cannot parse" + , style Current (fromString str) + , flow "as a" + , fromString what <> ":" + ] + <> blankLine + <> fromString e + pretty (CannotOpenDBForModification db_path e) = + "[S-3384]" + <> line + <> fillSep + [ flow "Couldn't open database" + , pretty db_path + , flow "for modification:" + ] + <> blankLine + <> string (displayException e) + pretty (SingleFileDBUnsupported path) = + "[S-1430]" + <> line + <> fillSep + [ flow "ghc no longer supports single-file style package databases" + , parens (pretty path) + , "use" + , style Shell (flow "ghc-pkg init") + , flow "to create the database with the correct format." + ] + pretty (ParsePackageInfoExceptions errs) = + "[S-5996]" + <> line + <> flow errs + pretty (CannotFindPackage pkgarg mdb_path) = + "[S-3189]" + <> line + <> fillSep + [ flow "cannot find package" + , style Current (pkg_msg pkgarg) + , maybe + "" + (\db_path -> fillSep ["in", pretty db_path]) + mdb_path + ] + where + pkg_msg (Substring pkgpat _) = fillSep ["matching", fromString pkgpat] + pkg_msg pkgarg' = fromString $ show pkgarg' + +instance Exception GhcPkgPrettyException + +-- ----------------------------------------------------------------------------- +-- Do the business + +-- | Enum flag representing argument type +data AsPackageArg + = AsUnitId + | AsDefault + +-- | Represents how a package may be specified by a user on the command line. +data PackageArg + -- | A package identifier foo-0.1, or a glob foo-* + = Id GlobPackageIdentifier + -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely + -- match a single entry in the package database. + | IUId UnitId + -- | A glob against the package name. The first string is the literal + -- glob, the second is a function which returns @True@ if the argument + -- matches. + | Substring String (String -> Bool) + +instance Show PackageArg where + show (Id pkgid) = displayGlobPkgId pkgid + show (IUId ipid) = display ipid + show (Substring pkgpat _) = pkgpat + +parseCheck :: Cabal.Parsec a => String -> String -> RIO env a +parseCheck str what = + case Cabal.eitherParsec str of + Left e -> prettyThrowIO $ CannotParse str what e + Right x -> pure x + +-- | Either an exact 'PackageIdentifier', or a glob for all packages +-- matching 'PackageName'. +data GlobPackageIdentifier + = ExactPackageIdentifier MungedPackageId + | GlobPackageIdentifier MungedPackageName + +displayGlobPkgId :: GlobPackageIdentifier -> String +displayGlobPkgId (ExactPackageIdentifier pid) = display pid +displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*" + +readGlobPkgId :: String -> RIO env GlobPackageIdentifier +readGlobPkgId str + | "-*" `isSuffixOf` str = + GlobPackageIdentifier <$> parseCheck (init (init str)) "package identifier (glob)" + | otherwise = ExactPackageIdentifier <$> parseCheck str "package identifier (exact)" + +readPackageArg :: AsPackageArg -> String -> RIO env PackageArg +readPackageArg AsUnitId str = IUId <$> parseCheck str "installed package id" +readPackageArg AsDefault str = Id <$> readGlobPkgId str + +-- ----------------------------------------------------------------------------- +-- Package databases + +data PackageDB (mode :: GhcPkg.DbMode) = PackageDB + { location :: !(SomeBase Dir) + -- We only need possibly-relative package db location. The relative + -- location is used as an identifier for the db, so it is important we do + -- not modify it. + , packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock) + -- If package db is open in read write mode, we keep its lock around for + -- transactional updates. + , packages :: [InstalledPackageInfo] + } + +-- | A stack of package databases. Convention: head is the topmost in the stack. +type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly] + +-- | Selector for picking the right package DB to modify as 'modify' changes the +-- first database that contains a specific package. +newtype DbModifySelector = ContainsPkg PackageArg + +getPkgDatabases :: + forall env. HasTerm env + => Path Abs Dir + -- ^ Path to the global package database. + -> PackageArg + -> Path Abs Dir + -- ^ Path to the package database. + -> RIO + env + ( PackageDBStack + -- the real package DB stack: [global,user] ++ DBs specified on the + -- command line with -f. + , GhcPkg.DbOpenMode GhcPkg.DbReadWrite (PackageDB GhcPkg.DbReadWrite) + -- which one to modify, if any + , PackageDBStack + -- the package DBs specified on the command line, or [global,user] + -- otherwise. This is used as the list of package DBs for commands + -- that just read the DB, such as 'list'. + ) +getPkgDatabases globalDb pkgarg pkgDb = do + -- Second we determine the location of the global package config. On Windows, + -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the + -- location is passed to the binary using the --global-package-db flag by the + -- wrapper script. + let sys_databases = [Abs globalDb] + e_pkg_path <- tryIO (liftIO $ System.Environment.getEnv "GHC_PACKAGE_PATH") + let env_stack = + case e_pkg_path of + Left _ -> sys_databases + Right path + | not (null path) && isSearchPathSeparator (last path) + -> mapMaybe parseSomeDir (splitSearchPath (init path)) <> sys_databases + | otherwise + -> mapMaybe parseSomeDir (splitSearchPath path) + + -- -f flags on the command line add to the database stack, unless any of them + -- are present in the stack already. + let final_stack = [Abs pkgDb | Abs pkgDb `notElem` env_stack] <> env_stack + + (db_stack, db_to_operate_on) <- getDatabases pkgDb final_stack + + let flag_db_stack = [ db | db <- db_stack, location db == Abs pkgDb ] + + prettyDebugL + $ flow "Db stack:" + : map (pretty . location) db_stack + F.forM_ db_to_operate_on $ \db -> + prettyDebugL + [ "Modifying:" + , pretty $ location db + ] + prettyDebugL + $ flow "Flag db stack:" + : map (pretty . location) flag_db_stack + + pure (db_stack, db_to_operate_on, flag_db_stack) + where + getDatabases flag_db_name final_stack = do + -- The package db we open in read write mode is the first one included in + -- flag_db_names that contains specified package. Therefore we need to + -- open each one in read/write mode first and decide whether it's for + -- modification based on its contents. + (db_stack, mto_modify) <- stateSequence Nothing + [ \case + to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path + Nothing -> if db_path /= Abs flag_db_name + then (, Nothing) <$> readDatabase db_path + else do + let hasPkg :: PackageDB mode -> Bool + hasPkg = not . null . findPackage pkgarg . packages + + openRo (e::IOException) = do + db <- readDatabase db_path + if hasPkg db + then + prettyThrowIO $ CannotOpenDBForModification db_path e + else pure (db, Nothing) + + -- If we fail to open the database in read/write mode, we need + -- to check if it's for modification first before throwing an + -- error, so we attempt to open it in read only mode. + handle openRo $ do + db <- readParseDatabase + (GhcPkg.DbOpenReadWrite $ ContainsPkg pkgarg) db_path + let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly } + if hasPkg db + then pure (ro_db, Just db) + else do + -- If the database is not for modification after all, + -- drop the write lock as we are already finished with + -- the database. + case packageDbLock db of + GhcPkg.DbOpenReadWrite lock -> + liftIO $ GhcPkg.unlockPackageDb lock + pure (ro_db, Nothing) + | db_path <- final_stack ] + + to_modify <- case mto_modify of + Just db -> pure db + Nothing -> cannotFindPackage pkgarg Nothing + + pure (db_stack, GhcPkg.DbOpenReadWrite to_modify) + where + -- Parse package db in read-only mode. + readDatabase :: SomeBase Dir -> RIO env (PackageDB 'GhcPkg.DbReadOnly) + readDatabase = readParseDatabase GhcPkg.DbOpenReadOnly + + stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) + stateSequence s [] = pure ([], s) + stateSequence s (m:ms) = do + (a, s') <- m s + (as, s'') <- stateSequence s' ms + pure (a : as, s'') + +readParseDatabase :: + forall mode t env. HasTerm env + => GhcPkg.DbOpenMode mode t + -> SomeBase Dir + -> RIO env (PackageDB mode) +readParseDatabase mode path = do + e <- tryIO $ prjSomeBase listDir path + case e of + Left err + | ioeGetErrorType err == InappropriateType -> do + -- We provide a limited degree of backwards compatibility for + -- old single-file style db: + mdb <- tryReadParseOldFileStyleDatabase mode path + case mdb of + Just db -> pure db + Nothing -> prettyThrowIO $ SingleFileDBUnsupported path + + | otherwise -> liftIO $ ioError err + Right (_, fs) -> ignore_cache + where + confs = filter isConf fs + + isConf :: Path Abs File -> Bool + isConf f = case fileExtension f of + Nothing -> False + Just ext -> ext == ".conf" + + ignore_cache :: RIO env (PackageDB mode) + ignore_cache = do + -- If we're opening for modification, we need to acquire a lock even if + -- we don't open the cache now, because we are going to modify it later. + lock <- liftIO $ + F.mapM (const $ GhcPkg.lockPackageDb (prjSomeBase toFilePath cache)) mode + pkgs <- mapM parseSingletonPackageConf confs + mkPackageDB pkgs lock + where + cache = mapSomeBase (P. relFilePackageCache) path + + mkPackageDB :: + [InstalledPackageInfo] + -> GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock + -> RIO env (PackageDB mode) + mkPackageDB pkgs lock = do + pure $ PackageDB + { location = path + , packageDbLock = lock + , packages = pkgs + } + +parseSingletonPackageConf :: + HasTerm env + => Path Abs File + -> RIO env InstalledPackageInfo +parseSingletonPackageConf file = do + prettyDebugL + [ flow "Reading package config:" + , pretty file + ] + BS.readFile (toFilePath file) >>= fmap fst . parsePackageInfo + +-- ----------------------------------------------------------------------------- +-- Workaround for old single-file style package dbs + +-- Single-file style package dbs have been deprecated for some time, but +-- it turns out that Cabal was using them in one place. So this code is for a +-- workaround to allow older Cabal versions to use this newer ghc. + +-- We check if the file db contains just "[]" and if so, we look for a new +-- dir-style db in path.d/, ie in a dir next to the given file. +-- We cannot just replace the file with a new dir style since Cabal still +-- assumes it's a file and tries to overwrite with 'writeFile'. + +-- ghc itself also cooperates in this workaround + +tryReadParseOldFileStyleDatabase :: + HasTerm env + => GhcPkg.DbOpenMode mode t + -> SomeBase Dir + -> RIO env (Maybe (PackageDB mode)) +tryReadParseOldFileStyleDatabase mode path = do + -- assumes we've already established that path exists and is not a dir + content <- liftIO $ readFile (prjSomeBase toFilePath path) `catchIO` \_ -> pure "" + if take 2 content == "[]" + then do + let path_dir = adjustOldDatabasePath path + prettyWarnL + [ flow "Ignoring old file-style db and trying" + , pretty path_dir + ] + direxists <- prjSomeBase doesDirExist path_dir + if direxists + then do + db <- readParseDatabase mode path_dir + -- but pretend it was at the original location + pure $ Just db { location = path } + else do + lock <- F.forM mode $ \_ -> do + prjSomeBase (createDirIfMissing True) path_dir + liftIO $ GhcPkg.lockPackageDb $ + prjSomeBase (toFilePath . (P. relFilePackageCache)) path_dir + pure $ Just PackageDB + { location = path + , packageDbLock = lock + , packages = [] + } + + -- if the path is not a file, or is not an empty db then we fail + else pure Nothing + +adjustOldFileStylePackageDB :: PackageDB mode -> RIO env (PackageDB mode) +adjustOldFileStylePackageDB db = do + -- assumes we have not yet established if it's an old style or not + mcontent <- liftIO $ + fmap Just (readFile (prjSomeBase toFilePath (location db))) `catchIO` \_ -> pure Nothing + case fmap (take 2) mcontent of + -- it is an old style and empty db, so look for a dir kind in location.d/ + Just "[]" -> pure db + { location = adjustOldDatabasePath $ location db } + -- it is old style but not empty, we have to bail + Just _ -> prettyThrowIO $ SingleFileDBUnsupported (location db) + -- probably not old style, carry on as normal + Nothing -> pure db + +adjustOldDatabasePath :: SomeBase Dir -> SomeBase Dir +adjustOldDatabasePath = + fromJust . prjSomeBase (parseSomeDir . (<> ".d") . toFilePath) + +parsePackageInfo :: BS.ByteString -> RIO env (InstalledPackageInfo, [String]) +parsePackageInfo str = + case parseInstalledPackageInfo str of + Right (warnings, ok) -> pure (mungePackageInfo ok, ws) + where + ws = [ msg | msg <- warnings + , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] + Left err -> prettyThrowIO $ ParsePackageInfoExceptions (unlines (F.toList err)) + +mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo +mungePackageInfo ipi = ipi + +-- ----------------------------------------------------------------------------- +-- Making changes to a package database + +newtype DBOp = RemovePackage InstalledPackageInfo + +changeNewDB :: + HasTerm env + => [DBOp] + -> PackageDB 'GhcPkg.DbReadWrite + -> RIO env () +changeNewDB cmds new_db = do + new_db' <- adjustOldFileStylePackageDB new_db + prjSomeBase (createDirIfMissing True) (location new_db') + changeDBDir' cmds new_db' + +changeDBDir' :: + HasTerm env + => [DBOp] + -> PackageDB 'GhcPkg.DbReadWrite + -> RIO env () +changeDBDir' cmds db = do + mapM_ do_cmd cmds + case packageDbLock db of + GhcPkg.DbOpenReadWrite lock -> liftIO $ GhcPkg.unlockPackageDb lock + where + do_cmd (RemovePackage p) = do + let relFileConf = + fromJust (parseRelFile $ display (installedUnitId p) <> ".conf") + file = mapSomeBase (P. relFileConf) (location db) + prettyDebugL + [ "Removing" + , pretty file + ] + removeFileSafe file + +unregisterPackages :: + forall env. HasTerm env + => Path Abs Dir + -- ^ Path to the global package database. + -> [PackageArg] + -> Path Abs Dir + -- ^ Path to the package database. + -> RIO env () +unregisterPackages globalDb pkgargs pkgDb = do + pkgsByPkgDBs <- F.foldlM (getPkgsByPkgDBs []) [] pkgargs + forM_ pkgsByPkgDBs unregisterPackages' + where + -- Update a list of 'packages by package database' for a package. Assumes that + -- a package to be unregistered is in no more than one database. + getPkgsByPkgDBs :: [(PackageDB GhcPkg.DbReadWrite, [UnitId])] + -- ^ List of considered 'packages by package database' + -> [(PackageDB GhcPkg.DbReadWrite, [UnitId])] + -- ^ List of to be considered 'packages by package database' + -> PackageArg + -- Package to update + -> RIO env [(PackageDB GhcPkg.DbReadWrite, [UnitId])] + -- No more 'packages by package database' to consider? We need to try to get + -- another package database. + getPkgsByPkgDBs pkgsByPkgDBs [] pkgarg = + getPkgDatabases globalDb pkgarg pkgDb >>= \case + (_, GhcPkg.DbOpenReadWrite (db :: PackageDB GhcPkg.DbReadWrite), _) -> do + pks <- do + let pkgs = packages db + ps = findPackage pkgarg pkgs + -- This shouldn't happen if getPkgsByPkgDBs picks the DB correctly. + when (null ps) $ cannotFindPackage pkgarg $ Just db + pure (map installedUnitId ps) + let pkgsByPkgDB = (db, pks) + pure (pkgsByPkgDB : pkgsByPkgDBs) + -- Consider the next 'packages by package database' in the list of ones to + -- consider. + getPkgsByPkgDBs pkgsByPkgDBs ( pkgsByPkgDB : pkgsByPkgDBs') pkgarg = do + let (db, pks') = pkgsByPkgDB + pkgs = packages db + ps = findPackage pkgarg pkgs + pks = map installedUnitId ps + pkgByPkgDB' = (db, pks <> pks') + if null ps + then + -- Not found in the package database? Add the package database to those + -- considered and try with the remaining package databases to consider. + getPkgsByPkgDBs ( pkgsByPkgDB : pkgsByPkgDBs ) pkgsByPkgDBs' pkgarg + else + -- Found in the package database? Add to the list of packages to be + -- unregistered from that package database. TO DO: Perhaps check not + -- already in that list for better error messages when there are + -- duplicated requests to unregister. + pure (pkgsByPkgDBs <> (pkgByPkgDB' : pkgsByPkgDBs')) + + unregisterPackages' :: (PackageDB GhcPkg.DbReadWrite, [UnitId]) -> RIO env () + unregisterPackages' (db, pks) = do + let pkgs = packages db + cmds = [ RemovePackage pkg + | pkg <- pkgs, installedUnitId pkg `elem` pks + ] + new_db = db{ packages = pkgs' } + where + deleteFirstsBy' :: (a -> b -> Bool) -> [a] -> [b] -> [a] + deleteFirstsBy' eq = foldl' (deleteBy' eq) + + deleteBy' :: (a -> b -> Bool) -> [a] -> b -> [a] + deleteBy' _ [] _ = [] + deleteBy' eq (y:ys) x = if y `eq` x then ys else y : deleteBy' eq ys x + + pkgs' = deleteFirstsBy' (\p1 p2 -> installedUnitId p1 == p2) pkgs pks + -- Use changeNewDB, rather than changeDB, to avoid duplicating + -- updateInternalDB db cmds + changeNewDB cmds new_db + +findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo] +findPackage pkgarg = filter (pkgarg `matchesPkg`) + +cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> RIO env a +cannotFindPackage pkgarg mdb = + prettyThrowIO $ CannotFindPackage pkgarg (location <$> mdb) + +matches :: GlobPackageIdentifier -> MungedPackageId -> Bool +GlobPackageIdentifier pn `matches` pid' = pn == mungedName pid' +ExactPackageIdentifier pid `matches` pid' = + mungedName pid == mungedName pid' + && ( mungedVersion pid == mungedVersion pid' + || mungedVersion pid == nullVersion + ) + +matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool +(Id pid) `matchesPkg` pkg = pid `matches` mungedId pkg +(IUId ipid) `matchesPkg` pkg = ipid == installedUnitId pkg +(Substring _ m) `matchesPkg` pkg = m (display (mungedId pkg)) + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: SomeBase File -> RIO env () +removeFileSafe fn = do + prjSomeBase removeFile fn `catchIO` \ e -> + unless (isDoesNotExistError e) $ liftIO $ ioError e diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 39808a09f1..647df0c82f 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -19,6 +19,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as T +import GHC.Utils.GhcPkg.Main.Compat ( ghcPkgUnregisterForce ) import Path ( (), parent ) import Path.Extra ( toFilePathNoTrailingSep ) import Path.IO @@ -27,7 +28,10 @@ import RIO.Process ( HasProcessContext, proc, readProcess_ ) import Stack.Constants ( relFilePackageCache ) import Stack.Prelude import Stack.Types.Compiler ( WhichCompiler (..) ) -import Stack.Types.CompilerPaths ( GhcPkgExe (..) ) +import Stack.Types.CompilerPaths + ( CompilerPaths (..), GhcPkgExe (..), HasCompiler + , compilerPathsL + ) import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString ) import System.FilePath ( searchPathSeparator ) @@ -138,27 +142,53 @@ findGhcPkgField pkgexe pkgDbs name field = do -- | unregister list of package ghcids, batching available from GHC 8.2.1, -- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402 -- using GHC package id where available (from GHC 7.9) +-- +-- The version of the ghc-pkg executable supplied with GHCs published before +-- 28 August 2023 does not efficiently bulk unregister. Until an 'efficient' +-- ghc-pkg is available, this function no longer uses: +-- +-- > eres <- ghcPkg pkgexe [pkgDb] args +-- > where +-- > args = "unregister" : "--user" : "--force" : +-- > map packageIdentifierString idents ++ +-- > if null gids then [] else "--ipid" : map ghcPkgIdString gids +-- +-- but uses: +-- +-- > globalDb <- view $ compilerPathsL.to cpGlobalDB +-- > eres <- tryAny $ liftIO $ +-- > ghcPkgUnregisterUserForce globalDb pkgDb hasIpid pkgarg_strs +-- unregisterGhcPkgIds :: - (HasProcessContext env, HasTerm env) + (HasCompiler env, HasProcessContext env, HasTerm env) => Bool - -- ^ Report exceptions as warnings? + -- ^ Report pretty exceptions as warnings? -> GhcPkgExe -> Path Abs Dir -- ^ package database -> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env () unregisterGhcPkgIds isWarn pkgexe pkgDb epgids = do - -- The ghcPkg function supplies initial arguments - -- --no-user-package-db --package-db= ... --package-db= - eres <- ghcPkg pkgexe [pkgDb] args + globalDb <- view $ compilerPathsL.to cpGlobalDB + eres <- try $ do + ghcPkgUnregisterForce globalDb pkgDb hasIpid pkgarg_strs + -- ghcPkgUnregisterForce does not perform an effective + -- 'ghc-pkg recache', as that depends on a specific version of the Cabal + -- package. + ghcPkg pkgexe [pkgDb] ["recache"] case eres of - Left e -> when isWarn $ - prettyWarn $ string $ displayException e + Left (PrettyException e) -> when isWarn $ + prettyWarn $ + "[S-8729]" + <> line + <> flow "While unregistering packages, Stack encountered the following \ + \error:" + <> blankLine + <> pretty e Right _ -> pure () where (idents, gids) = partitionEithers $ toList epgids - args = "unregister" : "--force" : - map packageIdentifierString idents ++ - if null gids then [] else "--ipid" : map ghcPkgIdString gids + hasIpid = not (null gids) + pkgarg_strs = map packageIdentifierString idents <> map ghcPkgIdString gids -- | Get the value for GHC_PACKAGE_PATH mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text diff --git a/stack.cabal b/stack.cabal index 9dfe74bfc7..2b6d1a5a1b 100644 --- a/stack.cabal +++ b/stack.cabal @@ -321,6 +321,7 @@ library Build_stack Paths_stack other-modules: + GHC.Utils.GhcPkg.Main.Compat Stack.Config.ConfigureScript Stack.Types.FileDigestCache autogen-modules: @@ -355,6 +356,7 @@ library , filepath , fsnotify >=0.4.1 , generic-deriving + , ghc-boot , hi-file-parser >=0.1.4.0 , hpack >=0.35.3 , hpc @@ -380,7 +382,7 @@ library , project-template , random , rio >=0.1.22.0 - , rio-prettyprint >=0.1.4.0 + , rio-prettyprint >=0.1.5.0 , split , stm , tar @@ -472,6 +474,7 @@ executable stack , filepath , fsnotify >=0.4.1 , generic-deriving + , ghc-boot , hi-file-parser >=0.1.4.0 , hpack >=0.35.3 , hpc @@ -497,7 +500,7 @@ executable stack , project-template , random , rio >=0.1.22.0 - , rio-prettyprint >=0.1.4.0 + , rio-prettyprint >=0.1.5.0 , split , stack , stm @@ -568,6 +571,7 @@ executable stack-integration-test , filepath , fsnotify >=0.4.1 , generic-deriving + , ghc-boot , hi-file-parser >=0.1.4.0 , hpack >=0.35.3 , hpc @@ -595,7 +599,7 @@ executable stack-integration-test , project-template , random , rio >=0.1.22.0 - , rio-prettyprint >=0.1.4.0 + , rio-prettyprint >=0.1.5.0 , split , stm , tar @@ -680,6 +684,7 @@ test-suite stack-unit-test , filepath , fsnotify >=0.4.1 , generic-deriving + , ghc-boot , hi-file-parser >=0.1.4.0 , hpack >=0.35.3 , hpc @@ -707,7 +712,7 @@ test-suite stack-unit-test , random , raw-strings-qq , rio >=0.1.22.0 - , rio-prettyprint >=0.1.4.0 + , rio-prettyprint >=0.1.5.0 , split , stack , stm diff --git a/stack.yaml b/stack.yaml index cd17e307d0..b83c32f128 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,6 +20,7 @@ extra-deps: - optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132 - optparse-generic-1.5.1@sha256:c65a7d3429feedf870f5a9f7f0d2aaf75609888b52449f85f22871b5f5a7e95f,2204 - pantry-0.9.2@sha256:e1c5444d1b4003435d860853abd21e91e5fc337f2b2e2c8c992a2bac04712dc0,7650 +- rio-prettyprint-0.1.5.0@sha256:5b4e78c51933c2029650d9efc61aba268c1d138aaea1c28cb7864eaf6ff3b82e,1358 - static-bytes-0.1.0@sha256:35dbf30f617baa0151682c97687042516be07872a39984f9fe31f78125b962bf,1627 - tar-conduit-0.4.0@sha256:f333649770f5ec42a83a93b0d424cf6bb895d80dfbee05a54340395f81d036ae,3126 - tls-1.9.0@sha256:8ad332dc0224decb1b137bf6c9678b4f786487b9aaa5c9068cd3ad19d42c39a7,5571 diff --git a/stack.yaml.lock b/stack.yaml.lock index 2bedbecb90..4945d7109d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -116,6 +116,13 @@ packages: size: 2665 original: hackage: pantry-0.9.2@sha256:e1c5444d1b4003435d860853abd21e91e5fc337f2b2e2c8c992a2bac04712dc0,7650 +- completed: + hackage: rio-prettyprint-0.1.5.0@sha256:5b4e78c51933c2029650d9efc61aba268c1d138aaea1c28cb7864eaf6ff3b82e,1358 + pantry-tree: + sha256: 49baf043ac1cbf4c107da16aed5792f5cd6099885b2b4553fce4ff71b0d3477a + size: 628 + original: + hackage: rio-prettyprint-0.1.5.0@sha256:5b4e78c51933c2029650d9efc61aba268c1d138aaea1c28cb7864eaf6ff3b82e,1358 - completed: hackage: static-bytes-0.1.0@sha256:35dbf30f617baa0151682c97687042516be07872a39984f9fe31f78125b962bf,1627 pantry-tree: