purescript · EMattfolk · Oct 20, 2022 · Oct 26, 2022 · Oct 26, 2022 · Nov 18, 2022
diff --git a/CHANGELOG.d/fix_invalid-entries-in-cache-db.md b/CHANGELOG.d/fix_invalid-entries-in-cache-db.md
@@ -0,0 +1 @@
+* Invalid entries are now removed from cache-db.json
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -136,7 +136,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
 --
 -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without
 -- having to typecheck those modules again.
-make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m)
      => MakeActions m
      -> [CST.PartialResult Module]
      -> m [ExternsFile]
@@ -177,7 +177,10 @@ make ma@MakeActions{..} ms = do
       M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
 
   -- Write the updated build cache database to disk
-  writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
+  let moduleSet = S.fromList $ map (getModuleName . CST.resPartial) sorted
+  writeCacheDb
+    =<< Cache.removeModules (M.keysSet failures)
+    <$> pruneMissingFiles (pruneMissingModules moduleSet newCacheDb)
 
   writePackageJson
 
@@ -261,6 +264,25 @@ make ma@MakeActions{..} ms = do
   onExceptionLifted :: m a -> m b -> m a
   onExceptionLifted l r = control $ \runInIO -> runInIO l `onException` runInIO r
 
+  -- Remove missing files from the cache.
+  -- Will remove modules without files.
+  pruneMissingFiles :: Cache.CacheDb -> m Cache.CacheDb
+  pruneMissingFiles cache =
+     M.filter (not . null . Cache.unCacheInfo)
+       <$> traverse (
+           fmap Cache.CacheInfo
+             . fmap M.fromList
+             . filterM (\(name, _) -> (/= Nothing) <$> getTimestampMaybe name)
+             . M.toList
+             . Cache.unCacheInfo
+       ) cache
+
+  -- Remove modules which are currently not being compiled.
+  pruneMissingModules :: S.Set ModuleName -> Cache.CacheDb -> Cache.CacheDb
+  pruneMissingModules modules cache =
+    let missingModules = S.difference (S.fromList (M.keys cache)) modules
+     in Cache.removeModules missingModules cache
+
 -- | Infer the module name for a module by looking for the same filename with
 -- a .js extension.
 inferForeignModules

diff --git a/tests/TestMake.hs b/tests/TestMake.hs
@@ -13,12 +13,14 @@ import Control.Monad
 import Control.Exception (tryJust)
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_)
+import qualified Data.Aeson as Aeson
 import Data.Time.Calendar
 import Data.Time.Clock
 import qualified Data.Text as T
 import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as M
+import Language.PureScript.Make.Cache (CacheDb)
 
 import System.FilePath
 import System.Directory
@@ -196,6 +198,57 @@ spec = do
       -- recompiled.
       go optsCorefnOnly `shouldReturn` moduleNames ["Module"]
 
+    it "writes cache-db.json" $ do
+      let modulePath = sourcesDir </> "Module.purs"
+
+      writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n"
+      compile [modulePath] `shouldReturn` moduleNames ["Module"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames ["Module"]
+
+    it "removes old entry from cache when module is renamed" $ do
+      let modulePath = sourcesDir </> "Module.purs"
+
+      writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n"
+      compile [modulePath] `shouldReturn` moduleNames ["Module"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames ["Module"]
+
+      writeFileWithTimestamp modulePath timestampA "module Module2 where\nfoo = 0\n"
+      compile [modulePath] `shouldReturn` moduleNames ["Module2"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames ["Module2"]
+
+    it "removes old entry from cache when file and module is renamed" $ do
+      let modulePath1 = sourcesDir </> "Module1.purs"
+
+      writeFileWithTimestamp modulePath1 timestampA "module Module1 where\nfoo = 0\n"
+      compile [modulePath1] `shouldReturn` moduleNames ["Module1"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames ["Module1"]
+
+      removeFile modulePath1
+      let modulePath2 = sourcesDir </> "Module2.purs"
+
+      writeFileWithTimestamp modulePath2 timestampA "module Module2 where\nfoo = 0\n"
+      compile [modulePath2] `shouldReturn` moduleNames ["Module2"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames  ["Module2"]
+
+    it "removes old entry from cache when file is deleted" $ do
+      let modulePath = sourcesDir </> "Module.purs"
+
+      writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n"
+      compile [modulePath] `shouldReturn` moduleNames ["Module"]
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames ["Module"]
+
+      removeFile modulePath
+
+      compile [] `shouldReturn` moduleNames []
+
+      M.keysSet <$> readCacheDb `shouldReturn` moduleNames []
+
 -- Note [Sleeping to avoid flaky tests]
 --
 -- One of the things we want to test here is that all requested output files
@@ -269,8 +322,15 @@ writeFileWithTimestamp path mtime contents = do
   writeUTF8FileT path contents
   setModificationTime path mtime
 
+readCacheDb :: IO CacheDb
+readCacheDb = do
+  let cachePath = modulesDir </> "cache-db.json"
+  maybeCache :: Maybe CacheDb <- Aeson.decodeFileStrict' cachePath
+  case maybeCache of
+    Just cache -> return cache
+    Nothing -> fail "CacheDb could not be read"
+
 -- | Use a different output directory to ensure that we don't get interference
 -- from other test results
 modulesDir :: FilePath
 modulesDir = ".test_modules" </> "make"
-
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		* Invalid entries are now removed from cache-db.json