Fix the FileMonitor to keep multiple monitors for the same file

Rather than doing any fancy merging of monitor kinds, we just do the
simple thing and keep each monitor spec separately, so each one will be
checked when the file system is probed. Internally, rather than keeping
a Map indexed by FilePath we just keep a list.

Add a regression test for this.

cabal-install/Distribution/Client/FileMonitor.hs

@@ -199,7 +199,7 @@ monitorFileHashedSearchPath notFoundAtPaths foundAtPath =
 -- files to be monitored (index by their path), and a list of
 -- globs, which monitor may files at once.
 data MonitorStateFileSet
-   = MonitorStateFileSet !(Map FilePath MonitorStateFile)
+   = MonitorStateFileSet ![MonitorStateFile]
                          ![MonitorStateGlob]
   deriving Show
 
@@ -216,7 +216,7 @@ type Hash = Int
 -- no longer exists at all.
 --
 data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir
-                                         !MonitorStateFileStatus
+                                         !FilePath !MonitorStateFileStatus
   deriving (Show, Generic)
 
 data MonitorStateFileStatus
@@ -262,11 +262,10 @@ instance Binary MonitorStateGlobRel
 --
 reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]
 reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
-    Map.foldrWithKey (\k x r -> getSinglePath k x : r)
-                     (map getGlobPath globPaths)
-                     singlePaths
+    map getSinglePath singlePaths
+ ++ map getGlobPath globPaths
   where
-    getSinglePath filepath (MonitorStateFile kindfile kinddir _) =
+    getSinglePath (MonitorStateFile kindfile kinddir filepath _) =
       MonitorFile kindfile kinddir filepath
 
     getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
@@ -516,7 +515,7 @@ probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =
   runChangedM $ do
     sequence_
       [ probeMonitorStateFileStatus root file status
-      | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ]
+      | MonitorStateFile _ _ file status <- singlePaths ]
     -- The glob monitors can require state changes
     globPaths' <-
       sequence
@@ -793,19 +792,19 @@ buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp
                                               --   relative to root
                          -> IO MonitorStateFileSet
 buildMonitorStateFileSet mstartTime hashcache root =
-    go Map.empty []
+    go [] []
   where
-    go :: Map FilePath MonitorStateFile -> [MonitorStateGlob]
+    go :: [MonitorStateFile] -> [MonitorStateGlob]
        -> [MonitorFilePath] -> IO MonitorStateFileSet
     go !singlePaths !globPaths [] =
-      return (MonitorStateFileSet singlePaths globPaths)
+      return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))
 
     go !singlePaths !globPaths
        (MonitorFile kindfile kinddir path : monitors) = do
-      monitorState <- MonitorStateFile kindfile kinddir
+      monitorState <- MonitorStateFile kindfile kinddir path
                   <$> buildMonitorStateFile mstartTime hashcache
                                             kindfile kinddir root path
-      go (Map.insert path monitorState singlePaths) globPaths monitors
+      go (monitorState : singlePaths) globPaths monitors
 
     go !singlePaths !globPaths
        (MonitorFileGlob kindfile kinddir globPath : monitors) = do
@@ -976,15 +975,15 @@ readCacheFileHashes monitor =
                     collectAllFileHashes singlePaths
         `Map.union` collectAllGlobHashes globPaths
 
-    collectAllFileHashes =
-      Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of
-        MonitorStateFileHashed mtime hash -> Just (mtime, hash)
-        _                                 -> Nothing
+    collectAllFileHashes singlePaths =
+      Map.fromList [ (fpath, (mtime, hash))
+                   | MonitorStateFile _ _ fpath
+                       (MonitorStateFileHashed mtime hash) <- singlePaths ]
 
     collectAllGlobHashes globPaths =
-      Map.fromList [ (fpath, hash)
+      Map.fromList [ (fpath, (mtime, hash))
                    | MonitorStateGlob _ _ _ gstate <- globPaths
-                   , (fpath, hash) <- collectGlobHashes "" gstate ]
+                   , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]
 
     collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
       [ res

cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs

@@ -34,6 +34,7 @@ tests mtimeChange =
   , testCase "remove file"           testRemoveFile
   , testCase "non-existent file"     testNonExistentFile
   , testCase "changed file type"     $ testChangedFileType mtimeChange
+  , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange
 
   , testGroup "glob matches"
     [ testCase "no change"           testGlobNoChange
@@ -328,6 +329,34 @@ testChangedFileType mtimeChange = do
         reason <- expectMonitorChanged root monitor ()
         reason @?= MonitoredFileChanged "a"
 
+-- Monitoring the same file with two different kinds of monitor should work
+-- both should be kept, and both checked for changes.
+-- We had a bug where only one monitor kind was kept per file.
+-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178
+testMultipleMonitorKinds :: Int -> Assertion
+testMultipleMonitorKinds mtimeChange =
+  withFileMonitor $ \root monitor -> do
+    touchFile root "a"
+    updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()
+    (res, files) <- expectMonitorUnchanged root monitor ()
+    res   @?= ()
+    files @?= [monitorFile "a", monitorFileHashed "a"]
+    threadDelay mtimeChange
+    touchFile root "a" -- not changing content, just mtime
+    reason <- expectMonitorChanged root monitor ()
+    reason @?= MonitoredFileChanged "a"
+
+    createDir root "dir"
+    updateMonitor root monitor [monitorDirectory "dir",
+                                monitorDirectoryExistence "dir"] () ()
+    (res2, files2) <- expectMonitorUnchanged root monitor ()
+    res2   @?= ()
+    files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]
+    threadDelay mtimeChange
+    touchFile root ("dir" </> "a") -- changing dir mtime, not existence
+    reason2 <- expectMonitorChanged root monitor ()
+    reason2 @?= MonitoredFileChanged "dir"
+
 
 ------------------
 -- globs