From 339b0825388b6b8f9183501c251f11427420c7c7 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sun, 3 Sep 2023 11:37:38 +0100 Subject: [PATCH] Use types from the path package --- package.yaml | 2 +- src/GHC/Utils/GhcPkg/Main/Compat.hs | 142 +++++++++++++++------------- stack.cabal | 8 +- stack.yaml | 1 + stack.yaml.lock | 7 ++ 5 files changed, 87 insertions(+), 73 deletions(-) diff --git a/package.yaml b/package.yaml index 149f81fc39..f23f4120b4 100644 --- a/package.yaml +++ b/package.yaml @@ -111,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 index 334ef9fafb..fe0a46526e 100644 --- a/src/GHC/Utils/GhcPkg/Main/Compat.hs +++ b/src/GHC/Utils/GhcPkg/Main/Compat.hs @@ -18,6 +18,7 @@ -- * 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 @@ -49,10 +50,16 @@ 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.Directory - ( createDirectoryIfMissing, doesDirectoryExist - , getDirectoryContents, removeFile ) +import RIO.Partial ( fromJust ) +import Stack.Constants ( relFilePackageCache ) import Stack.Prelude hiding ( display ) import System.Environment ( getEnv ) import System.FilePath as FilePath @@ -78,19 +85,18 @@ ghcPkgUnregisterForce globalDb pkgDb hasIpid pkgarg_strs = do : (pretty pkgDb <> ":") : mkNarrativeList (Just Current) False (map (fromString . show) pkgargs :: [StyleDoc]) - unregisterPackages globalDb pkgargs pkgDb' + unregisterPackages globalDb pkgargs pkgDb where - pkgDb' = toFilePath pkgDb 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 !FilePath !IOException - | SingleFileDBUnsupported !FilePath + | CannotOpenDBForModification !(SomeBase Dir) !IOException + | SingleFileDBUnsupported !(SomeBase Dir) | ParsePackageInfoExceptions !String - | CannotFindPackage !PackageArg !(Maybe FilePath) + | CannotFindPackage !PackageArg !(Maybe (SomeBase Dir)) deriving (Show, Typeable) instance Pretty GhcPkgPrettyException where @@ -110,7 +116,7 @@ instance Pretty GhcPkgPrettyException where <> line <> fillSep [ flow "Couldn't open database" - , style Dir (fromString db_path) + , pretty db_path , flow "for modification:" ] <> blankLine @@ -120,7 +126,7 @@ instance Pretty GhcPkgPrettyException where <> line <> fillSep [ flow "ghc no longer supports single-file style package databases" - , parens (style Dir (fromString path)) + , parens (pretty path) , "use" , style Shell (flow "ghc-pkg init") , flow "to create the database with the correct format." @@ -137,7 +143,7 @@ instance Pretty GhcPkgPrettyException where , style Current (pkg_msg pkgarg) , maybe "" - (\db_path -> fillSep ["in", style Dir (fromString db_path)]) + (\db_path -> fillSep ["in", pretty db_path]) mdb_path ] where @@ -201,7 +207,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str -- Package databases data PackageDB (mode :: GhcPkg.DbMode) = PackageDB - { location :: !FilePath + { 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. @@ -223,7 +229,7 @@ getPkgDatabases :: => Path Abs Dir -- ^ Path to the global package database. -> PackageArg - -> FilePath + -> Path Abs Dir -- ^ Path to the package database. -> RIO env @@ -242,41 +248,40 @@ getPkgDatabases globalDb pkgarg pkgDb = do -- 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 global_conf = toFilePath globalDb - sys_databases = [global_conf] + 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) - -> splitSearchPath (init path) ++ sys_databases + -> mapMaybe parseSomeDir (splitSearchPath (init path)) <> sys_databases | otherwise - -> splitSearchPath path + -> 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 = [pkgDb | pkgDb `notElem` env_stack] <> env_stack + let final_stack = [Abs pkgDb | Abs pkgDb `notElem` env_stack] <> env_stack - (db_stack, db_to_operate_on) <- getDatabases [pkgDb] final_stack + (db_stack, db_to_operate_on) <- getDatabases pkgDb final_stack - let flag_db_stack = [ db | db <- db_stack, location db == pkgDb ] + let flag_db_stack = [ db | db <- db_stack, location db == Abs pkgDb ] prettyDebugL $ flow "Db stack:" - : map (style Dir . fromString . location) db_stack + : map (pretty . location) db_stack F.forM_ db_to_operate_on $ \db -> prettyDebugL [ "Modifying:" - , style Dir (fromString $ location db) + , pretty $ location db ] prettyDebugL $ flow "Flag db stack:" - : map (style Dir . fromString . location) flag_db_stack + : map (pretty . location) flag_db_stack pure (db_stack, db_to_operate_on, flag_db_stack) where - getDatabases flag_db_names final_stack = do + 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 @@ -284,7 +289,7 @@ getPkgDatabases globalDb pkgarg pkgDb = do (db_stack, mto_modify) <- stateSequence Nothing [ \case to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path - Nothing -> if db_path `notElem` flag_db_names + Nothing -> if db_path /= Abs flag_db_name then (, Nothing) <$> readDatabase db_path else do let hasPkg :: PackageDB mode -> Bool @@ -293,7 +298,8 @@ getPkgDatabases globalDb pkgarg pkgDb = do openRo (e::IOException) = do db <- readDatabase db_path if hasPkg db - then couldntOpenDbForModification db_path e + then + prettyThrowIO $ CannotOpenDBForModification db_path e else pure (db, Nothing) -- If we fail to open the database in read/write mode, we need @@ -321,12 +327,8 @@ getPkgDatabases globalDb pkgarg pkgDb = do pure (db_stack, GhcPkg.DbOpenReadWrite to_modify) where - couldntOpenDbForModification :: FilePath -> IOException -> RIO env a - couldntOpenDbForModification db_path e = prettyThrowIO $ - CannotOpenDBForModification db_path e - -- Parse package db in read-only mode. - readDatabase :: FilePath -> RIO env (PackageDB 'GhcPkg.DbReadOnly) + readDatabase :: SomeBase Dir -> RIO env (PackageDB 'GhcPkg.DbReadOnly) readDatabase = readParseDatabase GhcPkg.DbOpenReadOnly stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) @@ -339,10 +341,10 @@ getPkgDatabases globalDb pkgarg pkgDb = do readParseDatabase :: forall mode t env. HasTerm env => GhcPkg.DbOpenMode mode t - -> FilePath + -> SomeBase Dir -> RIO env (PackageDB mode) readParseDatabase mode path = do - e <- tryIO $ getDirectoryContents path + e <- tryIO $ prjSomeBase listDir path case e of Left err | ioeGetErrorType err == InappropriateType -> do @@ -354,23 +356,25 @@ readParseDatabase mode path = do Nothing -> prettyThrowIO $ SingleFileDBUnsupported path | otherwise -> liftIO $ ioError err - Right fs -> ignore_cache (const $ pure ()) + Right (_, fs) -> ignore_cache where - confs = map (path ) $ filter (".conf" `isSuffixOf`) fs - - ignore_cache :: (FilePath -> RIO env ()) -> RIO env (PackageDB mode) - ignore_cache checkTime = 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 cache) mode - let doFile f = do - checkTime f - parseSingletonPackageConf f - pkgs <- mapM doFile confs + 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 = path cachefilename + cache = mapSomeBase (P. relFilePackageCache) path mkPackageDB :: [InstalledPackageInfo] @@ -385,17 +389,14 @@ readParseDatabase mode path = do parseSingletonPackageConf :: HasTerm env - => FilePath + => Path Abs File -> RIO env InstalledPackageInfo parseSingletonPackageConf file = do prettyDebugL [ flow "Reading package config:" - , style File (fromString file) + , pretty file ] - BS.readFile file >>= fmap fst . parsePackageInfo - -cachefilename :: FilePath -cachefilename = "package.cache" + BS.readFile (toFilePath file) >>= fmap fst . parsePackageInfo -- ----------------------------------------------------------------------------- -- Workaround for old single-file style package dbs @@ -414,19 +415,19 @@ cachefilename = "package.cache" tryReadParseOldFileStyleDatabase :: HasTerm env => GhcPkg.DbOpenMode mode t - -> FilePath + -> 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 path `catchIO` \_ -> pure "" + 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" - , style Dir (fromString path_dir) + , pretty path_dir ] - direxists <- doesDirectoryExist path_dir + direxists <- prjSomeBase doesDirExist path_dir if direxists then do db <- readParseDatabase mode path_dir @@ -434,8 +435,9 @@ tryReadParseOldFileStyleDatabase mode path = do pure $ Just db { location = path } else do lock <- F.forM mode $ \_ -> do - createDirectoryIfMissing True path_dir - liftIO $ GhcPkg.lockPackageDb $ path_dir cachefilename + prjSomeBase (createDirIfMissing True) path_dir + liftIO $ GhcPkg.lockPackageDb $ + prjSomeBase (toFilePath . (P. relFilePackageCache)) path_dir pure $ Just PackageDB { location = path , packageDbLock = lock @@ -449,7 +451,7 @@ 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 (location db)) `catchIO` \_ -> pure Nothing + 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 @@ -459,8 +461,9 @@ adjustOldFileStylePackageDB db = do -- probably not old style, carry on as normal Nothing -> pure db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") +adjustOldDatabasePath :: SomeBase Dir -> SomeBase Dir +adjustOldDatabasePath = + fromJust . prjSomeBase (parseSomeDir . (<> ".d") . toFilePath) parsePackageInfo :: BS.ByteString -> RIO env (InstalledPackageInfo, [String]) parsePackageInfo str = @@ -486,7 +489,7 @@ changeNewDB :: -> RIO env () changeNewDB cmds new_db = do new_db' <- adjustOldFileStylePackageDB new_db - createDirectoryIfMissing True (location new_db') + prjSomeBase (createDirIfMissing True) (location new_db') changeDBDir' cmds new_db' changeDBDir' :: @@ -500,10 +503,12 @@ changeDBDir' cmds db = do GhcPkg.DbOpenReadWrite lock -> liftIO $ GhcPkg.unlockPackageDb lock where do_cmd (RemovePackage p) = do - let file = location db display (installedUnitId p) <.> "conf" + let relFileConf = + fromJust (parseRelFile $ display (installedUnitId p) <> ".conf") + file = mapSomeBase (P. relFileConf) (location db) prettyDebugL [ "Removing" - , style File (fromString file) + , pretty file ] removeFileSafe file @@ -512,7 +517,8 @@ unregisterPackages :: => Path Abs Dir -- ^ Path to the global package database. -> [PackageArg] - -> String + -> Path Abs Dir + -- ^ Path to the package database. -> RIO env () unregisterPackages globalDb pkgargs pkgDb = do pkgsByPkgDBs <- F.foldlM (getPkgsByPkgDBs []) [] pkgargs @@ -601,7 +607,7 @@ matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool (Substring _ m) `matchesPkg` pkg = m (display (mungedId pkg)) -- removeFileSave doesn't throw an exceptions, if the file is already deleted -removeFileSafe :: FilePath -> RIO env () +removeFileSafe :: SomeBase File -> RIO env () removeFileSafe fn = do - removeFile fn `catchIO` \ e -> + prjSomeBase removeFile fn `catchIO` \ e -> unless (isDoesNotExistError e) $ liftIO $ ioError e diff --git a/stack.cabal b/stack.cabal index 76b59df94a..2b6d1a5a1b 100644 --- a/stack.cabal +++ b/stack.cabal @@ -382,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 @@ -500,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 @@ -599,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 @@ -712,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 b581d977a2..4f3c675005 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.0@sha256:1de163cf439350d2c5817dd9067b51eeb62d6fdd4e2f0a70c06c9e1b931c38d7,2285 - 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.7.0@sha256:fa82e9ca8fd887b66fba8433b3ba1db4e5e047fe7c815707f06209679d04177b,5566 diff --git a/stack.yaml.lock b/stack.yaml.lock index 217f3918a0..c28faf75cf 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: