Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Refactor Rebuild monad into writer over sets #9843

Closed
wants to merge 2 commits into from
Closed

Refactor Rebuild monad into writer over sets #9843

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
5f90c11
Refactor Rebuild monad into writer over sets
edmundnoble Mar 25, 2024
be2695f
Format files
edmundnoble Mar 26, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 3 additions & 3 deletions Cabal/src/Distribution/Simple/Glob/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion cabal-install/cabal-install.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
62 changes: 33 additions & 29 deletions cabal-install/src/Distribution/Client/FileMonitor.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -231,7 +232,7 @@ data MonitorStateFile
!MonitorKindDir
!FilePath
!MonitorStateFileStatus
deriving (Show, Generic)
deriving (Eq, Ord, Show, Generic)

data MonitorStateFileStatus
= MonitorStateFileExists
Expand All @@ -244,7 +245,7 @@ data MonitorStateFileStatus
MonitorStateDirModTime !ModTime
| MonitorStateNonExistent
| MonitorStateAlreadyChanged
deriving (Show, Generic)
deriving (Eq, Ord, Show, Generic)

instance Binary MonitorStateFile
instance Binary MonitorStateFileStatus
Expand All @@ -259,7 +260,7 @@ data MonitorStateGlob
!MonitorKindDir
!FilePathRoot
!MonitorStateGlobRel
deriving (Show, Generic)
deriving (Eq, Ord, Show, Generic)

data MonitorStateGlobRel
= MonitorStateGlobDirs
Expand All @@ -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
Expand All @@ -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 _) =
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -569,14 +572,15 @@ 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
[ probeMonitorStateGlob root globPath
| globPath <- globPaths
]
Set.fromList
<$> sequence
[ probeMonitorStateGlob root globPath
| globPath <- Set.toList globPaths
]
return (MonitorStateFileSet singlePaths globPaths')

-----------------------------------------------
Expand Down Expand Up @@ -849,7 +853,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
Expand Down Expand Up @@ -889,20 +893,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)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This worries me: reverse implies the ordering is significant. (I know it's reversing because it uses : to prepend paths, but that still means the original path order is considered important enough to reconstruct afterward.)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, this worried me a bit too. I figure this was just out of habit, but I might be wrong.

go
!singlePaths
!globPaths
Expand All @@ -916,7 +920,7 @@ buildMonitorStateFileSet mstartTime hashcache root =
kinddir
root
path
go (monitorState : singlePaths) globPaths monitors
go (Set.insert monitorState singlePaths) globPaths monitors
go
!singlePaths
!globPaths
Expand All @@ -929,7 +933,7 @@ buildMonitorStateFileSet mstartTime hashcache root =
kinddir
root
globPath
go singlePaths (monitorState : globPaths) monitors
go singlePaths (Set.insert monitorState globPaths) monitors

buildMonitorStateFile
:: Maybe MonitorTimestamp
Expand Down Expand Up @@ -1129,7 +1133,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))
Expand All @@ -1138,14 +1142,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
]

Expand Down
4 changes: 2 additions & 2 deletions cabal-install/src/Distribution/Client/Glob.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
6 changes: 3 additions & 3 deletions cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -226,7 +226,7 @@ updatePackageConfigFileMonitor
pkgFileMonitorConfig
srcdir
Nothing
[]
mempty
pkgconfig
()
where
Expand All @@ -238,7 +238,7 @@ updatePackageBuildFileMonitor
-> MonitorTimestamp
-> ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> [MonitorFilePath]
-> Set MonitorFilePath
-> BuildResultMisc
-> IO ()
updatePackageBuildFileMonitor
Expand Down Expand Up @@ -285,7 +285,7 @@ updatePackageRegFileMonitor
pkgFileMonitorReg
srcdir
Nothing
[]
mempty
()
mipkg

Expand Down
19 changes: 10 additions & 9 deletions cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -473,7 +474,7 @@ buildInplaceUnpackedPackage
let listSimple =
execRebuild srcdir (needElaboratedConfiguredPackage pkg)
listSdist =
fmap (map monitorFileHashed) $
fmap (Set.fromList . map monitorFileHashed) $
allPackageSourceFiles verbosity srcdir
ifNullThen m m' = do
xs <- m
Expand All @@ -499,19 +500,20 @@ buildInplaceUnpackedPackage
listSimple

let dep_monitors =
map monitorFileHashed $
elabInplaceDependencyBuildCacheFiles
distDirLayout
pkgshared
plan
pkg
Set.fromList $
map monitorFileHashed $
elabInplaceDependencyBuildCacheFiles
distDirLayout
pkgshared
plan
pkg
updatePackageBuildFileMonitor
packageFileMonitor
srcdir
timestamp
pkg
buildStatus
(monitors ++ dep_monitors)
(monitors <> dep_monitors)
buildResult
PBHaddockPhase{runHaddock} -> do
runHaddock
Expand Down Expand Up @@ -933,4 +935,3 @@ withTempInstalledPackageInfoFile verbosity tempdir action =
unlines warns

return ipkg

Loading