Refactor externs diff and make api, fix some review sugs

wclr · wclr · commit 42c9b5f6c5d6 · 2023-07-06T03:23:36.000+05:00
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
@@ -65,7 +65,7 @@ compile PSCMakeOptions{..} = do
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
     let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+    P.make_ makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
@@ -79,7 +79,7 @@ make
   -> P.Make ([P.ExternsFile], P.Environment)
 make ms = do
     foreignFiles <- P.inferForeignModules filePathMap
-    externs <- P.make' (buildActions foreignFiles) (map snd ms)
+    externs <- P.make (buildActions foreignFiles) (map snd ms)
     return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
   where
     buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -1,10 +1,8 @@
 module Language.PureScript.Make
-  (
-  -- * Make API
-  rebuildModule
+  ( make
+  , make_
+  , rebuildModule
   , rebuildModule'
-  , make
-  , make'
   , inferForeignModules
   , module Monad
   , module Actions
@@ -14,7 +12,7 @@ import Prelude
 
 import Control.Concurrent.Lifted as C
 import Control.Exception.Base (onException)
-import Control.Monad (foldM, unless, when)
+import Control.Monad (foldM, unless, when, void, foldM, unless, when)
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
@@ -131,57 +129,53 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
                Right d -> d
 
   evalSupplyT nextVar'' $ codegen renamed docs exts
-  -- evaluate $ trace ("\n===== externs: " <> show moduleName <> ":\n" <> show exts) ()
   return exts
 
+data MakeOptions = MakeOptions
+  { moCollectAllExterns :: Bool
+  }
+
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file
 -- and an @externs.cbor@ file.
 --
 -- 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.
 --
--- This version will collect an return externs only of modules that were used
--- during the build.
+-- It collects and returns externs for all modules passed.
 make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
      => MakeActions m
      -> [CST.PartialResult Module]
      -> m [ExternsFile]
-make ma ms = makeImp ma ms False
+make  = make' (MakeOptions {moCollectAllExterns = True})
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file
 -- and an @externs.cbor@ file.
 --
--- 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.
---
--- This version will collect an return all externs of all passed modules.
-make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+-- This version of make returns nothing.
+make_ :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
      => MakeActions m
      -> [CST.PartialResult Module]
-     -> m [ExternsFile]
-make' ma ms = makeImp ma ms True
+     -> m ()
+make_ ma ms = void $ make' (MakeOptions {moCollectAllExterns = False}) ma ms
 
-makeImp :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-     => MakeActions m
+make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+     => MakeOptions
+     -> MakeActions m
      -> [CST.PartialResult Module]
-     -> Bool
      -> m [ExternsFile]
-makeImp ma@MakeActions{..} ms collectAll = do
+make' MakeOptions{..} ma@MakeActions{..} ms = do
   checkModuleNames
   cacheDb <- readCacheDb
 
   (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms
-
-  (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) collectAll
+  let opts = BuildPlan.Options {optPreloadAllExterns = moCollectAllExterns}
+  (buildPlan, newCacheDb) <- BuildPlan.construct opts ma cacheDb (sorted, graph)
 
   let sortedModuleNames = getModuleName . CST.resPartial <$> sorted
   let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
   let totalModuleCount = length toBeRebuilt
   for_ toBeRebuilt $ \m -> fork $ do
-    -- evaluate $ trace ("resPartial:" <> show (CST.resPartial $ m)) ()
-    -- evaluate $ trace ("resFull:" <> show (CST.resFull $ m)) ()
     let moduleName = getModuleName . CST.resPartial $ m
     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
     buildModule buildPlan moduleName totalModuleCount
@@ -225,10 +219,11 @@ makeImp ma@MakeActions{..} ms collectAll = do
         fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name)
         $ M.lookup mn successes
 
-  if collectAll then
-    pure $ map lookupResult sortedModuleNames
-  else
-    pure $ mapMaybe (flip M.lookup successes) sortedModuleNames
+  pure $
+    if moCollectAllExterns then
+      map lookupResult sortedModuleNames
+    else
+      mapMaybe (flip M.lookup successes) sortedModuleNames
 
   where
   checkModuleNames :: m ()
@@ -275,12 +270,9 @@ makeImp ma@MakeActions{..} ms collectAll = do
       case mexterns of
         Just (_, depsDiffExterns) -> do
           let externs = fst <$> depsDiffExterns
-          --evaluate $ trace ("diff:" <> show moduleName <> ":" <> show (snd <$> depsDiffExterns)) ()
-          --evaluate $ trace ("check diff:" <> show moduleName <> ":" <> show (isNothing $ traverse snd depsDiffExterns)) ()
           let prevResult = BuildPlan.getPrevResult buildPlan moduleName
           let depsDiffs = traverse snd depsDiffExterns
           let maySkipBuild moduleIndex
-                --  Just exts <- BuildPlan.getPrevResult buildPlan moduleName
                 -- we may skip built only for up-to-date modules
                 | Just (True, exts) <- prevResult
                 -- check if no dep's externs have changed
@@ -291,7 +283,6 @@ makeImp ma@MakeActions{..} ms collectAll = do
                   -- compilation results as actual. If it fails to update timestamp
                   -- on any of exiting codegen targets, it will run the build process.
                   updated <- updateOutputTimestamp moduleName
-                  --evaluate $ trace ("updated:" <> show updated <> ":" <> show moduleName) ()
                   if updated then do
                     progress $ SkippingModule moduleName moduleIndex
                     pure $ Just (exts, MultipleErrors [], Just (emptyDiff moduleName))
@@ -311,9 +302,7 @@ makeImp ma@MakeActions{..} ms collectAll = do
           env <- C.readMVar (bpEnv buildPlan)
           idx <- C.takeMVar (bpIndex buildPlan)
           C.putMVar (bpIndex buildPlan) (idx + 1)
-          -- (exts, warnings) <- do
-          --   let doBuild = listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
-          --   maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure
+
           (exts, warnings, diff) <- do
             let doBuild = do
                   (exts, warnings) <-
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
@@ -155,8 +155,6 @@ readCacheDb'
   -- ^ The path to the output directory
   -> m CacheDb
 readCacheDb' outputDir = do
-  --fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir)
-  --fromMaybe mempty <$> (fmap fromCacheDbVersioned <$> readJSONFile (cacheDbFile outputDir))
   mdb <- readJSONFile (cacheDbFile outputDir)
   pure $ fromMaybe mempty $ do
     db <- mdb
@@ -268,11 +266,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   updateOutputTimestamp mn = do
     curTime <- getCurrentTime
     ok <- setTimestamp (outputFilename mn externsFileName) curTime
-    -- then update all actual codegen targets
+    -- Then update timestamps of all actual codegen targets.
     codegenTargets <- asks optionsCodegenTargets
     let outputPaths = fmap (targetFilename mn) (S.toList codegenTargets)
     results <- traverse (flip setTimestamp curTime) outputPaths
-    -- if something goes wrong, something failed to update, return Nothing
+    -- If something goes wrong (any of targets doesn't exit, a file system
+    -- error), return False.
     pure $ and (ok : results)
 
   readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
@@ -1,6 +1,7 @@
 module Language.PureScript.Make.BuildPlan
   ( BuildPlan(bpEnv, bpIndex)
   , BuildJobResult(..)
+  , Options(..)
   , construct
   , getResult
   , getPrevResult
@@ -130,7 +131,6 @@ getResult
   -> ModuleName
   -> m (Maybe SuccessResult)
 getResult buildPlan moduleName =
-  -- may bring back first lookup for bpPrebuilt
   case M.lookup moduleName (bpBuildJobs buildPlan) of
     Just bj ->
       buildJobSuccess <$> C.readMVar (bjResult bj)
@@ -146,20 +146,23 @@ getPrevResult :: BuildPlan -> ModuleName -> Maybe (Bool, ExternsFile)
 getPrevResult buildPlan moduleName =
   fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan)
 
+
+data Options = Options
+  { optPreloadAllExterns :: Bool
+  }
+
 -- | Constructs a BuildPlan for the given module graph.
 --
 -- The given MakeActions are used to collect various timestamps in order to
 -- determine whether a module needs rebuilding.
 construct
   :: forall m. MonadBaseControl IO m
-  => MakeActions m
+  => Options
+  -> MakeActions m
   -> CacheDb
   -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
-  -> Bool
-  -- ^ If True will preload all the externs, otherwise will load only needed for
-  -- the build.
   -> m (BuildPlan, CacheDb)
-construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do
+construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do
   let sortedModuleNames = map (getModuleName . CST.resPartial) sorted
   rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus
 
@@ -177,9 +180,10 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do
   let inBuildDeps = flip S.member allBuildDeps
 
   -- We only need prebuilt results for deps of the modules to be build.
-  let toLoadPrebuilt
-        | preloadAll = prebuiltMap
-        | otherwise = M.filterWithKey (const . inBuildDeps) prebuiltMap
+  let toLoadPrebuilt =
+        if optPreloadAllExterns
+          then prebuiltMap
+          else M.filterWithKey (const . inBuildDeps) prebuiltMap
 
   -- We will need previously built results for modules to be build
   -- to skip rebuilding if deps have not changed.
@@ -203,8 +207,8 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do
   let prebuilt = M.mapMaybe id prebuiltLoad
   let previous = M.mapMaybe id prevLoad
 
-  -- If for some reason (wrong version, files corruption) loading fails,
-  -- those modules should be rebuilt too.
+  -- If for some reason (wrong version, files corruption, etc) prebuilt
+  -- externs loading fails, those modules should be rebuilt too.
   let failedLoads = M.keys $ M.filter isNothing prebuiltLoad
   buildJobs <- foldM makeBuildJob M.empty (toBeRebuilt <> failedLoads)
 
@@ -219,8 +223,8 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do
         foldl' update cacheDb rebuildStatuses
     )
   where
-    -- Timestamp here is just to ensure that we will try to load modules that
-    -- have previous built results available.
+    -- Timestamp here is just to ensure that we will only try to load modules
+    -- that have previous built results available.
     loadPrebuilt :: ModuleName -> UTCTime -> m (Maybe Prebuilt)
     loadPrebuilt = const . fmap (fmap Prebuilt . snd) . readExterns
 
diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs
@@ -72,13 +72,12 @@ hash = ContentHash . Hash.hash
 type CacheDb = Map ModuleName CacheInfo
 
 data CacheDbVersioned = CacheDbVersioned { cdbVersion :: Text, cdbModules :: CacheDb }
-  --deriving stock (Show)
   deriving (Eq, Ord)
 
 instance Aeson.FromJSON CacheDbVersioned where
   parseJSON = Aeson.withObject "CacheDb" $ \v ->
     CacheDbVersioned
-      <$> v .:  "version"
+      <$> v .: "version"
       <*> v .: "modules"
 
 instance Aeson.ToJSON CacheDbVersioned where
diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
