From ca287b541cc747f38edfe6934b2ff9ba2a994149 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sat, 21 Oct 2023 15:58:40 +0100 Subject: [PATCH] Clear Stan suggestions --- .stan.toml | 10 ----- doc/maintainers/stack_errors.md | 2 + src/GHC/Utils/GhcPkg/Main/Compat.hs | 67 ++++++++++++++++++++--------- 3 files changed, 49 insertions(+), 30 deletions(-) diff --git a/.stan.toml b/.stan.toml index 7bd26472f6..00411fa02c 100644 --- a/.stan.toml +++ b/.stan.toml @@ -22,16 +22,6 @@ scope = "all" type = "Exclude" -# Infinite: base/isSuffixOf -# Usage of the 'isSuffixOf' function that hangs on infinite lists -[[ignore]] - id = "OBS-STAN-0102-MEZP5/-198:10" -# ✦ Category: #Infinite #List -# ✦ File: src\GHC\Utils\GhcPkg\Main\Compat.hs -# 197 ┃ -# 198 ┃ | "-*" `isSuffixOf` str = -# 199 ┃ ^^^^^^^^^^^^ - # Infinite: base/isSuffixOf # Usage of the 'isSuffixOf' function that hangs on infinite lists [[ignore]] diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 45a3604d01..5956c4ac62 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -36,6 +36,8 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-1430] | SingleFileDBUnsupported FilePath [S-5996] | ParsePackageInfoExceptions String [S-3189] | CannotFindPackage PackageArg (Maybe FilePath) + [S-9323] | CannotParseRelFileBug String + [S-7651] | CannotParseDirectoryWithDBug String ~~~ - `Options.Applicative.Builder.Extra.OptionsApplicativeExtraException` diff --git a/src/GHC/Utils/GhcPkg/Main/Compat.hs b/src/GHC/Utils/GhcPkg/Main/Compat.hs index fe0a46526e..4ce406e484 100644 --- a/src/GHC/Utils/GhcPkg/Main/Compat.hs +++ b/src/GHC/Utils/GhcPkg/Main/Compat.hs @@ -41,7 +41,6 @@ module GHC.Utils.GhcPkg.Main.Compat ----------------------------------------------------------------------------- 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 ) @@ -58,7 +57,9 @@ import qualified Path as P import Path.IO ( createDirIfMissing, doesDirExist, listDir, removeFile ) import qualified RIO.ByteString as BS -import RIO.Partial ( fromJust ) +import RIO.List ( isPrefixOf, stripSuffix ) +import RIO.NonEmpty ( nonEmpty ) +import qualified RIO.NonEmpty as NE import Stack.Constants ( relFilePackageCache ) import Stack.Prelude hiding ( display ) import System.Environment ( getEnv ) @@ -97,6 +98,8 @@ data GhcPkgPrettyException | SingleFileDBUnsupported !(SomeBase Dir) | ParsePackageInfoExceptions !String | CannotFindPackage !PackageArg !(Maybe (SomeBase Dir)) + | CannotParseRelFileBug !String + | CannotParseDirectoryWithDBug !String deriving (Show, Typeable) instance Pretty GhcPkgPrettyException where @@ -149,6 +152,18 @@ instance Pretty GhcPkgPrettyException where where pkg_msg (Substring pkgpat _) = fillSep ["matching", fromString pkgpat] pkg_msg pkgarg' = fromString $ show pkgarg' + pretty (CannotParseRelFileBug relFileName) = bugPrettyReport "[S-9323]" $ + fillSep + [ flow "changeDBDir': Could not parse" + , style File (fromString relFileName) + , flow "as a relative path to a file." + ] + pretty (CannotParseDirectoryWithDBug dirName) = bugPrettyReport "[S-7651]" $ + fillSep + [ flow "adjustOldDatabasePath: Could not parse" + , style Dir (fromString dirName) + , flow "as a directory." + ] instance Exception GhcPkgPrettyException @@ -194,10 +209,11 @@ 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)" +readGlobPkgId str = case stripSuffix "-*" str of + Nothing -> + ExactPackageIdentifier <$> parseCheck str "package identifier (exact)" + Just str' -> + GlobPackageIdentifier <$> parseCheck str' "package identifier (glob)" readPackageArg :: AsPackageArg -> String -> RIO env PackageArg readPackageArg AsUnitId str = IUId <$> parseCheck str "installed package id" @@ -251,13 +267,14 @@ getPkgDatabases globalDb pkgarg pkgDb = do let sys_databases = [Abs globalDb] e_pkg_path <- tryIO (liftIO $ System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = - case e_pkg_path of + case nonEmpty <$> e_pkg_path of Left _ -> sys_databases - Right path - | not (null path) && isSearchPathSeparator (last path) - -> mapMaybe parseSomeDir (splitSearchPath (init path)) <> sys_databases + Right Nothing -> [] + Right (Just path) + | isSearchPathSeparator (NE.last path) + -> mapMaybe parseSomeDir (splitSearchPath (NE.init path)) <> sys_databases | otherwise - -> mapMaybe parseSomeDir (splitSearchPath path) + -> mapMaybe parseSomeDir (splitSearchPath $ NE.toList path) -- -f flags on the command line add to the database stack, unless any of them -- are present in the stack already. @@ -422,7 +439,7 @@ tryReadParseOldFileStyleDatabase mode path = do content <- liftIO $ readFile (prjSomeBase toFilePath path) `catchIO` \_ -> pure "" if take 2 content == "[]" then do - let path_dir = adjustOldDatabasePath path + path_dir <- adjustOldDatabasePath path prettyWarnL [ flow "Ignoring old file-style db and trying" , pretty path_dir @@ -454,16 +471,23 @@ adjustOldFileStylePackageDB db = do 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 } + Just "[]" -> do + adjustedDatabasePath <- adjustOldDatabasePath $ location db + pure db { location = adjustedDatabasePath } -- 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) +adjustOldDatabasePath :: SomeBase Dir -> RIO env (SomeBase Dir) +adjustOldDatabasePath = prjSomeBase addDToDirName + where + addDToDirName dir = do + let dirNameWithD = toFilePath dir <> ".d" + maybe + (prettyThrowIO $ CannotParseDirectoryWithDBug dirNameWithD) + pure + (parseSomeDir dirNameWithD) parsePackageInfo :: BS.ByteString -> RIO env (InstalledPackageInfo, [String]) parsePackageInfo str = @@ -503,9 +527,12 @@ changeDBDir' cmds db = do 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) + let relFileConfName = display (installedUnitId p) <> ".conf" + relFileConf <- maybe + (prettyThrowIO $ CannotParseRelFileBug relFileConfName) + pure + (parseRelFile relFileConfName) + let file = mapSomeBase (P. relFileConf) (location db) prettyDebugL [ "Removing" , pretty file