version 0.13.40.13.4

1 files changed, 71 insertions, 22 deletions

diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index 7e4d81e..ebbe50d 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -15,12 +15,11 @@ import           Prelude
 import           Control.Concurrent.Async.Lifted as A
 import           Control.Concurrent.Lifted as C
 import           Control.Monad hiding (sequence)
-import           Control.Monad.Trans.Class (lift)
 import           Control.Monad.Trans.Control (MonadBaseControl(..))
 import           Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
 import           Data.Foldable (foldl')
 import qualified Data.Map as M
-import           Data.Maybe (catMaybes, fromMaybe)
+import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Time.Clock (UTCTime)
 import           Language.PureScript.AST
 import           Language.PureScript.Crash
@@ -28,6 +27,7 @@ import qualified Language.PureScript.CST as CST
 import           Language.PureScript.Errors
 import           Language.PureScript.Externs
 import           Language.PureScript.Make.Actions as Actions
+import           Language.PureScript.Make.Cache
 import           Language.PureScript.Names (ModuleName)
 
 -- | The BuildPlan tracks information about our build progress, and holds all
@@ -65,6 +65,20 @@ buildJobFailure :: BuildJobResult -> Maybe MultipleErrors
 buildJobFailure (BuildJobFailed errors) = Just errors
 buildJobFailure _ = Nothing
 
+-- | Information obtained about a particular module while constructing a build
+-- plan; used to decide whether a module needs rebuilding.
+data RebuildStatus = RebuildStatus
+  { statusModuleName :: ModuleName
+  , statusRebuildNever :: Bool
+  , statusNewCacheInfo :: Maybe CacheInfo
+    -- ^ New cache info for this module which should be stored for subsequent
+    -- incremental builds. A value of Nothing indicates that cache info for
+    -- this module should not be stored in the build cache, because it is being
+    -- rebuilt according to a RebuildPolicy instead.
+  , statusPrebuilt :: Maybe Prebuilt
+    -- ^ Prebuilt externs and timestamp for this module, if any.
+  }
+
 -- | Called when we finished compiling a module and want to report back the
 -- compilation result, as well as any potential errors that were thrown.
 markComplete
@@ -115,32 +129,67 @@ getResult buildPlan moduleName =
 construct
   :: forall m. (Monad m, MonadBaseControl IO m)
   => MakeActions m
+  -> CacheDb
   -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
-  -> m BuildPlan
-construct MakeActions{..} (sorted, graph) = do
-  prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern
-  let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted
-  buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt)
-  pure $ BuildPlan prebuilt buildJobs
+  -> m (BuildPlan, CacheDb)
+construct MakeActions{..} cacheDb (sorted, graph) = do
+  let sortedModuleNames = map (getModuleName . CST.resPartial) sorted
+  rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus
+  let prebuilt =
+        foldl' collectPrebuiltModules M.empty $
+          mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses
+  let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames
+  buildJobs <- foldM makeBuildJob M.empty toBeRebuilt
+  pure
+    ( BuildPlan prebuilt buildJobs
+    , let
+        update = flip $ \s ->
+          M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
+      in
+        foldl' update cacheDb rebuildStatuses
+    )
   where
     makeBuildJob prev moduleName = do
       buildJob <- BuildJob <$> C.newEmptyMVar
       pure (M.insert moduleName buildJob prev)
 
-    findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt))
-    findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do
-      inputTimestamp <- lift $ getInputTimestamp moduleName
-      (rebuildNever, existingTimestamp) <-
-        case inputTimestamp of
-          Left RebuildNever ->
-            fmap (True,) $ MaybeT $ getOutputTimestamp moduleName
-          Right (Just t1) -> do
-            outputTimestamp <- MaybeT $ getOutputTimestamp moduleName
-            guard (t1 < outputTimestamp)
-            pure (False, outputTimestamp)
-          _ -> mzero
-      externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
-      pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile)
+    getRebuildStatus :: ModuleName -> m RebuildStatus
+    getRebuildStatus moduleName = do
+      inputInfo <- getInputTimestampsAndHashes moduleName
+      case inputInfo of
+        Left RebuildNever -> do
+          prebuilt <- findExistingExtern moduleName
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = True
+            , statusPrebuilt = prebuilt
+            , statusNewCacheInfo = Nothing
+            })
+        Left RebuildAlways -> do
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = False
+            , statusPrebuilt = Nothing
+            , statusNewCacheInfo = Nothing
+            })
+        Right cacheInfo -> do
+          (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cacheInfo
+          prebuilt <-
+            if isUpToDate
+              then findExistingExtern moduleName
+              else pure Nothing
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = False
+            , statusPrebuilt = prebuilt
+            , statusNewCacheInfo = Just newCacheInfo
+            })
+
+    findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
+    findExistingExtern moduleName = runMaybeT $ do
+      timestamp <- MaybeT $ getOutputTimestamp moduleName
+      externs <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
+      pure (Prebuilt timestamp externs)
 
     collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
     collectPrebuiltModules prev (moduleName, rebuildNever, pb)