From 5f90c11589db0ceda296ac056beb03e4ee25d4e5 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Mon, 25 Mar 2024 13:35:35 -0400 Subject: [PATCH 1/2] Refactor Rebuild monad into writer over sets --- .../src/Distribution/Simple/Glob/Internal.hs | 4 +- cabal-install/cabal-install.cabal | 3 +- .../src/Distribution/Client/FileMonitor.hs | 57 +++---- cabal-install/src/Distribution/Client/Glob.hs | 4 +- .../ProjectBuilding/PackageFileMonitor.hs | 6 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 8 +- .../src/Distribution/Client/ProjectConfig.hs | 18 +-- .../Distribution/Client/ProjectPlanning.hs | 5 +- .../src/Distribution/Client/RebuildMonad.hs | 40 ++--- cabal-install/src/Distribution/Client/VCS.hs | 3 +- .../Distribution/Client/FileMonitor.hs | 146 +++++++++--------- 11 files changed, 153 insertions(+), 141 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs index 4f0b91eca39..a88f86cb53b 100644 --- a/Cabal/src/Distribution/Simple/Glob/Internal.hs +++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs @@ -49,7 +49,7 @@ data Glob GlobFile !GlobPieces | -- | Trailing dir; a glob ending in @/@. GlobDirTrailing - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary Glob instance Structured Glob @@ -65,7 +65,7 @@ data GlobPiece Literal String | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@ Union [GlobPieces] - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary GlobPiece instance Structured GlobPiece diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 95b7ce725f3..ba2be24f509 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -247,7 +247,8 @@ library regex-base >= 0.94.0.0 && <0.95, regex-posix >= 0.96.0.0 && <0.97, safe-exceptions >= 0.1.7.0 && < 0.2, - semaphore-compat >= 1.0.0 && < 1.1 + semaphore-compat >= 1.0.0 && < 1.1, + transformers >= 0.5.6.2 && < 0.7 if flag(native-dns) if os(windows) diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index 084545d5e7e..d409273fdb5 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -52,6 +52,7 @@ import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy as BS import qualified Data.Hashable as Hashable import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Control.Exception import Control.Monad @@ -93,20 +94,20 @@ data MonitorFilePath , monitorKindDir :: !MonitorKindDir , monitorPathGlob :: !RootedGlob } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) data MonitorKindFile = FileExists | FileModTime | FileHashed | FileNotExists - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) data MonitorKindDir = DirExists | DirModTime | DirNotExists - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary MonitorFilePath instance Binary MonitorKindFile @@ -202,8 +203,8 @@ monitorFileHashedSearchPath notFoundAtPaths foundAtPath = -- globs, which monitor may files at once. data MonitorStateFileSet = MonitorStateFileSet - ![MonitorStateFile] - ![MonitorStateGlob] + !(Set MonitorStateFile) + !(Set MonitorStateGlob) -- Morally this is not actually a set but a bag (represented by lists). -- There is no principled reason to use a bag here rather than a set, but -- there is also no particular gain either. That said, we do preserve the @@ -231,7 +232,7 @@ data MonitorStateFile !MonitorKindDir !FilePath !MonitorStateFileStatus - deriving (Show, Generic) + deriving (Eq, Ord, Show, Generic) data MonitorStateFileStatus = MonitorStateFileExists @@ -244,7 +245,7 @@ data MonitorStateFileStatus MonitorStateDirModTime !ModTime | MonitorStateNonExistent | MonitorStateAlreadyChanged - deriving (Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary MonitorStateFile instance Binary MonitorStateFileStatus @@ -259,7 +260,7 @@ data MonitorStateGlob !MonitorKindDir !FilePathRoot !MonitorStateGlobRel - deriving (Show, Generic) + deriving (Eq, Ord, Show, Generic) data MonitorStateGlobRel = MonitorStateGlobDirs @@ -272,7 +273,7 @@ data MonitorStateGlobRel !ModTime ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted | MonitorStateGlobDirTrailing - deriving (Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary MonitorStateGlob instance Binary MonitorStateGlobRel @@ -283,9 +284,11 @@ instance Structured MonitorStateGlobRel -- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by -- inspecting the state of the file system, and we can go in the reverse -- direction by just forgetting the extra info. -reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] +reconstructMonitorFilePaths :: MonitorStateFileSet -> Set MonitorFilePath reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - map getSinglePath singlePaths ++ map getGlobPath globPaths + Set.fromList + $ map getSinglePath (Set.toList singlePaths) + <> map getGlobPath (Set.toList globPaths) where getSinglePath :: MonitorStateFile -> MonitorFilePath getSinglePath (MonitorStateFile kindfile kinddir filepath _) = @@ -374,7 +377,7 @@ data MonitorChanged a b -- -- The set of monitored files is also returned. This is useful -- for composing or nesting 'FileMonitor's. - MonitorUnchanged b [MonitorFilePath] + MonitorUnchanged b (Set MonitorFilePath) | -- | The monitor found that something changed. The reason is given. MonitorChanged (MonitorChangedReason a) deriving (Show) @@ -569,13 +572,13 @@ probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = runChangedM $ do sequence_ [ probeMonitorStateFileStatus root file status - | MonitorStateFile _ _ file status <- singlePaths + | MonitorStateFile _ _ file status <- Set.toList singlePaths ] -- The glob monitors can require state changes globPaths' <- - sequence + Set.fromList <$> sequence [ probeMonitorStateGlob root globPath - | globPath <- globPaths + | globPath <- Set.toList globPaths ] return (MonitorStateFileSet singlePaths globPaths') @@ -849,7 +852,7 @@ updateFileMonitor -- ^ root directory -> Maybe MonitorTimestamp -- ^ timestamp when the update action started - -> [MonitorFilePath] + -> Set MonitorFilePath -- ^ files of interest relative to root -> a -- ^ the current key value @@ -889,20 +892,20 @@ buildMonitorStateFileSet -- ^ existing file hashes -> FilePath -- ^ root directory - -> [MonitorFilePath] + -> Set MonitorFilePath -- ^ patterns of interest -- relative to root -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root = - go [] [] + go mempty mempty . Set.toList where go - :: [MonitorStateFile] - -> [MonitorStateGlob] + :: Set MonitorStateFile + -> Set MonitorStateGlob -> [MonitorFilePath] -> IO MonitorStateFileSet go !singlePaths !globPaths [] = - return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) + return (MonitorStateFileSet singlePaths globPaths) go !singlePaths !globPaths @@ -916,7 +919,7 @@ buildMonitorStateFileSet mstartTime hashcache root = kinddir root path - go (monitorState : singlePaths) globPaths monitors + go (Set.insert monitorState singlePaths) globPaths monitors go !singlePaths !globPaths @@ -929,7 +932,7 @@ buildMonitorStateFileSet mstartTime hashcache root = kinddir root globPath - go singlePaths (monitorState : globPaths) monitors + go singlePaths (Set.insert monitorState globPaths) monitors buildMonitorStateFile :: Maybe MonitorTimestamp @@ -1129,7 +1132,7 @@ readCacheFileHashes monitor = collectAllFileHashes singlePaths `Map.union` collectAllGlobHashes globPaths - collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash) + collectAllFileHashes :: Set MonitorStateFile -> Map FilePath (ModTime, Hash) collectAllFileHashes singlePaths = Map.fromList [ (fpath, (mtime, hash)) @@ -1138,14 +1141,14 @@ readCacheFileHashes monitor = _ fpath (MonitorStateFileHashed mtime hash) <- - singlePaths + Set.toList singlePaths ] - collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash) + collectAllGlobHashes :: Set MonitorStateGlob -> Map FilePath (ModTime, Hash) collectAllGlobHashes globPaths = Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateGlob _ _ _ gstate <- globPaths + | MonitorStateGlob _ _ _ gstate <- Set.toList globPaths , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs index 90054a8f64f..943268096f5 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -39,7 +39,7 @@ data RootedGlob -- ^ what the glob is relative to Glob -- ^ the glob - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary RootedGlob instance Structured RootedGlob @@ -49,7 +49,7 @@ data FilePathRoot | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' FilePathRoot FilePath | FilePathHomeDir - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary FilePathRoot instance Structured FilePathRoot diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs index b93064ea7be..5fa19b63bb3 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -226,7 +226,7 @@ updatePackageConfigFileMonitor pkgFileMonitorConfig srcdir Nothing - [] + mempty pkgconfig () where @@ -238,7 +238,7 @@ updatePackageBuildFileMonitor -> MonitorTimestamp -> ElaboratedConfiguredPackage -> BuildStatusRebuild - -> [MonitorFilePath] + -> Set MonitorFilePath -> BuildResultMisc -> IO () updatePackageBuildFileMonitor @@ -285,7 +285,7 @@ updatePackageRegFileMonitor pkgFileMonitorReg srcdir Nothing - [] + mempty () mipkg diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 5b651746dc1..cc7981ed3c9 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -91,6 +91,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) @@ -472,8 +473,7 @@ buildInplaceUnpackedPackage let listSimple = execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ + listSdist = fmap (Set.fromList . map monitorFileHashed) $ allPackageSourceFiles verbosity srcdir ifNullThen m m' = do xs <- m @@ -499,6 +499,7 @@ buildInplaceUnpackedPackage listSimple let dep_monitors = + Set.fromList $ map monitorFileHashed $ elabInplaceDependencyBuildCacheFiles distDirLayout @@ -511,7 +512,7 @@ buildInplaceUnpackedPackage timestamp pkg buildStatus - (monitors ++ dep_monitors) + (monitors <> dep_monitors) buildResult PBHaddockPhase{runHaddock} -> do runHaddock @@ -933,4 +934,3 @@ withTempInstalledPackageInfoFile verbosity tempdir action = unlines warns return ipkg - diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 23d8cbab932..97428671936 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -685,7 +685,7 @@ readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do then do readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file" else do - monitorFiles [monitorNonExistentFile projectFile] + monitorFiles (Set.singleton (monitorNonExistentFile projectFile)) return (singletonProjectConfigSkeleton defaultImplicitProjectConfig) defaultImplicitProjectConfig :: ProjectConfig @@ -739,12 +739,12 @@ readProjectFileSkeleton exists <- liftIO $ doesFileExist extensionFile if exists then do - monitorFiles [monitorFileHashed extensionFile] + monitorFiles (Set.singleton (monitorFileHashed extensionFile)) pcs <- liftIO readExtensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + monitorFiles (Set.fromList (map monitorFileHashed (projectSkeletonImports pcs))) pure pcs else do - monitorFiles [monitorNonExistentFile extensionFile] + monitorFiles (Set.singleton (monitorNonExistentFile extensionFile)) return mempty where extensionFile = distProjectFile extensionName @@ -782,7 +782,7 @@ readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig readGlobalConfig verbosity configFileFlag = do config <- liftIO (loadConfig verbosity configFileFlag) configFile <- liftIO (getConfigFilePath configFileFlag) - monitorFiles [monitorFileHashed configFile] + monitorFiles (Set.singleton (monitorFileHashed configFile)) return (convertLegacyGlobalConfig config) reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton @@ -1230,7 +1230,7 @@ readSourcePackageLocalDirectory -- ^ The package @.cabal@ file -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readSourcePackageLocalDirectory verbosity dir cabalFile = do - monitorFiles [monitorFileHashed cabalFile] + monitorFiles (Set.singleton (monitorFileHashed cabalFile)) root <- askRoot let location = LocalUnpackedPackage (root dir) liftIO $ @@ -1246,7 +1246,7 @@ readSourcePackageLocalTarball -> FilePath -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readSourcePackageLocalTarball verbosity tarballFile = do - monitorFiles [monitorFile tarballFile] + monitorFiles (Set.singleton (monitorFile tarballFile)) root <- askRoot let location = LocalTarballPackage (root tarballFile) liftIO $ @@ -1286,7 +1286,7 @@ fetchAndReadSourcePackageRemoteTarball return () -- Read - monitorFiles [monitorFile tarballFile] + monitorFiles (Set.singleton (monitorFile tarballFile)) let location = RemoteTarballPackage tarballUri tarballFile liftIO $ fmap (mkSpecificSourcePackage location) @@ -1437,7 +1437,7 @@ syncAndReadSourcePackagesRemoteRepos (_ : _ : _) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir [cabalFileName] -> do let cabalFilePath = packageDir cabalFileName - monitorFiles [monitorFileHashed cabalFilePath] + monitorFiles (Set.singleton (monitorFileHashed cabalFilePath)) gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath -- write sdist tarball, to repoPath-pgkid diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6344249a8a6..f55dccd4f4c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -488,7 +488,7 @@ configureCompiler -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb'') + monitorFiles (Set.fromList (programsMonitorFiles progdb'')) return result where @@ -941,7 +941,7 @@ getInstalledPackages -> PackageDBStack -> Rebuild InstalledPackageIndex getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory + monitorFiles . Set.fromList . map monitorFileOrDirectory =<< liftIO ( IndexUtils.getInstalledPackagesMonitorFiles verbosity @@ -1166,6 +1166,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do | (pkgid, tarball) <- allTarballFilePkgs ] monitorFiles + $ Set.fromList [ monitorFile tarball | (_pkgid, tarball) <- allTarballFilePkgs ] diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index 33303ea3243..c497fd132c1 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -69,15 +69,16 @@ import Distribution.Simple.Utils (debug) import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Monad.Reader as Reader -import Control.Monad.State as State +import Control.Monad.Writer.Strict as Writer import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import System.Directory import System.FilePath -- | A monad layered on top of 'IO' to help with re-running actions when the -- input files and values they depend on change. The crucial operations are -- 'rerunIfChanged' and 'monitorFiles'. -newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) +newtype Rebuild a = Rebuild (ReaderT FilePath (WriterT (Set MonitorFilePath) IO) a) deriving (Functor, Applicative, Monad, MonadIO) -- | Use this within the body action of 'rerunIfChanged' to declare that the @@ -87,20 +88,20 @@ newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) -- -- Relative paths are interpreted as relative to an implicit root, ultimately -- passed in to 'runRebuild'. -monitorFiles :: [MonitorFilePath] -> Rebuild () -monitorFiles filespecs = Rebuild (State.modify (filespecs ++)) +monitorFiles :: Set MonitorFilePath -> Rebuild () +monitorFiles filespecs = Rebuild (Writer.tell filespecs) -- | Run a 'Rebuild' IO action. -unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) -unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] +unRebuild :: FilePath -> Rebuild a -> IO (a, Set MonitorFilePath) +unRebuild rootDir (Rebuild action) = runWriterT (runReaderT action rootDir) -- | Run a 'Rebuild' IO action. runRebuild :: FilePath -> Rebuild a -> IO a -runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] +runRebuild rootDir (Rebuild action) = fst <$> runWriterT (runReaderT action rootDir) -- | Run a 'Rebuild' IO action. -execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] -execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] +execRebuild :: FilePath -> Rebuild a -> IO (Set MonitorFilePath) +execRebuild rootDir (Rebuild action) = execWriterT (runReaderT action rootDir) -- | The root that relative paths are interpreted as being relative to. askRoot :: Rebuild FilePath @@ -236,7 +237,7 @@ delayInitSharedResources action = do matchFileGlob :: RootedGlob -> Rebuild [FilePath] matchFileGlob glob = do root <- askRoot - monitorFiles [monitorFileGlobExistence glob] + monitorFiles (Set.singleton (monitorFileGlobExistence glob)) liftIO $ Glob.matchFileGlob root glob getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] @@ -248,7 +249,7 @@ getDirectoryContentsMonitored dir = do createDirectoryMonitored :: Bool -> FilePath -> Rebuild () createDirectoryMonitored createParents dir = do - monitorFiles [monitorDirectoryExistence dir] + monitorFiles (Set.singleton (monitorDirectoryExistence dir)) liftIO $ createDirectoryIfMissing createParents dir -- | Monitor a directory as in 'monitorDirectory' if it currently exists or @@ -257,10 +258,11 @@ monitorDirectoryStatus :: FilePath -> Rebuild Bool monitorDirectoryStatus dir = do exists <- liftIO $ doesDirectoryExist dir monitorFiles - [ if exists + $ Set.singleton + ( if exists then monitorDirectory dir else monitorNonExistentDirectory dir - ] + ) return exists -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does @@ -270,15 +272,16 @@ doesFileExistMonitored f = do root <- askRoot exists <- liftIO $ doesFileExist (root f) monitorFiles - [ if exists + $ Set.singleton + ( if exists then monitorFileExistence f else monitorNonExistentFile f - ] + ) return exists -- | Monitor a single file need :: FilePath -> Rebuild () -need f = monitorFiles [monitorFileHashed f] +need f = monitorFiles (Set.singleton (monitorFileHashed f)) -- | Monitor a file if it exists; otherwise check for when it -- gets created. This is a bit better for recompilation avoidance @@ -290,10 +293,11 @@ needIfExists f = do root <- askRoot exists <- liftIO $ doesFileExist (root f) monitorFiles - [ if exists + $ Set.singleton + ( if exists then monitorFileHashed f else monitorNonExistentFile f - ] + ) -- | Like 'findFileWithExtension', but in the 'Rebuild' monad. findFileWithExtensionMonitored diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 7c071de31eb..b3a77e49525 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -90,6 +90,7 @@ import Control.Monad.Trans import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Map as Map +import qualified Data.Set as Set import System.Directory ( doesDirectoryExist , removeDirectoryRecursive @@ -274,7 +275,7 @@ syncSourceRepos -> Rebuild () syncSourceRepos verbosity vcs repos = do files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos - monitorFiles files + monitorFiles (Set.fromList files) -- ------------------------------------------------------------ diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs index f3c8145bc49..fceb7459a7e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -8,6 +8,7 @@ import Control.Concurrent (threadDelay) import Control.Exception import Control.Monad import Data.Proxy (Proxy (..)) +import Data.Set (Set) import qualified Data.Set as Set import qualified System.Directory as IO import System.FilePath @@ -188,10 +189,10 @@ testCorruptMonitorCache step = reason @?= MonitorCorruptCache step "Updating file monitor" - updateMonitor root monitor [] () () + updateMonitor root monitor mempty () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [] + files @?= mempty step "Writing broken file again" IO.writeFile (fileMonitorCacheFile monitor) "broken" @@ -203,11 +204,11 @@ testEmptyMonitor :: Assertion testEmptyMonitor = withFileMonitor $ \root monitor -> do touchFile root "a" - updateMonitor root monitor [] () () + updateMonitor root monitor mempty () () touchFile root "b" (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [] + files @?= mempty -- monitor a file that is expected to exist testMissingFile :: Assertion @@ -228,13 +229,13 @@ testMissingFile = do withFileMonitor $ \root monitor -> do -- a file that doesn't exist at snapshot time is considered to have -- changed - updateMonitor root monitor [monitorKind file] () () + updateMonitor root monitor (Set.singleton (monitorKind file)) () () reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged file -- a file doesn't exist at snapshot time, but gets added afterwards is -- also considered to have changed - updateMonitor root monitor [monitorKind file] () () + updateMonitor root monitor (Set.singleton (monitorKind file)) () () touch root file reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged file @@ -257,7 +258,7 @@ testChangedFile mtimeChange = do test monitorKind touch touch' file = withFileMonitor $ \root monitor -> do touch root file - updateMonitor root monitor [monitorKind file] () () + updateMonitor root monitor (Set.singleton (monitorKind file)) () () threadDelay mtimeChange touch' root file reason <- expectMonitorChanged root monitor () @@ -268,28 +269,28 @@ testChangedFileMtimeVsContent mtimeChange = withFileMonitor $ \root monitor -> do -- if we don't touch the file, it's unchanged touchFile root "a" - updateMonitor root monitor [monitorFile "a"] () () + updateMonitor root monitor (Set.singleton (monitorFile "a")) () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFile "a"] + files @?= Set.fromList [monitorFile "a"] -- if we do touch the file, it's changed if we only consider mtime - updateMonitor root monitor [monitorFile "a"] () () + updateMonitor root monitor (Set.singleton (monitorFile "a")) () () threadDelay mtimeChange touchFile root "a" reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged "a" -- but if we touch the file, it's unchanged if we consider content hash - updateMonitor root monitor [monitorFileHashed "a"] () () + updateMonitor root monitor (Set.singleton (monitorFileHashed "a")) () () threadDelay mtimeChange touchFile root "a" (res2, files2) <- expectMonitorUnchanged root monitor () res2 @?= () - files2 @?= [monitorFileHashed "a"] + files2 @?= Set.fromList [monitorFileHashed "a"] -- finally if we change the content it's changed - updateMonitor root monitor [monitorFileHashed "a"] () () + updateMonitor root monitor (Set.singleton (monitorFileHashed "a")) () () threadDelay mtimeChange touchFileContent root "a" reason2 <- expectMonitorChanged root monitor () @@ -314,25 +315,25 @@ testUpdateDuringAction mtimeChange = do test monitorSpec touch file = withFileMonitor $ \root monitor -> do touch root file - updateMonitor root monitor [monitorSpec] () () + updateMonitor root monitor (Set.singleton (monitorSpec)) () () -- start doing an update action... threadDelay mtimeChange -- some time passes touch root file -- a file gets updates during the action threadDelay mtimeChange -- some time passes then we finish - updateMonitor root monitor [monitorSpec] () () + updateMonitor root monitor (Set.singleton (monitorSpec)) () () -- we don't notice this change since we took the timestamp after the -- action finished (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorSpec] + files @?= Set.fromList [monitorSpec] -- Let's try again, this time taking the timestamp before the action timestamp' <- beginUpdateFileMonitor threadDelay mtimeChange -- some time passes touch root file -- a file gets updates during the action threadDelay mtimeChange -- some time passes then we finish - updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () () + updateMonitorWithTimestamp root monitor timestamp' (Set.singleton (monitorSpec)) () () -- now we do notice the change since we took the snapshot before the -- action finished reason <- expectMonitorChanged root monitor () @@ -356,7 +357,7 @@ testRemoveFile = do test monitorKind touch remove file = withFileMonitor $ \root monitor -> do touch root file - updateMonitor root monitor [monitorKind file] () () + updateMonitor root monitor (Set.singleton (monitorKind file)) () () remove root file reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged file @@ -366,10 +367,10 @@ testNonExistentFile :: Assertion testNonExistentFile = withFileMonitor $ \root monitor -> do -- a file that doesn't exist at snapshot time or check time is unchanged - updateMonitor root monitor [monitorNonExistentFile "a"] () () + updateMonitor root monitor (Set.singleton (monitorNonExistentFile "a")) () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorNonExistentFile "a"] + files @?= Set.fromList [monitorNonExistentFile "a"] -- if the file then exists it has changed touchFile root "a" @@ -377,7 +378,7 @@ testNonExistentFile = reason @?= MonitoredFileChanged "a" -- if the file then exists at snapshot and check time it has changed - updateMonitor root monitor [monitorNonExistentFile "a"] () () + updateMonitor root monitor (Set.singleton (monitorNonExistentFile "a")) () () reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged "a" @@ -387,11 +388,11 @@ testNonExistentFile = -- can depend on that content, whereas if the action expected a file not to -- exist and it now does not, it'll give the same result, irrespective of -- the fact that the file might have existed in the meantime. - updateMonitor root monitor [monitorNonExistentFile "a"] () () + updateMonitor root monitor (Set.singleton (monitorNonExistentFile "a")) () () removeFile root "a" (res2, files2) <- expectMonitorUnchanged root monitor () res2 @?= () - files2 @?= [monitorNonExistentFile "a"] + files2 @?= Set.fromList [monitorNonExistentFile "a"] testChangedFileType :: Int -> Assertion testChangedFileType mtimeChange = do @@ -421,7 +422,7 @@ testChangedFileType mtimeChange = do test monitorKind touch remove touch' = withFileMonitor $ \root monitor -> do touch root "a" - updateMonitor root monitor [monitorKind] () () + updateMonitor root monitor (Set.singleton (monitorKind)) () () threadDelay mtimeChange remove root "a" touch' root "a" @@ -436,10 +437,10 @@ testMultipleMonitorKinds :: Int -> Assertion testMultipleMonitorKinds mtimeChange = withFileMonitor $ \root monitor -> do touchFile root "a" - updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () () + updateMonitor root monitor (Set.fromList [monitorFile "a", monitorFileHashed "a"]) () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFile "a", monitorFileHashed "a"] + files @?= Set.fromList [monitorFile "a", monitorFileHashed "a"] threadDelay mtimeChange touchFile root "a" -- not changing content, just mtime reason <- expectMonitorChanged root monitor () @@ -449,14 +450,15 @@ testMultipleMonitorKinds mtimeChange = updateMonitor root monitor + (Set.fromList [ monitorDirectory "dir" , monitorDirectoryExistence "dir" - ] + ]) () () (res2, files2) <- expectMonitorUnchanged root monitor () res2 @?= () - files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"] + files2 @?= Set.fromList [monitorDirectory "dir", monitorDirectoryExistence "dir"] threadDelay mtimeChange touchFile root ("dir" "a") -- changing dir mtime, not existence reason2 <- expectMonitorChanged root monitor () @@ -471,19 +473,19 @@ testGlobNoChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/good-*"] testGlobAddMatch :: Int -> Assertion testGlobAddMatch mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/good-*"] threadDelay mtimeChange touchFile root ("dir" "good-b") reason <- expectMonitorChanged root monitor () @@ -494,7 +496,7 @@ testGlobRemoveMatch mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () threadDelay mtimeChange removeFile root "dir/good-a" reason <- expectMonitorChanged root monitor () @@ -505,12 +507,12 @@ testGlobChangeMatch mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () threadDelay mtimeChange touchFile root ("dir" "good-b") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/good-*"] touchFileContent root ("dir" "good-b") reason <- expectMonitorChanged root monitor () @@ -520,7 +522,7 @@ testGlobAddMatchSubdir :: Int -> Assertion testGlobAddMatchSubdir mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "a" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/good-*")) () () threadDelay mtimeChange touchFile root ("dir" "b" "good-b") reason <- expectMonitorChanged root monitor () @@ -531,7 +533,7 @@ testGlobRemoveMatchSubdir mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "a" "good-a") touchFile root ("dir" "b" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/good-*")) () () threadDelay mtimeChange removeDir root ("dir" "a") reason <- expectMonitorChanged root monitor () @@ -542,12 +544,12 @@ testGlobChangeMatchSubdir mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "a" "good-a") touchFile root ("dir" "b" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/good-*")) () () threadDelay mtimeChange touchFile root ("dir" "b" "good-b") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/*/good-*"] touchFileContent root "dir/b/good-b" reason <- expectMonitorChanged root monitor () @@ -557,7 +559,7 @@ testGlobChangeMatchSubdir mtimeChange = testGlobMatchTopDir :: Int -> Assertion testGlobMatchTopDir mtimeChange = withFileMonitor $ \root monitor -> do - updateMonitor root monitor [monitorFileGlobStr "*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "*")) () () threadDelay mtimeChange touchFile root "a" reason <- expectMonitorChanged root monitor () @@ -567,47 +569,47 @@ testGlobAddNonMatch :: Int -> Assertion testGlobAddNonMatch mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () threadDelay mtimeChange touchFile root ("dir" "bad") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/good-*"] testGlobRemoveNonMatch :: Int -> Assertion testGlobRemoveNonMatch mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "good-a") touchFile root ("dir" "bad") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/good-*")) () () threadDelay mtimeChange removeFile root "dir/bad" (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/good-*"] testGlobAddNonMatchSubdir :: Int -> Assertion testGlobAddNonMatchSubdir mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "a" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/good-*")) () () threadDelay mtimeChange touchFile root ("dir" "b" "bad") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/*/good-*"] testGlobRemoveNonMatchSubdir :: Int -> Assertion testGlobRemoveNonMatchSubdir mtimeChange = withFileMonitor $ \root monitor -> do touchFile root ("dir" "a" "good-a") touchFile root ("dir" "b" "bad") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/good-*")) () () threadDelay mtimeChange removeDir root ("dir" "b") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] + files @?= Set.fromList [monitorFileGlobStr "dir/*/good-*"] -- try and tickle a bug that happens if we don't maintain the invariant that -- MonitorStateGlobFiles entries are sorted @@ -618,7 +620,7 @@ testInvariantMonitorStateGlobFiles mtimeChange = touchFile root ("dir" "b") touchFile root ("dir" "c") touchFile root ("dir" "d") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*")) () () threadDelay mtimeChange -- so there should be no change (since we're doing content checks) -- but if we can get the dir entries to appear in the wrong order @@ -634,7 +636,7 @@ testInvariantMonitorStateGlobFiles mtimeChange = touchFile root ("dir" "a") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*"] + files @?= Set.fromList [monitorFileGlobStr "dir/*"] -- same thing for the subdirs case testInvariantMonitorStateGlobDirs :: Int -> Assertion @@ -644,7 +646,7 @@ testInvariantMonitorStateGlobDirs mtimeChange = touchFile root ("dir" "b" "file") touchFile root ("dir" "c" "file") touchFile root ("dir" "d" "file") - updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/file")) () () threadDelay mtimeChange removeDir root ("dir" "a") removeDir root ("dir" "b") @@ -656,25 +658,25 @@ testInvariantMonitorStateGlobDirs mtimeChange = touchFile root ("dir" "a" "file") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*/file"] + files @?= Set.fromList [monitorFileGlobStr "dir/*/file"] -- ensure that a glob can match a directory as well as a file testGlobMatchDir :: Int -> Assertion testGlobMatchDir mtimeChange = withFileMonitor $ \root monitor -> do createDir root ("dir" "a") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*")) () () threadDelay mtimeChange -- nothing changed yet (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*"] + files @?= Set.fromList [monitorFileGlobStr "dir/*"] -- expect dir/b to match and be detected as changed createDir root ("dir" "b") reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged ("dir" "b") -- now remove dir/a and expect it to be detected as changed - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*")) () () threadDelay mtimeChange removeDir root ("dir" "a") reason2 <- expectMonitorChanged root monitor () @@ -683,13 +685,13 @@ testGlobMatchDir mtimeChange = testGlobMatchDirOnly :: Int -> Assertion testGlobMatchDirOnly mtimeChange = withFileMonitor $ \root monitor -> do - updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*/")) () () threadDelay mtimeChange -- expect file dir/a to not match, so not detected as changed touchFile root ("dir" "a") (res, files) <- expectMonitorUnchanged root monitor () res @?= () - files @?= [monitorFileGlobStr "dir/*/"] + files @?= Set.fromList [monitorFileGlobStr "dir/*/"] -- note that checking the file monitor for changes can updates the -- cached dir mtimes (when it has to record that there's new matches) -- so we need an extra mtime delay @@ -704,14 +706,14 @@ testGlobChangeFileType mtimeChange = withFileMonitor $ \root monitor -> do -- change file to dir touchFile root ("dir" "a") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*")) () () threadDelay mtimeChange removeFile root ("dir" "a") createDir root ("dir" "a") reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged ("dir" "a") -- change dir to file - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr "dir/*")) () () threadDelay mtimeChange removeDir root ("dir" "a") touchFile root ("dir" "a") @@ -725,19 +727,19 @@ testGlobAbsolutePath mtimeChange = -- absolute glob, removing a file touchFile root ("dir/good-a") touchFile root ("dir/good-b") - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr (root' "dir/good-*"))) () () threadDelay mtimeChange removeFile root "dir/good-a" reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged (root' "dir" "good-a") -- absolute glob, adding a file - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr (root' "dir/good-*"))) () () threadDelay mtimeChange touchFile root ("dir/good-a") reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged (root' "dir" "good-a") -- absolute glob, changing a file - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () + updateMonitor root monitor (Set.singleton (monitorFileGlobStr (root' "dir/good-*"))) () () threadDelay mtimeChange touchFileContent root "dir/good-b" reason3 <- expectMonitorChanged root monitor () @@ -751,16 +753,16 @@ testValueUnchanged :: Assertion testValueUnchanged = withFileMonitor $ \root monitor -> do touchFile root "a" - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" + updateMonitor root monitor (Set.singleton (monitorFile "a")) (42 :: Int) "ok" (res, files) <- expectMonitorUnchanged root monitor 42 res @?= "ok" - files @?= [monitorFile "a"] + files @?= Set.fromList [monitorFile "a"] testValueChanged :: Assertion testValueChanged = withFileMonitor $ \root monitor -> do touchFile root "a" - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" + updateMonitor root monitor (Set.singleton (monitorFile "a")) (42 :: Int) "ok" reason <- expectMonitorChanged root monitor 43 reason @?= MonitoredValueChanged 42 @@ -770,7 +772,7 @@ testValueAndFileChanged mtimeChange = touchFile root "a" -- we change the value and the file, and the value change is reported - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" + updateMonitor root monitor (Set.singleton (monitorFile "a")) (42 :: Int) "ok" threadDelay mtimeChange touchFile root "a" reason <- expectMonitorChanged root monitor 43 @@ -780,12 +782,12 @@ testValueAndFileChanged mtimeChange = -- then it's reported as MonitoredValueChanged let monitor' :: FileMonitor Int String monitor' = monitor{fileMonitorCheckIfOnlyValueChanged = True} - updateMonitor root monitor' [monitorFile "a"] 42 "ok" + updateMonitor root monitor' (Set.singleton (monitorFile "a")) 42 "ok" reason2 <- expectMonitorChanged root monitor' 43 reason2 @?= MonitoredValueChanged 42 -- but if a file changed too then we don't report MonitoredValueChanged - updateMonitor root monitor' [monitorFile "a"] 42 "ok" + updateMonitor root monitor' (Set.singleton (monitorFile "a")) 42 "ok" threadDelay mtimeChange touchFile root "a" reason3 <- expectMonitorChanged root monitor' 43 @@ -803,7 +805,7 @@ testValueUpdated = , fileMonitorKeyValid = Set.isSubsetOf } - updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42, 43]) "ok" + updateMonitor root monitor' (Set.singleton (monitorFile "a")) (Set.fromList [42, 43]) "ok" (res, _files) <- expectMonitorUnchanged root monitor' (Set.fromList [42]) res @?= "ok" @@ -870,7 +872,7 @@ expectMonitorUnchanged => RootPath -> FileMonitor a b -> a - -> IO (b, [MonitorFilePath]) + -> IO (b, Set MonitorFilePath) expectMonitorUnchanged root monitor key = do res <- checkChanged root monitor key case res of @@ -890,7 +892,7 @@ updateMonitor :: (Binary a, Structured a, Binary b, Structured b) => RootPath -> FileMonitor a b - -> [MonitorFilePath] + -> Set MonitorFilePath -> a -> b -> IO () @@ -902,7 +904,7 @@ updateMonitorWithTimestamp => RootPath -> FileMonitor a b -> MonitorTimestamp - -> [MonitorFilePath] + -> Set MonitorFilePath -> a -> b -> IO () From be2695fe2c6caee9b242f9ff866dac14a4adaf60 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Mon, 25 Mar 2024 20:13:01 -0400 Subject: [PATCH 2/2] Format files --- .../src/Distribution/Simple/Glob/Internal.hs | 2 +- .../src/Distribution/Client/FileMonitor.hs | 15 ++++---- .../Client/ProjectBuilding/UnpackedPackage.hs | 15 ++++---- .../Distribution/Client/ProjectPlanning.hs | 10 +++--- .../src/Distribution/Client/RebuildMonad.hs | 36 +++++++++---------- .../Distribution/Client/FileMonitor.hs | 9 ++--- 6 files changed, 45 insertions(+), 42 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs index a88f86cb53b..c987cbab082 100644 --- a/Cabal/src/Distribution/Simple/Glob/Internal.hs +++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs @@ -457,8 +457,8 @@ checkNameMatches spec glob candidate -- if multidot is supported, then this is a clean match if enableMultidot spec then pure (GlobMatch ()) - else -- if not, issue a warning saying multidot is needed for the match + else -- if not, issue a warning saying multidot is needed for the match let (_, candidateExts) = splitExtensions $ takeFileName candidate extractExts :: GlobPieces -> Maybe String extractExts [] = Nothing diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index d409273fdb5..4a53f30b6c7 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -286,9 +286,9 @@ instance Structured MonitorStateGlobRel -- direction by just forgetting the extra info. reconstructMonitorFilePaths :: MonitorStateFileSet -> Set MonitorFilePath reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - Set.fromList - $ map getSinglePath (Set.toList singlePaths) - <> map getGlobPath (Set.toList globPaths) + Set.fromList $ + map getSinglePath (Set.toList singlePaths) + <> map getGlobPath (Set.toList globPaths) where getSinglePath :: MonitorStateFile -> MonitorFilePath getSinglePath (MonitorStateFile kindfile kinddir filepath _) = @@ -576,10 +576,11 @@ probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = ] -- The glob monitors can require state changes globPaths' <- - Set.fromList <$> sequence - [ probeMonitorStateGlob root globPath - | globPath <- Set.toList globPaths - ] + Set.fromList + <$> sequence + [ probeMonitorStateGlob root globPath + | globPath <- Set.toList globPaths + ] return (MonitorStateFileSet singlePaths globPaths') ----------------------------------------------- diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index cc7981ed3c9..a78ebaff142 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -473,7 +473,8 @@ buildInplaceUnpackedPackage let listSimple = execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = fmap (Set.fromList . map monitorFileHashed) $ + listSdist = + fmap (Set.fromList . map monitorFileHashed) $ allPackageSourceFiles verbosity srcdir ifNullThen m m' = do xs <- m @@ -500,12 +501,12 @@ buildInplaceUnpackedPackage let dep_monitors = Set.fromList $ - map monitorFileHashed $ - elabInplaceDependencyBuildCacheFiles - distDirLayout - pkgshared - plan - pkg + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg updatePackageBuildFileMonitor packageFileMonitor srcdir diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index f55dccd4f4c..8db6fbe7329 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1165,11 +1165,11 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do return (pkgid, srchash) | (pkgid, tarball) <- allTarballFilePkgs ] - monitorFiles - $ Set.fromList - [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs - ] + monitorFiles $ + Set.fromList + [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs + ] -- Return the combination return $! diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index c497fd132c1..cc8f559cf01 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -257,12 +257,12 @@ createDirectoryMonitored createParents dir = do monitorDirectoryStatus :: FilePath -> Rebuild Bool monitorDirectoryStatus dir = do exists <- liftIO $ doesDirectoryExist dir - monitorFiles - $ Set.singleton - ( if exists - then monitorDirectory dir - else monitorNonExistentDirectory dir - ) + monitorFiles $ + Set.singleton + ( if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir + ) return exists -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does @@ -271,12 +271,12 @@ doesFileExistMonitored :: FilePath -> Rebuild Bool doesFileExistMonitored f = do root <- askRoot exists <- liftIO $ doesFileExist (root f) - monitorFiles - $ Set.singleton - ( if exists - then monitorFileExistence f - else monitorNonExistentFile f - ) + monitorFiles $ + Set.singleton + ( if exists + then monitorFileExistence f + else monitorNonExistentFile f + ) return exists -- | Monitor a single file @@ -292,12 +292,12 @@ needIfExists :: FilePath -> Rebuild () needIfExists f = do root <- askRoot exists <- liftIO $ doesFileExist (root f) - monitorFiles - $ Set.singleton - ( if exists - then monitorFileHashed f - else monitorNonExistentFile f - ) + monitorFiles $ + Set.singleton + ( if exists + then monitorFileHashed f + else monitorNonExistentFile f + ) -- | Like 'findFileWithExtension', but in the 'Rebuild' monad. findFileWithExtensionMonitored diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs index fceb7459a7e..3d49feb7261 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -450,10 +450,11 @@ testMultipleMonitorKinds mtimeChange = updateMonitor root monitor - (Set.fromList - [ monitorDirectory "dir" - , monitorDirectoryExistence "dir" - ]) + ( Set.fromList + [ monitorDirectory "dir" + , monitorDirectoryExistence "dir" + ] + ) () () (res2, files2) <- expectMonitorUnchanged root monitor ()