From 118a12f2a8c33f45f06f962ea0d7ba37e883008a Mon Sep 17 00:00:00 2001 From: Alex Date: Tue, 26 Dec 2023 12:24:25 +0500 Subject: [PATCH 1/8] Make cut-off, the main piece --- purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 2 +- .../PureScript/AST/Declarations/ChainId.hs | 2 +- src/Language/PureScript/Docs/Collect.hs | 2 +- src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Externs.hs | 6 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Make.hs | 124 +++- src/Language/PureScript/Make/Actions.hs | 69 ++- src/Language/PureScript/Make/BuildPlan.hs | 228 +++++--- src/Language/PureScript/Make/Cache.hs | 39 +- src/Language/PureScript/Make/ExternsDiff.hs | 440 ++++++++++++++ src/Language/PureScript/Make/Monad.hs | 18 +- tests/TestMake.hs | 543 ++++++++++++++---- tests/TestUtils.hs | 2 +- 15 files changed, 1250 insertions(+), 230 deletions(-) create mode 100644 src/Language/PureScript/Make/ExternsDiff.hs diff --git a/purescript.cabal b/purescript.cabal index 5cecca41fc..5f6a5c0759 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -335,6 +335,7 @@ library Language.PureScript.Make.Actions Language.PureScript.Make.BuildPlan Language.PureScript.Make.Cache + Language.PureScript.Make.ExternsDiff Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index cf0c83a42d..7184cbb812 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -165,7 +165,7 @@ importPrim = . addDefaultImport (Qualified ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed - deriving (Show, Generic, NFData, Serialise) + deriving (Eq, Show, Generic, NFData, Serialise) -- | -- An item in a list of explicit imports or exports diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs index aacfc11fe8..5997c55b04 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -1,5 +1,5 @@ module Language.PureScript.AST.Declarations.ChainId - ( ChainId + ( ChainId(..) , mkChainId ) where diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 0da65d2251..ad538c1ae4 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -96,7 +96,7 @@ compileForDocs outputDir inputFiles = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions outputDir filePathMap foreigns False) - { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "Compiling documentation for " + { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for " } P.make makeActions (map snd ms) either throwError return result diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..0c087e9cf1 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -82,7 +82,7 @@ data FunctionalDependency = FunctionalDependency -- ^ the type arguments which determine the determined type arguments , fdDetermined :: [Int] -- ^ the determined type arguments - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance NFData FunctionalDependency instance Serialise FunctionalDependency diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a9669a9995..70ad704142 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -89,7 +89,7 @@ data ExternsFixity = ExternsFixity , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) - } deriving (Show, Generic, NFData) + } deriving (Eq, Show, Generic, NFData) instance Serialise ExternsFixity @@ -104,7 +104,7 @@ data ExternsTypeFixity = ExternsTypeFixity , efTypeOperator :: OpName 'TypeOpName -- | The value the operator is an alias for , efTypeAlias :: Qualified (ProperName 'TypeName) - } deriving (Show, Generic, NFData) + } deriving (Eq, Show, Generic, NFData) instance Serialise ExternsTypeFixity @@ -157,7 +157,7 @@ data ExternsDeclaration = , edInstanceNameSource :: NameSource , edInstanceSourceSpan :: SourceSpan } - deriving (Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData) instance Serialise ExternsDeclaration diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 5f88b079c3..2650cba284 100644 --- 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 index 5228dc86e6..8d0212e456 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -4,6 +4,8 @@ module Language.PureScript.Make rebuildModule , rebuildModule' , make + , make' + , makeImp , inferForeignModules , module Monad , module Actions @@ -27,7 +29,7 @@ import Data.Function (on) import Data.Foldable (fold, for_) import Data.List (foldl', sortOn) import Data.List.NonEmpty qualified as NEL -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T @@ -37,16 +39,17 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Convert qualified as Docs import Language.PureScript.Environment (initEnvironment) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) import Language.PureScript.Linter (Name(..), lint, lintImports) import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) -import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName) +import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName) import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult) import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad @@ -56,7 +59,6 @@ import System.FilePath (replaceExtension) -- | Rebuild a single module. -- --- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -133,23 +135,50 @@ 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 --- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. +-- | 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. +-- 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. make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] -make ma@MakeActions{..} ms = do +make ma ms = makeImp ma ms False + +-- | 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) + => MakeActions m + -> [CST.PartialResult Module] + -> m [ExternsFile] +make' ma ms = makeImp ma ms True + +makeImp :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [CST.PartialResult Module] + -> Bool + -> m [ExternsFile] +makeImp ma@MakeActions{..} ms collectAll = do checkModuleNames cacheDb <- readCacheDb (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms - (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) + (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) collectAll -- Limit concurrent module builds to the number of capabilities as -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. @@ -160,16 +189,19 @@ make ma@MakeActions{..} ms = do let concurrency = max 1 capabilities lock <- C.newQSem concurrency + 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 lock buildPlan moduleName totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) - (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) + (deps `inOrderOf` sortedModuleNames) -- Prevent hanging on other modules when there is an internal error -- (the exception is thrown, but other threads waiting on MVars are released) @@ -179,7 +211,7 @@ make ma@MakeActions{..} ms = do (failures, successes) <- let splitResults = \case - BuildJobSucceeded _ exts -> + BuildJobSucceeded _ exts _ -> Right exts BuildJobFailed errs -> Left errs @@ -195,7 +227,6 @@ make ma@MakeActions{..} ms = do -- If generating docs, also generate them for the Prim modules outputPrimDocs - -- All threads have completed, rethrow any caught errors. let errors = M.elems failures unless (null errors) $ throwError (mconcat errors) @@ -203,10 +234,14 @@ make ma@MakeActions{..} ms = do -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. - let lookupResult mn = - fromMaybe (internalError "make: module not found in results") + let lookupResult mn@(ModuleName name) = + fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name) $ M.lookup mn successes - return (map (lookupResult . getModuleName . CST.resPartial) sorted) + + if collectAll then + pure $ map lookupResult sortedModuleNames + else + pure $ mapMaybe (flip M.lookup successes) sortedModuleNames where checkModuleNames :: m () @@ -251,7 +286,32 @@ make ma@MakeActions{..} ms = do mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps case mexterns of - Just (_, externs) -> do + 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 + -- if one of the diffs is Nothing means we can not check and need to rebuild + --, Just False <- checkDiffs m <$> traverse snd depsDiffExterns = do + , Just False <- checkDiffs m <$> depsDiffs = do + -- We should update modification times to mark existing + -- 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)) + else + pure Nothing + | otherwise = pure Nothing + -- We need to ensure that all dependencies have been included in Env C.modifyMVar_ (bpEnv buildPlan) $ \env -> do let @@ -265,19 +325,25 @@ make ma@MakeActions{..} ms = do idx <- C.takeMVar (bpIndex buildPlan) C.putMVar (bpIndex buildPlan) (idx + 1) - -- Bracket all of the per-module work behind the semaphore, including - -- forcing the result. This is done to limit concurrency and keep - -- memory usage down; see comments above. - (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do - -- Eventlog markers for profiling; see debug/eventlog.js - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" - -- Force the externs and warnings to avoid retaining excess module - -- data after the module is finished compiling. - extsAndWarnings <- evaluate . force <=< listen $ do - rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" - return extsAndWarnings - return $ BuildJobSucceeded (pwarnings' <> warnings) exts + (exts, warnings, diff) <- do + let doBuild = do + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + return extsAndWarnings + let diff = diffExterns exts <$> (snd <$> prevResult) <*> depsDiffs + pure (exts, warnings, diff) + maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure + return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff + Nothing -> return BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f138327c8d..07d2e1fc78 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -13,7 +13,7 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Monad (unless, when) +import Control.Monad (guard, unless, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (asks) @@ -46,8 +46,8 @@ import Language.PureScript.Docs.Prim qualified as Docs.Prim import Language.PureScript.Docs.Types qualified as Docs import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') import Language.PureScript.Externs (ExternsFile, externsFileName) -import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile) -import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache) +import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile) +import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVersion, fromCacheDbVersioned, normaliseForCache, toCacheDbVersioned) import Language.PureScript.Names (Ident(..), ModuleName, runModuleName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.Pretty.Common (SMap(..)) @@ -71,16 +71,26 @@ data RebuildPolicy data ProgressMessage = CompilingModule ModuleName (Maybe (Int, Int)) -- ^ Compilation started for the specified module + | SkippingModule ModuleName (Maybe (Int, Int)) deriving (Show, Eq, Ord) -- | Render a progress message renderProgressMessage :: T.Text -> ProgressMessage -> T.Text -renderProgressMessage infx (CompilingModule mn mi) = - T.concat - [ renderProgressIndex mi - , infx - , runModuleName mn - ] +renderProgressMessage infx msg = case msg of + CompilingModule mn mi -> + T.concat + [ renderProgressIndex mi + , "Compiling " + , infx + , runModuleName mn + ] + SkippingModule mn mi -> + T.concat + [renderProgressIndex mi + , "Skipping " + , infx + , runModuleName mn + ] where renderProgressIndex :: Maybe (Int, Int) -> T.Text renderProgressIndex = maybe "" $ \(start, end) -> @@ -109,6 +119,9 @@ data MakeActions m = MakeActions -- externs file, or if any of the requested codegen targets were not produced -- the last time this module was compiled, this function must return Nothing; -- this indicates that the module will have to be recompiled. + , updateOutputTimestamp :: ModuleName -> m Bool + -- ^ Updates the modification time of existing output files to mark them as + -- actual. , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. @@ -141,8 +154,14 @@ readCacheDb' => FilePath -- ^ The path to the output directory -> m CacheDb -readCacheDb' outputDir = - fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) +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 + guard $ cacheDbIsCurrentVersion db + pure $ fromCacheDbVersioned db writeCacheDb' :: (MonadIO m, MonadError MultipleErrors m) @@ -151,7 +170,7 @@ writeCacheDb' -> CacheDb -- ^ The CacheDb to be written -> m () -writeCacheDb' = writeJSONFile . cacheDbFile +writeCacheDb' = (. toCacheDbVersioned) . writeJSONFile . cacheDbFile writePackageJson' :: (MonadIO m, MonadError MultipleErrors m) @@ -174,7 +193,18 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs + MakeActions + getInputTimestampsAndHashes + getOutputTimestamp + updateOutputTimestamp + readExterns + codegen + ffiCodegen + progress + readCacheDb + writeCacheDb + writePackageJson + outputPrimDocs where getInputTimestampsAndHashes @@ -234,6 +264,17 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = then Just externsTimestamp else Nothing + updateOutputTimestamp :: ModuleName -> Make Bool + updateOutputTimestamp mn = do + curTime <- getCurrentTime + ok <- setTimestamp (outputFilename mn externsFileName) curTime + -- then update 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 + pure $ and (ok : results) + readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do let path = outputDir T.unpack (runModuleName mn) externsFileName @@ -314,7 +355,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling " + progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "" readCacheDb :: Make CacheDb readCacheDb = readCacheDb' outputDir diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 3eba2359a3..38554fcec0 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,9 +1,9 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) - , buildJobSuccess , construct , getResult + , getPrevResult , collectResults , markComplete , needsRebuild @@ -11,15 +11,16 @@ module Language.PureScript.Make.BuildPlan import Prelude -import Control.Concurrent.Async.Lifted as A -import Control.Concurrent.Lifted as C +import Control.Concurrent.Async.Lifted qualified as A +import Control.Concurrent.Lifted qualified as C import Control.Monad.Base (liftBase) -import Control.Monad (foldM) +import Control.Monad (foldM, guard) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Foldable (foldl') import Data.Map qualified as M -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, catMaybes) +import Data.Set qualified as S +import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Language.PureScript.AST (Module, getModuleName) import Language.PureScript.Crash (internalError) @@ -28,6 +29,7 @@ import Language.PureScript.Errors (MultipleErrors(..)) import Language.PureScript.Externs (ExternsFile) import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged) +import Language.PureScript.Make.ExternsDiff (ExternsDiff, emptyDiff) import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) @@ -36,14 +38,14 @@ import System.Directory (getCurrentDirectory) -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt + , bpPreviousBuilt :: M.Map ModuleName (Bool, Prebuilt) , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int } data Prebuilt = Prebuilt - { pbModificationTime :: UTCTime - , pbExternsFile :: ExternsFile + { pbExternsFile :: ExternsFile } newtype BuildJob = BuildJob @@ -52,33 +54,43 @@ newtype BuildJob = BuildJob } data BuildJobResult - = BuildJobSucceeded !MultipleErrors !ExternsFile - -- ^ Succeeded, with warnings and externs + = BuildJobSucceeded !MultipleErrors !ExternsFile (Maybe ExternsDiff) + -- ^ Succeeded, with warnings and externs, also holds externs diff with + -- previous build result if any (lazily evaluated). -- | BuildJobFailed !MultipleErrors - -- ^ Failed, with errors + -- ^ Failed, with errors. | BuildJobSkipped - -- ^ The build job was not run, because an upstream build job failed + -- ^ The build job was not run, because an upstream build job failed. -buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) -buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) +type SuccessResult = (MultipleErrors, (ExternsFile, Maybe ExternsDiff)) + +buildJobSuccess :: BuildJobResult -> Maybe SuccessResult +buildJobSuccess (BuildJobSucceeded warnings externs diff) = Just (warnings, (externs, diff)) buildJobSuccess _ = 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 + { rsModuleName :: ModuleName + , rsRebuildNever :: Bool + , rsNewCacheInfo :: 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. + , rsPrebuilt :: Maybe UTCTime + -- ^ Prebuilt timestamp (compilation time) for this module. + , rsUpToDate :: Bool + -- ^ Whether or not module (timestamp or content) changed since previous + -- compilation (checked against provided cache-db info). } +-- | Construct common error message indicating a bug in the internal logic +barrierError :: T.Text -> a +barrierError infx = internalError $ "make: " <> T.unpack infx <> " no barrier" + -- | 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 @@ -88,8 +100,9 @@ markComplete -> BuildJobResult -> m () markComplete buildPlan moduleName result = do - let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) - putMVar rVar result + let BuildJob rVar = + fromMaybe (barrierError "markComplete") $ M.lookup moduleName (bpBuildJobs buildPlan) + C.putMVar rVar result -- | Whether or not the module with the given ModuleName needs to be rebuilt needsRebuild :: BuildPlan -> ModuleName -> Bool @@ -103,8 +116,10 @@ collectResults => BuildPlan -> m (M.Map ModuleName BuildJobResult) collectResults buildPlan = do - let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) - barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan + let mapExts exts = BuildJobSucceeded (MultipleErrors []) exts Nothing + let prebuiltResults = + M.map (mapExts . pbExternsFile) (bpPrebuilt buildPlan) + barrierResults <- traverse (C.readMVar . bjResult) $ bpBuildJobs buildPlan pure (M.union prebuiltResults barrierResults) -- | Gets the the build result for a given module name independent of whether it @@ -113,14 +128,23 @@ getResult :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> m (Maybe (MultipleErrors, ExternsFile)) + -> m (Maybe SuccessResult) getResult buildPlan moduleName = - case M.lookup moduleName (bpPrebuilt buildPlan) of - Just es -> - pure (Just (MultipleErrors [], pbExternsFile es)) + -- may bring back first lookup for bpPrebuilt + case M.lookup moduleName (bpBuildJobs buildPlan) of + Just bj -> + buildJobSuccess <$> C.readMVar (bjResult bj) Nothing -> do - r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) - pure $ buildJobSuccess r + let exts = pbExternsFile + $ fromMaybe (barrierError "getResult") + $ M.lookup moduleName (bpPrebuilt buildPlan) + pure (Just (MultipleErrors [], (exts, Just $ emptyDiff moduleName ))) + +-- | Gets preloaded previous built result for modules that are going to be built. This +-- will be used to skip compilation if dep's externs have not changed. +getPrevResult :: BuildPlan -> ModuleName -> Maybe (Bool, ExternsFile) +getPrevResult buildPlan moduleName = + fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) -- | Constructs a BuildPlan for the given module graph. -- @@ -131,26 +155,75 @@ construct => 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) = do +construct MakeActions{..} cacheDb (sorted, graph) preloadAll = 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 + + -- Split modules into those that have to be rebuilt and those that have a valid + -- prebuilt input. The Bool value in rebuildMap means if we may skip the + -- compilation (if externs of dependencies have not changed). If it is False we + -- should re-compile the module due to the following: the module's source have + -- changed or some of dependencies were compiled later than the module. + let (rebuildMap, prebuiltMap) = splitModules rebuildStatuses + + let toBeRebuilt = M.keys rebuildMap + + -- Set of all dependencies of modules to be rebuilt. + let allBuildDeps = S.unions (S.fromList . moduleDeps <$> toBeRebuilt) + 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 + + -- We will need previously built results for modules to be build + -- to skip rebuilding if deps have not changed. + let toLoadPrev = + M.mapMaybeWithKey + ( \mn prev -> do + -- We load previous build result for all up-to-date modules, and + -- also for changed modules that have dependants. + upToDate <- fst <$> prev + guard (upToDate || inBuildDeps mn) + prev + ) + rebuildMap + + (prebuiltLoad, prevLoad) <- + A.concurrently + (A.mapConcurrently id $ M.mapWithKey loadPrebuilt toLoadPrebuilt) + (A.mapConcurrently id $ M.mapWithKey + (\mn (up, ts) -> fmap (up,) <$> loadPrebuilt mn ts) toLoadPrev) + + 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. + let failedLoads = M.keys $ M.filter isNothing prebuiltLoad + buildJobs <- foldM makeBuildJob M.empty (toBeRebuilt <> failedLoads) + env <- C.newMVar primEnv idx <- C.newMVar 1 pure - ( BuildPlan prebuilt buildJobs env idx + ( BuildPlan prebuilt previous buildJobs env idx , let update = flip $ \s -> - M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + M.alter (const (rsNewCacheInfo s)) (rsModuleName s) in foldl' update cacheDb rebuildStatuses ) where + -- Timestamp here is just to ensure that we will try to load modules that + -- have previous built results available. + loadPrebuilt :: ModuleName -> UTCTime -> m (Maybe Prebuilt) + loadPrebuilt = const . fmap (fmap Prebuilt . snd) . readExterns + makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) @@ -160,56 +233,59 @@ construct MakeActions{..} cacheDb (sorted, graph) = do inputInfo <- getInputTimestampsAndHashes moduleName case inputInfo of Left RebuildNever -> do - prebuilt <- findExistingExtern moduleName + timestamp <- getOutputTimestamp moduleName pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = True - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = True + , rsPrebuilt = timestamp + , rsUpToDate = True + , rsNewCacheInfo = Nothing }) Left RebuildAlways -> do pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = Nothing - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrebuilt = Nothing + , rsUpToDate = False + , rsNewCacheInfo = Nothing }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo - prebuilt <- - if isUpToDate - then findExistingExtern moduleName - else pure Nothing + timestamp <- getOutputTimestamp moduleName pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Just newCacheInfo + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrebuilt = timestamp + , rsUpToDate = isUpToDate + , rsNewCacheInfo = Just newCacheInfo }) - findExistingExtern :: ModuleName -> m (Maybe Prebuilt) - findExistingExtern moduleName = runMaybeT $ do - timestamp <- MaybeT $ getOutputTimestamp moduleName - externs <- MaybeT $ snd <$> readExterns moduleName - pure (Prebuilt timestamp externs) - - collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt - collectPrebuiltModules prev (moduleName, rebuildNever, pb) - | rebuildNever = M.insert moduleName pb prev - | otherwise = do - let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) - case traverse (fmap pbModificationTime . flip M.lookup prev) deps of - Nothing -> - -- If we end up here, one of the dependencies didn't exist in the - -- prebuilt map and so we know a dependency needs to be rebuilt, which - -- means we need to be rebuilt in turn. - prev - Just modTimes -> - case maximumMaybe modTimes of - Just depModTime | pbModificationTime pb < depModTime -> - prev - _ -> M.insert moduleName pb prev + moduleDeps = fromMaybe graphError . flip lookup graph + where + graphError = internalError "make: module not found in dependency graph." + + splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (Bool, UTCTime)), M.Map ModuleName UTCTime) + splitModules = foldl' collectByStatus (M.empty, M.empty) + + collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) + | Nothing <- mbPb = (M.insert mn Nothing build, prev) + | Just pb <- mbPb, not upToDate = toRebuild (False, pb) + | Just pb <- mbPb, rebuildNever = toPrebuilt pb + | Just pb <- mbPb = do + let deps = moduleDeps mn + let modTimes = map (flip M.lookup prev) deps + + case maximumMaybe (catMaybes modTimes) of + -- Check if any of deps where build later. This means we should + -- recompile even if the source is up-to-date. + Just depModTime | pb < depModTime -> toRebuild (False, pb) + -- If one of the deps is not in the prebuilt, we should rebuild. + _ | any isNothing modTimes -> toRebuild (upToDate, pb) + _ -> toPrebuilt pb + where + toRebuild v = (M.insert mn (Just v) build, prev) + toPrebuilt v = (build, M.insert mn v prev) maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 092544fa73..f703b18789 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -6,6 +6,9 @@ module Language.PureScript.Make.Cache , checkChanged , removeModules , normaliseForCache + , cacheDbIsCurrentVersion + , toCacheDbVersioned + , fromCacheDbVersioned ) where import Prelude @@ -23,14 +26,19 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Monoid (All(..)) import Data.Set (Set) -import Data.Text (Text) +import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) import System.FilePath qualified as FilePath +import Paths_purescript as Paths + import Language.PureScript.Names (ModuleName) +import Data.Version (showVersion) +import Data.Aeson ((.=)) +import Data.Aeson.Types ((.:)) digestToHex :: Digest a -> Text digestToHex = decodeUtf8 . convertToBase Base16 @@ -63,6 +71,35 @@ 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 .: "modules" + +instance Aeson.ToJSON CacheDbVersioned where + toJSON CacheDbVersioned{..} = + Aeson.object + [ "version" .= cdbVersion + , "modules" .= cdbModules + ] + +cacheDbIsCurrentVersion :: CacheDbVersioned -> Bool +cacheDbIsCurrentVersion ef = + unpack (cdbVersion ef) == showVersion Paths.version + +toCacheDbVersioned :: CacheDb -> CacheDbVersioned +toCacheDbVersioned = + CacheDbVersioned (pack $ showVersion Paths.version) + +fromCacheDbVersioned :: CacheDbVersioned -> CacheDb +fromCacheDbVersioned = + cdbModules + -- | A CacheInfo contains all of the information we need to store about a -- particular module in the cache database. newtype CacheInfo = CacheInfo diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs new file mode 100644 index 0000000000..25dd6f8b15 --- /dev/null +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -0,0 +1,440 @@ +module Language.PureScript.Make.ExternsDiff + ( ExternsDiff + , emptyDiff + , diffExterns + , checkDiffs + ) where + +import Protolude hiding (check, moduleName, trace) + +import Data.Graph as G (graphFromEdges, reachable) +import Data.List qualified as L +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T + +import Language.PureScript.AST qualified as P +import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) +import Language.PureScript.Constants.Prim (primModules) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.Names (ModuleName) +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P + +type RefStatus = Bool + +data ExternsDiff = ExternsDiff + {edModuleName :: ModuleName, edRefs :: M.Map Ref RefStatus} + deriving (Show) + +-- | Empty diff means no effective difference between externs. +emptyDiff :: P.ModuleName -> ExternsDiff +emptyDiff mn = ExternsDiff mn mempty + +isRefRemoved :: RefStatus -> Bool +isRefRemoved = not + +-- Refs structure appropriate for storing and checking externs diffs. +data Ref + = TypeClassRef (P.ProperName 'P.ClassName) + | TypeOpRef (P.OpName 'P.TypeOpName) + | TypeRef (P.ProperName 'P.TypeName) + | -- we use separate ref for a data constructor and keep here origin type as well + ConstructorRef (P.ProperName 'P.TypeName) (P.ProperName 'P.ConstructorName) + | ValueRef P.Ident + | ValueOpRef (P.OpName 'P.ValueOpName) + | -- instance ref points to the class and types defined in the same module + -- TypeInstanceRef P.Ident (Maybe (P.ProperName 'P.ClassName)) [P.ProperName 'P.TypeName] + TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] + deriving (Show, Eq, Ord) + +diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff +diffExterns newExts oldExts depsDiffs = + ExternsDiff modName $ + addStatus (changedRefs <> affectedReExported <> allAffectedLocalRefs) + where + modName = P.efModuleName newExts + -- Marks if ref was removed + addStatus = M.fromSet (flip S.notMember removedSet) + + depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) + + -- To get changed reexported refs, we take those which were removed (not + -- present in new extern's exports) or changed in dependencies. + goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref + goRe _ = [] + + oldExports = concatMap goRe (P.efExports oldExts) + newReExports = concatMap goRe (P.efExports newExts) + checkRe (mn, ref) + | (mn, ref) `notElem` newReExports = True + | Just True <- elem ref <$> M.lookup mn depsDiffsMap = True + | otherwise = False + affectedReExported = S.fromList $ map snd $ filter checkRe oldExports + + getDecls = map stripDeclaration . P.efDeclarations + getTypeFixities = P.efTypeFixities + getFixities = P.efFixities + + -- Type class instances if changed (added/removed) indirectly effect back + -- the class or the types that are defined in the module, meaning if the + -- instance is added/removed we will recompile modules that use the type + -- class or (if the type class defined in another module) we have to + -- recompile modules that use types defined in this module affected by the + -- instance. + applyInstances (a, r, c, u) = + let checkType t (TypeRef t') = t' == t + checkType _ _ = False + uRefs = map fst u + go (TypeInstanceRef _ (clsMod, cls) types) + | clsRef <- TypeClassRef cls = + if clsMod == modName + then -- If the class is defined in this module we ensure that is marked as changed + maybe [] pure $ find ((==) clsRef) uRefs + else case S.member clsRef <$> M.lookup clsMod depsDiffsMap of + Just True -> + -- if the type class is in another module and it has + -- changed we don't need to care about instance types. + [] + -- Otherwise mark instance types as changed. + _ -> + foldMap (\t -> filter (checkType t) uRefs) types + go _ = mempty + affected = foldMap (S.fromList . go . fst) (a <> r <> c) + (uc, uu) = L.partition (flip S.member affected . fst) u + in (a, r, c <> uc, uu) + + declsSplit = + applyInstances $ + splitRefs (getDecls newExts) (getDecls oldExts) (externsDeclarationToRef modName) + + -- Make the context for fixity's data constructor search: place all + -- known refs in the map. + getRefsSet (a, r, c, u) = S.fromList $ map fst (a <> r <> c <> u) + fixityCtx = M.insert modName (getRefsSet declsSplit) depsDiffsMap + + -- Determine which declarations where directly changed or removed. + (_, removed, changed, unchangedRefs) = + foldl + zipTuple4 + (mempty, mempty, mempty, mempty) + [ declsSplit + , splitRefs (getFixities newExts) (getFixities oldExts) (pure . externsFixityToRef fixityCtx) + , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) + ] + + removedSet = S.fromList (map fst removed) + changedRefs = S.fromList $ map fst (removed <> changed) + + diffsMapWithLocal + | null changedRefs = depsDiffsMap + | otherwise = M.insert modName changedRefs depsDiffsMap + + -- Affected refs here are refs that depend on external or local changed refs. + -- + -- Rest local refs are refs that do not depend on external/local changed, but + -- may depend on affected local refs and need to be checked. + hasChangedDeps (mn, ref) = + Just True == (S.member ref <$> M.lookup mn diffsMapWithLocal) + (affectedLocalRefs, restLocalRefs) = + L.partition (any hasChangedDeps . snd) unchangedRefs + + -- Use graph to go though local refs and their cyclic dependencies on each other. + -- The graph includes only local refs that depend on other local refs. + toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) deps) + + vtxs = toNode <$> (map (map S.toList) restLocalRefs <> (map (const mempty) <$> affectedLocalRefs)) + (graph, fromVtx, toVtx) = G.graphFromEdges vtxs + refsGraph = do + (_, t, _) <- vtxs + let v = fromMaybe (internalError "diffExterns: vertex not found") $ toVtx t + let deps = G.reachable graph v + let toKey = (\(_, k, _) -> k) . fromVtx + pure (t, map toKey deps) + + -- Get local refs that depend on affected refs (affected refs are included + -- in the graph too). + allAffectedLocalRefs = + S.fromList $ + map fst $ + filter (any (flip elem (fst <$> affectedLocalRefs)) . snd) refsGraph + +checkDiffs :: P.Module -> [ExternsDiff] -> Bool +checkDiffs (P.Module _ _ _ decls exports) diffs + | all isEmpty diffs = False + | isNothing mbSearch = True + | null searches = False + | otherwise = checkReExports || checkUsage searches decls + where + mbSearch = makeSearches decls diffs + searches = fromMaybe S.empty mbSearch + -- Check if the module reexports any of searched refs. + checkReExports = flip (maybe False) exports $ any $ \case + P.ModuleRef _ mn -> not . null $ S.filter ((== Just mn) . fst) searches + _ -> False + +-- Goes though the module and try to find any usage of the refs. +checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool +checkUsage searches decls = foldMap findUsage decls /= mempty + where + findUsage decl = + let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty + in extr mempty decl + + toSearched = (,) <$> P.getQual <*> P.disqualify + + -- To check data constructors we remove an origin type from it. + emptyName = P.ProperName "" + stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n + stripCtorType x = x + + searches' = S.map (map stripCtorType) searches + check = (\x -> [x | x]) . flip S.member searches' . toSearched + + checkType = check . map TypeRef + checkTypeOp = check . map TypeOpRef + checkValue = check . map ValueRef + checkValueOp = check . map ValueOpRef + checkCtor = check . map (ConstructorRef emptyName) + checkClass = check . map TypeClassRef + + onTypes = P.everythingOnTypes (<>) $ \case + P.TypeConstructor _ n -> checkType n + P.TypeOp _ n -> checkTypeOp n + P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) + _ -> mempty + + foldCtor f (P.DataConstructorDeclaration _ _ vars) = + foldMap (f . snd) vars + + constraintTypes = + foldMap (\c -> P.constraintArgs c <> P.constraintKindArgs c) + + goDecl _ = \case + P.TypeDeclaration t -> onTypes (P.tydeclType t) + P.DataDeclaration _ _ _ _ ctors -> foldMap (foldCtor onTypes) ctors + P.TypeSynonymDeclaration _ _ _ t -> onTypes t + P.KindDeclaration _ _ _ t -> onTypes t + P.FixityDeclaration _ (Right (P.TypeFixity _ tn _)) -> + checkType tn + P.FixityDeclaration _ (Left (P.ValueFixity _ (P.Qualified by val) _)) -> + either (checkValue . P.Qualified by) (checkCtor . P.Qualified by) val + P.TypeClassDeclaration _ _ _ cs _ _ -> + foldMap onTypes (constraintTypes cs) + P.TypeInstanceDeclaration _ _ _ _ _ cs tc sts _ -> + foldMap onTypes (constraintTypes cs <> sts) <> checkClass tc + _ -> mempty + + isLocal scope ident = P.LocalIdent ident `S.member` scope + goExpr scope expr = case expr of + P.Var _ n + | P.isUnqualified n && isLocal scope (P.disqualify n) -> mempty + | otherwise -> checkValue n + P.Constructor _ n -> checkCtor n + P.Op _ n -> checkValueOp n + P.TypedValue _ _ t -> onTypes t + _ -> mempty + + goBinder _ binder = case binder of + P.ConstructorBinder _ n _ -> checkCtor n + P.OpBinder _ n -> checkValueOp n + _ -> mempty + +-- | Traverses imports and returns a set of refs to be searched though the +-- module. Returns Nothing if removed refs found in imports (no need to search +-- through the module). If an empty set is returned then no changes apply to the +-- module. +makeSearches :: [P.Declaration] -> [ExternsDiff] -> Maybe (Set (Maybe ModuleName, Ref)) +makeSearches decls depsDiffs = + foldM go mempty decls + where + diffsMap = M.fromList (map (liftM2 (,) edModuleName edRefs) depsDiffs) + + -- Add data constructors to refs if all are implicitly imported using (..). + getCtor n (ConstructorRef tn _) = tn == n + getCtor _ _ = False + getCtors n = M.keys . M.filterWithKey (const . getCtor n) + addCtors mn (P.TypeRef _ n Nothing) = maybe [] (getCtors n) (M.lookup mn diffsMap) + addCtors _ _ = [] + getRefs = (toRefs <>) . addCtors + + go s (P.ImportDeclaration _ mn dt qual) + -- We return Nothing if we encounter removed refs in imports. + | Just diffs <- M.lookup mn diffsMap + , removed <- M.keysSet $ M.filter isRefRemoved diffs = + fmap ((s <>) . S.map (qual,) . M.keysSet) $ case dt of + P.Explicit dRefs + | any (flip S.member removed) refs -> Nothing + | otherwise -> + -- search only refs encountered in the import. + Just $ M.filterWithKey (const . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + P.Hiding dRefs + | any (flip S.member removed) refs -> Nothing + | otherwise -> + -- search only refs not encountered in the import. + Just $ M.filterWithKey (const . not . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + -- search all changed refs + P.Implicit -> Just diffs + go s _ = Just s + +toRefs :: P.DeclarationRef -> [Ref] +toRefs = \case + P.TypeClassRef _ n -> [TypeClassRef n] + P.TypeOpRef _ n -> [TypeOpRef n] + P.TypeRef _ n c -> [TypeRef n] <> (ConstructorRef n <$> fromMaybe [] c) + P.ValueRef _ i -> [ValueRef i] + P.ValueOpRef _ n -> [ValueOpRef n] + _ -> [] + +isEmpty :: ExternsDiff -> Bool +isEmpty (ExternsDiff _ refs) + | null refs = True + | otherwise = False + +type Tuple4 m a = (m a, m a, m a, m a) + +zipTuple4 :: Monoid (m a) => Tuple4 m a -> Tuple4 m a -> Tuple4 m a +zipTuple4 (f1, s1, t1, fo1) (f2, s2, t2, fo2) = + (f1 <> f2, s1 <> s2, t1 <> t2, fo1 <> fo2) + +-- | Returns refs as a tuple of four (added, removed, changed, unchanged). +splitRefs :: Ord r => Eq a => [a] -> [a] -> (a -> Maybe r) -> Tuple4 [] r +splitRefs new old toRef = + M.foldrWithKey go (added, [], [], []) oldMap + where + toMap = M.fromList . mapMaybe (((<$>) . flip (,)) <*> toRef) + newMap = toMap new + oldMap = toMap old + added = M.keys $ M.difference newMap oldMap + go ref decl (a, r, c, u) = case M.lookup ref newMap of + Nothing -> (a, r <> [ref], c, u) + Just newDecl + | decl /= newDecl -> (a, r, c <> [ref], u) + | otherwise -> (a, r, c, u <> [ref]) + +-- | Traverses the type and finds all the refs within. +typeDeps :: P.Type a -> S.Set (ModuleName, Ref) +typeDeps = P.everythingOnTypes (<>) $ + \case + P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn) + | isPrimModule mn -> mempty + | otherwise -> S.singleton (mn, TypeRef tn) + P.TypeConstructor _ _ -> + internalError "typeDeps: type is not qualified" + P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn) + | isPrimModule mn -> mempty + | otherwise -> S.singleton (mn, TypeOpRef tn) + P.ConstrainedType _ c _ -> + S.singleton (map TypeClassRef (qualified $ P.constraintClass c)) + P.TypeOp _ _ -> + internalError "typeDeps: type is not qualified" + _ -> mempty + +qualified :: P.Qualified b -> (ModuleName, b) +qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) +qualified _ = internalError "ExternsDiff: type is not qualified" + +type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) + +-- | To get fixity's data constructor dependency we should provide it with the +-- context (that contains all known refs) to search in. +externsFixityToRef :: Map ModuleName (Set Ref) -> P.ExternsFixity -> RefWithDeps +externsFixityToRef refs (P.ExternsFixity _ _ n alias) = + (ValueOpRef n, maybe mempty S.singleton $ getDep (qualified alias)) + where + getDep (mn, Left i) = Just (mn, ValueRef i) + getDep (mn, Right p) = + (mn,) <$> (M.lookup mn refs >>= S.lookupMin . S.filter (goRef p)) + goRef c (ConstructorRef _ c') = c' == c + goRef _ _ = False + +externsTypeFixityToRef :: P.ExternsTypeFixity -> RefWithDeps +externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = + ( TypeOpRef n + , S.singleton (map TypeRef (qualified alias)) + ) + +externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps +externsDeclarationToRef moduleName = \case + P.EDType n t tk + | isDictName n -> Nothing + | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) + -- + P.EDTypeSynonym n args t -> + Just (TypeRef n, typeDeps t <> foldArgs args) + -- + P.EDDataConstructor n _ tn t _ + | isDictName n -> Nothing + | otherwise -> + Just + ( ConstructorRef tn n + , -- Add the type as a dependency: if the type has changed (e.g. + -- constructors removed/added) it should affect all the constructors + -- in the type. + S.insert (moduleName, TypeRef tn) (typeDeps t) + ) + -- + P.EDValue n t -> + Just (ValueRef n, typeDeps t) + -- + P.EDClass n args members constraints _ _ -> + Just + ( TypeClassRef n + , foldArgs args <> constraintsDeps constraints <> foldMap (typeDeps . snd) members + ) + -- + P.EDInstance cn n args kinds types constraints _ _ _ _ -> + Just + ( TypeInstanceRef n (qualified cn) (mapMaybe myType types) + , maybe mempty constraintsDeps constraints <> instanceArgsDeps args <> foldMap typeDeps kinds + ) + where + goDataTypeArg (_, st, _) = maybe mempty typeDeps st + typeKindDeps (P.DataType _ args _) = foldMap goDataTypeArg args + typeKindDeps _ = mempty + + myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn)) + | isPrimModule mn || moduleName /= mn = Nothing + | otherwise = Just tn + myType _ = Nothing + + foldArgs = foldMap typeDeps . mapMaybe snd + instanceArgsDeps = foldMap (typeDeps . snd) + constraintsDeps = + foldMap + ( \(P.Constraint _ cls kArgs args _) -> + S.singleton (TypeClassRef <$> qualified cls) + <> foldMap typeDeps kArgs + <> foldMap typeDeps args + ) + +-- | Removes excessive info from declarations before comparing. +stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration +stripDeclaration = \case + P.EDType n t (P.DataType dt args ctors) -> + -- Remove data constructors types, we don't need them, we only need to know + -- if the list of ctors has changed. + P.EDType n t (P.DataType dt args (map (map (const [])) ctors)) + -- + P.EDInstance cn n fa ks ts cs ch chi ns ss -> + P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss + -- + decl -> decl + where + emptySP = P.SourcePos 0 0 + -- emptySS = SourceSpan "" emptySP emptySP + stripChain (ChainId (n, _)) = ChainId (n, emptySP) + +isPrimModule :: ModuleName -> Bool +isPrimModule = flip S.member (S.fromList primModules) + +-- | Check if type name is a type class dictionary name. +isDictName :: P.ProperName a -> Bool +isDictName = + T.isInfixOf "$" . P.runProperName diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 8c86144e9a..ed553cf28f 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -5,6 +5,8 @@ module Language.PureScript.Make.Monad , makeIO , getTimestamp , getTimestampMaybe + , getCurrentTime + , setTimestamp , readTextFile , readJSONFile , readJSONFileIO @@ -35,14 +37,16 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson qualified as Aeson import Data.ByteString qualified as B +import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) +import Data.Time.Clock qualified as Time import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), singleError) import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options (Options) -import System.Directory (createDirectoryIfMissing, getModificationTime) +import System.Directory (createDirectoryIfMissing, getModificationTime, setModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) @@ -85,6 +89,18 @@ getTimestampMaybe :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ( getTimestampMaybe path = makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path +-- | Get current system time. +getCurrentTime :: (MonadIO m) => m UTCTime +getCurrentTime = + liftIO Time.getCurrentTime + +-- | Set a file's modification time in the 'Make' monad, returning False if +-- the file does not exist. +setTimestamp :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> UTCTime -> m Bool +setTimestamp path time = + makeIO ("set a timestamp for file: " <> Text.pack path) $ (fmap isJust . catchDoesNotExist) $ setModificationTime path time + + -- | Read a text file strictly in the 'Make' monad, capturing any errors using -- the 'MonadError' instance. readTextFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m Text diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 610e8465c8..9865ad7a0f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -3,13 +3,13 @@ module TestMake where -import Prelude +import Prelude hiding (writeFile) import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad (guard, void) +import Control.Monad (guard, void, forM_) import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) @@ -36,141 +36,483 @@ timestampB = utcMidnightOnDate 2019 1 2 timestampC = utcMidnightOnDate 2019 1 3 timestampD = utcMidnightOnDate 2019 1 4 +oneSecond :: Int +oneSecond = 10 ^ (6::Int) -- microseconds. + +someMs :: Int +someMs = 10 ^ (3::Int) -- microseconds. + spec :: Spec spec = do let sourcesDir = "tests/purs/make" let moduleNames = Set.fromList . map P.moduleNameFromString + let modulePath name = sourcesDir (T.unpack name <> ".purs") + let foreignJsPath name = sourcesDir (T.unpack name <> ".js") + + -- Test helpers. + let testN fn name modules compile2 res = + fn name $ do + let names = map (\(mn, _, _) -> mn) modules + let paths = map modulePath names + let timestamp = utcMidnightOnDate 2019 1 + + forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do + writeFile (modulePath mn) (timestamp idx) content + + compile paths `shouldReturn` moduleNames names + + forM_ (zip [length modules..] modules) $ \(idx, (mn, _, mbContent)) -> do + maybe (pure ()) (writeFile (modulePath mn) (timestamp idx)) mbContent + + compile2 paths `shouldReturn` moduleNames res + + let test2 fn name (mAContent1, mAContent2, mBContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + ] compile res + + let testWithFailure2 fn name (mAContent1, mAContent2, mBContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + ] compileAllowingFailures res + + let test3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + , ("C", mCContent, Nothing) + ] compile res + + let testWithFailure3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + , ("C", mCContent, Nothing) + ] compileAllowingFailures res + + let recompile2 fn name ms = + test2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + + let recompileWithFailure2 fn name ms = + testWithFailure2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + + let noRecompile2 fn name ms = + test2 fn ("does not recompile when upstream not changed effectively: " <> name) ms ["A"] + before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do it "does not recompile if there are no changes" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" - writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - compile [modulePath] `shouldReturn` moduleNames [] + writeFile mPath timestampA "module Module where\nfoo = 0\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + compile [mPath] `shouldReturn` moduleNames [] it "recompiles if files have changed" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" - writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB "module Module where\nfoo = 1\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA "module Module where\nfoo = 0\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB "module Module where\nfoo = 1\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] it "does not recompile if hashes have not changed" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = modulePath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent - compile [modulePath] `shouldReturn` moduleNames [] + writeFile mPath timestampA moduleContent + compile [mPath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent + compile [mPath] `shouldReturn` moduleNames [] it "recompiles if the file path for a module has changed" $ do let modulePath1 = sourcesDir "Module1.purs" modulePath2 = sourcesDir "Module2.purs" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath1 timestampA moduleContent - writeFileWithTimestamp modulePath2 timestampA moduleContent + writeFile modulePath1 timestampA moduleContent + writeFile modulePath2 timestampA moduleContent compile [modulePath1] `shouldReturn` moduleNames ["Module"] compile [modulePath2] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was added" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" + let mPath = modulePath "Module" + mFFIPath = foreignJsPath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA moduleContent + compile [mPath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mFFIPath timestampB "export var bar = 1;\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was removed" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" + let mPath = modulePath "Module" + mFFIPath = foreignJsPath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - - removeFile moduleFFIPath - compile [modulePath] `shouldReturn` moduleNames ["Module"] - - it "recompiles downstream modules when a module is rebuilt" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent1 - writeFileWithTimestamp moduleBPath timestampB moduleBContent - compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] - - writeFileWithTimestamp moduleAPath timestampC moduleAContent2 - compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] - - it "only recompiles downstream modules when a module is rebuilt" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleCPath = sourcesDir "C.purs" - modulePaths = [moduleAPath, moduleBPath, moduleCPath] - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - moduleCContent = "module C where\nbaz = 3\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent1 - writeFileWithTimestamp moduleBPath timestampB moduleBContent - writeFileWithTimestamp moduleCPath timestampC moduleCContent + writeFile mPath timestampA moduleContent + writeFile mFFIPath timestampB "export var bar = 1;\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + + removeFile mFFIPath + compile [mPath] `shouldReturn` moduleNames ["Module"] + + it "recompiles downstream modules when a module is rebuilt and externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = '1'\n" + mBContent = "module B where\nimport A as A\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + it "only recompiles downstream modules when a module is rebuilt end externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = '1'\n" -- change externs here + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - writeFileWithTimestamp moduleAPath timestampD moduleAContent2 + writeFile mAPath timestampD mAContent2 compile modulePaths `shouldReturn` moduleNames ["A", "B"] + it "recompiles downstream after a module has been rebuilt separately" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + mPaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = 1\n" + mBContent = "module B where\nimport A\nbar = 1\nbaz = foo\n" + mCContent = "module C where\nimport B\nqux = bar" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampB mCContent + + compile mPaths `shouldReturn` moduleNames ["A", "B", "C"] + + threadDelay oneSecond + + writeFile mAPath timestampC mAContent2 + compile [mAPath] `shouldReturn` moduleNames ["A"] + + compile mPaths `shouldReturn` moduleNames ["B", "C"] + + -- Reexports. + test3 it "recompiles downstream modules when a reexported module changed" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A (foo) as E\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["A", "B", "C"] + + -- test3 fit "reexported module changed" + -- ( "module A where\ndata ABC = A Int | B\n" + -- , "module A where\ndata ABC = A String | B\n" -- change externs here + -- , "module B (module E) where\nimport A (ABC(..)) as E\n" + -- , "module C where\nimport B as B\nbaz = B.A\n" + -- ) + -- ["A", "B", "C"] + + -- Imports. + testWithFailure2 it "recompiles downstream when removed reference found in imports" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo2 = 1\n" + , "module B where\nimport A (foo)\nbar = 1" + ) + ["A", "B"] + + test2 it "does not recompiles downstream when removed reference is not used" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo2 = 1\n" + , "module B where\nimport A\nbar = 1" + ) + ["A"] + + -- Usage in the code + -- signature + + -- inlined + testWithFailure2 it "recompiles downstream when found changed inlined type" + ( "module A where\ntype T = Int\n" + , "module A where\ntype T = String\n" + , "module B where\nimport A\nx = (1 :: T)" + ) + ["A", "B"] + + -- Transitive change. + test3 it "recompiles downstream due to transitive change" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\n" + , "module B where\nimport A (foo)\nbar = qux\nqux = foo" + , "module C where\nimport B (bar)\nbaz = bar\n" + ) + ["A", "B", "C"] + + test3 it "do not recompile downstream if no transitive change" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\n" + , "module B where\nimport A (foo)\nbar = 1\nqux = foo" + , "module C where\nimport B (bar)\nbaz = bar\n" + ) + ["A", "B"] + + noRecompile2 it "unused type changed" + ( "module A where\ntype SynA = Int\ntype SynA2 = Int" + , "module A where\ntype SynA = String\ntype SynA2 = Int" + , "module B where\nimport A as A\ntype SynB = A.SynA2" + ) + + -- Type synonyms. + recompile2 it "type synonym changed" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" + ) + + recompile2 it "type synonym dependency changed" + ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" + , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" + ) + + -- Data types. + recompile2 it "data type changed (parameter added)" + ( "module A where\ndata T = A Int | B Int\n" + , "module A where\ndata T a = A Int | B a\n" + , "module B where\nimport A (T)\ntype B = T" + ) + + recompile2 it "data type changed (constructor added)" + ( "module A where\ndata T = A Int | B Int\n" + , "module A where\ndata T = A Int | B Int | C Int\n" + , "module B where\nimport A (T(B))\nb = B" + ) + + recompile2 it "data type constructor dependency changed" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" + , "module B where\nimport A (AB(..))\nb = A" + ) + + noRecompile2 it "data type constructor changed, but not used" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" + -- use type and other constructor + , "module B where\nimport A (AB(..))\ntype B = AB\nb = B" + ) + + + -- Value operators. + recompile2 it "value op changed" + ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" + , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" + , "module B where\nimport A\nt = 1 :+: \"1\" " + ) + + recompile2 it "value op dependency changed" + ( "module A where\ndata T a = T a String\ninfixl 2 T as :+:\n" + , "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" + , "module B where\nimport A\nt = 1 :+: \"1\" " + ) + + + -- Type operators. + recompile2 it "type op changed" + ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" + , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" + , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" + ) + + recompile2 it "type op dependency changed" + ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" + , "module A where\ndata T b a = T a b\ninfixl 2 type T as :+:\n" + , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" + ) + + -- Type classes. + recompile2 it "type class changed" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , T.unlines + [ "module B where" + , "import A as A" + , "fn :: forall a. A.Cls a => a -> Int" + , "fn _ = 1" + ] + ) + + recompile2 it "type class changed (member affected)" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , T.unlines + [ "module B where" + , "import A as A" + , "fn x = A.m1 x" + ] + ) + + recompile2 it "type class instance added" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" + , T.unlines + [ "module B where" + , "import A as A" + , "fn :: forall a. A.Cls a => a -> Int" + , "fn _ = 1" + ] + ) + + recompileWithFailure2 it "type class instance removed" + ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" + , "module A where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module B where" + , "import A (m1)" + , "x = m1 1" + ] + ) + + test3 it "recompiles downstream if instance added for type" + ( "module A where\nimport B\nnewtype T = T Int\n" + , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "t = T 1" + ] + ) + ["A", "C"] + + test3 it "recompiles downstream if instance added for type" + ( "module A where\nimport B\nnewtype T = T Int\n" + , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "t = T 1" + ] + ) + ["A", "C"] + + testWithFailure3 it "recompiles downstream if instance removed for type" + ( "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module A where\nimport B\nnewtype T = T Int\n" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "import B" + , "i :: Int" + , "i = m1 (T 1)" + ] + ) + ["A", "C"] + + testN it "doesn't recompile downstream if an instance added for the type and type class changed" + [ ( "A" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , Just "module A where\nclass Cls a where m1 :: a -> Int\n" + ) + , ( "B" + , "module B where\nimport A\nnewtype T = T Int\n" + , Just "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + ) + , ("C", "module C where\nimport B\ntype C = T", Nothing) + ] compile ["A", "B"] + + it "does not recompile downstream modules when a module is rebuilt but externs have not changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A (foo) where\nbar = 1\nfoo = 1\n" + mBContent = + T.unlines + [ "module B where" + , "import A (foo)" + , "import C (baz)" + , "bar = foo" + , "qux = baz" + ] + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + -- + writeFile mAPath timestampD mAContent2 + threadDelay oneSecond + compile modulePaths `shouldReturn` moduleNames ["A"] + -- compile again to check that it won't try recompile skipped module again + compile modulePaths `shouldReturn` moduleNames [] + it "does not necessarily recompile modules which were not part of the previous batch" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleCPath = sourcesDir "C.purs" - modulePaths = [moduleAPath, moduleBPath, moduleCPath] - batch1 = [moduleAPath, moduleBPath] - batch2 = [moduleAPath, moduleCPath] - moduleAContent = "module A where\nfoo = 0\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - moduleCContent = "module C where\nbaz = 3\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent - writeFileWithTimestamp moduleBPath timestampB moduleBContent - writeFileWithTimestamp moduleCPath timestampC moduleCContent + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + batch1 = [mAPath, mBPath] + batch2 = [mAPath, mCPath] + + mAContent = "module A where\nfoo = 0\n" + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] compile batch1 `shouldReturn` moduleNames [] compile batch2 `shouldReturn` moduleNames [] it "recompiles if a module fails to compile" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA moduleContent + compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] + compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] it "recompiles if docs are requested but not up to date" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } - go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10 ^ (6::Int) -- microseconds. + go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFileWithTimestamp modulePath timestampA moduleContent1 + writeFile mPath timestampA moduleContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeFile mPath timestampB moduleContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -178,30 +520,29 @@ spec = do -- recompiled. go optsWithDocs `shouldReturn` moduleNames ["Module"] - it "recompiles if corefn is requested but not up to date" $ do - let modulePath = sourcesDir "Module.purs" + it "recompiles if CoreFn is requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" moduleContent1 = "module Module where\nx :: Int\nx = 1" moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - optsCorefnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } - go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10 ^ (6::Int) -- microseconds. + optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } + go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFileWithTimestamp modulePath timestampA moduleContent1 - go optsCorefnOnly `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeFile mPath timestampA moduleContent1 + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing corefn.json is now outdated, the module should be + -- Since the existing CoreFn.json is now outdated, the module should be -- recompiled. - go optsCorefnOnly `shouldReturn` moduleNames ["Module"] + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] -- Note [Sleeping to avoid flaky tests] -- -- One of the things we want to test here is that all requested output files -- (via the --codegen CLI option) must be up to date if we are to skip -- recompiling a particular module. Since we check for outdatedness by --- comparing the timestamp of the output files (eg. corefn.json, index.js) to +-- comparing the timestamp of the output files (eg. CoreFn.json, index.js) to -- the timestamp of the externs file, this check is susceptible to flakiness -- if the timestamp resolution is sufficiently coarse. To get around this, we -- delay for one second. @@ -232,8 +573,10 @@ compileWithOptions opts input = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions modulesDir filePathMap foreigns True) - { P.progress = \(P.CompilingModule mn _) -> - liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + { P.progress = \case + P.CompilingModule mn _ -> + liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + _ -> pure () } P.make makeActions (map snd ms) @@ -264,8 +607,8 @@ compile input = compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) compileAllowingFailures input = fmap snd (compileWithResult input) -writeFileWithTimestamp :: FilePath -> UTCTime -> T.Text -> IO () -writeFileWithTimestamp path mtime contents = do +writeFile :: FilePath -> UTCTime -> T.Text -> IO () +writeFile path mtime contents = do writeUTF8FileT path contents setModificationTime path mtime diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 146093c452..94f56fc449 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -147,7 +147,7 @@ setupSupportModules = do let modules = map snd ms supportExterns <- runExceptT $ do foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules) + externs <- ExceptT . fmap fst . runTest $ P.make' (makeActions modules foreigns) (CST.pureResult <$> modules) return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) From 69f94f12d51d0cb23cc445c3ffa7d8abb6cb4705 Mon Sep 17 00:00:00 2001 From: Alex Date: Sun, 18 Jun 2023 22:07:51 +0500 Subject: [PATCH 2/8] Fix linting error. --- src/Language/PureScript/Make.hs | 1 - tests/TestMake.hs | 5 +---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8d0212e456..2292c21378 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -5,7 +5,6 @@ module Language.PureScript.Make , rebuildModule' , make , make' - , makeImp , inferForeignModules , module Monad , module Actions diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 9865ad7a0f..e08cda7314 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -1,7 +1,7 @@ -- Tests for the compiler's handling of incremental builds, i.e. the code in -- Language.PureScript.Make. -module TestMake where +module TestMake (spec) where import Prelude hiding (writeFile) @@ -39,9 +39,6 @@ timestampD = utcMidnightOnDate 2019 1 4 oneSecond :: Int oneSecond = 10 ^ (6::Int) -- microseconds. -someMs :: Int -someMs = 10 ^ (3::Int) -- microseconds. - spec :: Spec spec = do let sourcesDir = "tests/purs/make" From d4a4ad65d94641c51f7d9df961f3d3b225a25b78 Mon Sep 17 00:00:00 2001 From: Alex Date: Tue, 26 Dec 2023 12:30:40 +0500 Subject: [PATCH 3/8] Refactor externs diff and make api, fix some review sugs --- app/Command/Compile.hs | 2 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Make.hs | 92 ++++---- src/Language/PureScript/Make/Actions.hs | 7 +- src/Language/PureScript/Make/BuildPlan.hs | 54 +++-- src/Language/PureScript/Make/Cache.hs | 3 +- src/Language/PureScript/Make/ExternsDiff.hs | 219 +++++++++++++------- tests/TestUtils.hs | 4 +- 8 files changed, 231 insertions(+), 152 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..d43338580d 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -73,7 +73,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 index 2650cba284..5f88b079c3 100644 --- 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 index 2292c21378..07810192c9 100644 --- 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 @@ -15,7 +13,7 @@ import Prelude import Control.Concurrent.Lifted as C import Control.DeepSeq (force) import Control.Exception.Lifted (onException, bracket_, evaluate) -import Control.Monad (foldM, unless, when, (<=<)) +import Control.Monad (foldM, unless, void, when, (<=<)) import Control.Monad.Base (MonadBase(liftBase)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -46,12 +44,31 @@ import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModule import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) -import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult) +import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult, isUpToDate) import Language.PureScript.Make.BuildPlan qualified as BuildPlan import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad + ( Make(..), + writeTextFile, + writeJSONFile, + writeCborFileIO, + writeCborFile, + setTimestamp, + runMake, + readTextFile, + readJSONFileIO, + readJSONFile, + readExternsFile, + readCborFileIO, + readCborFile, + makeIO, + hashFile, + getTimestampMaybe, + getTimestamp, + getCurrentTime, + copyFile ) import Language.PureScript.CoreFn qualified as CF import System.Directory (doesFileExist) import System.FilePath (replaceExtension) @@ -134,9 +151,12 @@ 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. -- @@ -144,40 +164,35 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- 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) -- Limit concurrent module builds to the number of capabilities as -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. @@ -192,8 +207,6 @@ makeImp ma@MakeActions{..} ms collectAll = do 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 lock buildPlan moduleName totalModuleCount @@ -237,10 +250,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 () @@ -287,23 +301,19 @@ 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 - -- if one of the diffs is Nothing means we can not check and need to rebuild - --, Just False <- checkDiffs m <$> traverse snd depsDiffExterns = do + -- We may skip built only for up-to-date modules. + | Just (status, exts) <- prevResult + , isUpToDate status + -- Check if no dep's externs have changed. If any of the diffs + -- is Nothing means we can not check and need to rebuild. , Just False <- checkDiffs m <$> depsDiffs = do -- We should update modification times to mark existing -- 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,7 +321,7 @@ makeImp ma@MakeActions{..} ms collectAll = do pure Nothing | otherwise = pure Nothing - -- We need to ensure that all dependencies have been included in Env + -- We need to ensure that all dependencies have been included in Env. C.modifyMVar_ (bpEnv buildPlan) $ \env -> do let go :: Env -> ModuleName -> m Env diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 07d2e1fc78..6774457ac5 100644 --- 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 index 38554fcec0..8669233b0e 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,6 +1,8 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) + , Options(..) + , isUpToDate , construct , getResult , getPrevResult @@ -34,11 +36,16 @@ import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) +newtype UpToDateStatus = UpToDateStatus Bool + +isUpToDate :: UpToDateStatus -> Bool +isUpToDate (UpToDateStatus b) = b + -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt - , bpPreviousBuilt :: M.Map ModuleName (Bool, Prebuilt) + , bpPreviousBuilt :: M.Map ModuleName (UpToDateStatus, Prebuilt) , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int @@ -130,7 +137,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) @@ -142,24 +148,27 @@ getResult buildPlan moduleName = -- | Gets preloaded previous built result for modules that are going to be built. This -- will be used to skip compilation if dep's externs have not changed. -getPrevResult :: BuildPlan -> ModuleName -> Maybe (Bool, ExternsFile) +getPrevResult :: BuildPlan -> ModuleName -> Maybe (UpToDateStatus, 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,19 +186,20 @@ 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 + -- We will need previously built results for modules to be built -- to skip rebuilding if deps have not changed. let toLoadPrev = M.mapMaybeWithKey ( \mn prev -> do -- We load previous build result for all up-to-date modules, and -- also for changed modules that have dependants. - upToDate <- fst <$> prev - guard (upToDate || inBuildDeps mn) + status <- fst <$> prev + guard (isUpToDate status || inBuildDeps mn) prev ) rebuildMap @@ -203,8 +213,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 +229,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 @@ -251,13 +261,13 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory - (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo + (newCacheInfo, upToDate) <- checkChanged cacheDb moduleName cwd cacheInfo timestamp <- getOutputTimestamp moduleName pure (RebuildStatus { rsModuleName = moduleName , rsRebuildNever = False , rsPrebuilt = timestamp - , rsUpToDate = isUpToDate + , rsUpToDate = upToDate , rsNewCacheInfo = Just newCacheInfo }) @@ -265,7 +275,7 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do where graphError = internalError "make: module not found in dependency graph." - splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (Bool, UTCTime)), M.Map ModuleName UTCTime) + splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (UpToDateStatus, UTCTime)), M.Map ModuleName UTCTime) splitModules = foldl' collectByStatus (M.empty, M.empty) collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) @@ -284,7 +294,7 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do _ | any isNothing modTimes -> toRebuild (upToDate, pb) _ -> toPrebuilt pb where - toRebuild v = (M.insert mn (Just v) build, prev) + toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prev) toPrebuilt v = (build, M.insert mn v prev) maximumMaybe :: Ord a => [a] -> Maybe a diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index f703b18789..4582d2fdf7 100644 --- 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 index 25dd6f8b15..31530ccce0 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -11,8 +11,6 @@ import Data.Graph as G (graphFromEdges, reachable) import Data.List qualified as L import Data.Map qualified as M import Data.Set qualified as S -import Data.Text qualified as T - import Language.PureScript.AST qualified as P import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) import Language.PureScript.Constants.Prim (primModules) @@ -22,57 +20,70 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P - -type RefStatus = Bool - -data ExternsDiff = ExternsDiff - {edModuleName :: ModuleName, edRefs :: M.Map Ref RefStatus} - deriving (Show) - --- | Empty diff means no effective difference between externs. -emptyDiff :: P.ModuleName -> ExternsDiff -emptyDiff mn = ExternsDiff mn mempty - -isRefRemoved :: RefStatus -> Bool -isRefRemoved = not +import Language.PureScript.Environment (isDictTypeName) -- Refs structure appropriate for storing and checking externs diffs. data Ref = TypeClassRef (P.ProperName 'P.ClassName) | TypeOpRef (P.OpName 'P.TypeOpName) | TypeRef (P.ProperName 'P.TypeName) - | -- we use separate ref for a data constructor and keep here origin type as well + | -- We use separate ref for a data constructor and keep here origin type as well. ConstructorRef (P.ProperName 'P.TypeName) (P.ProperName 'P.ConstructorName) + | -- A ad-hoc ref that points to the type with a set of constructors that changed. + -- It is needed to correctly handle effects of adding/removing of ctors. + CtorsSetRef (P.ProperName 'P.TypeName) | ValueRef P.Ident | ValueOpRef (P.OpName 'P.ValueOpName) - | -- instance ref points to the class and types defined in the same module - -- TypeInstanceRef P.Ident (Maybe (P.ProperName 'P.ClassName)) [P.ProperName 'P.TypeName] + | -- Instance ref points to the class and types defined in the same module. TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] deriving (Show, Eq, Ord) -diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff -diffExterns newExts oldExts depsDiffs = - ExternsDiff modName $ - addStatus (changedRefs <> affectedReExported <> allAffectedLocalRefs) - where - modName = P.efModuleName newExts - -- Marks if ref was removed - addStatus = M.fromSet (flip S.notMember removedSet) +data RefStatus = Removed | Updated + deriving (Show) - depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) +type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) - -- To get changed reexported refs, we take those which were removed (not - -- present in new extern's exports) or changed in dependencies. +type RefsWithStatus = M.Map Ref RefStatus + +type ModuleRefsMap = Map ModuleName (Set Ref) + +data ExternsDiff = ExternsDiff + {edModuleName :: ModuleName, edRefs :: Map Ref RefStatus} + deriving (Show) + +-- | Empty diff means no effective difference between externs. +emptyDiff :: P.ModuleName -> ExternsDiff +emptyDiff mn = ExternsDiff mn mempty + +isRefRemoved :: RefStatus -> Bool +isRefRemoved Removed = True +isRefRemoved _ = False + +-- To get changed reexported refs, we take those which were removed (not +-- present in new extern's exports) or changed in dependencies. +getReExported :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> RefsWithStatus +getReExported newExts oldExts depsDiffsMap = + -- S.fromList $ map snd $ filter checkRe oldExports + M.fromList $ mapMaybe checkRe oldExports + where goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref goRe _ = [] oldExports = concatMap goRe (P.efExports oldExts) newReExports = concatMap goRe (P.efExports newExts) checkRe (mn, ref) - | (mn, ref) `notElem` newReExports = True - | Just True <- elem ref <$> M.lookup mn depsDiffsMap = True - | otherwise = False - affectedReExported = S.fromList $ map snd $ filter checkRe oldExports + | (mn, ref) `notElem` newReExports = Just (ref, Removed) + | Just True <- elem ref <$> M.lookup mn depsDiffsMap = Just (ref, Updated) + | otherwise = Nothing + +-- Extracts declarations from old and new externs and compares them. Returns a +-- tuple of changed refs (a form of which have changed) and unchanged refs with +-- dependencies (refs they depend upon). +getChanged :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> (RefsWithStatus, [RefWithDeps]) +getChanged newExts oldExts depsDiffsMap = + (changedRefs, unchangedRefs) + where + modName = P.efModuleName newExts getDecls = map stripDeclaration . P.efDeclarations getTypeFixities = P.efTypeFixities @@ -87,25 +98,31 @@ diffExterns newExts oldExts depsDiffs = applyInstances (a, r, c, u) = let checkType t (TypeRef t') = t' == t checkType _ _ = False - uRefs = map fst u + uRefs = map fst u -- Unchanged refs. go (TypeInstanceRef _ (clsMod, cls) types) | clsRef <- TypeClassRef cls = if clsMod == modName - then -- If the class is defined in this module we ensure that is marked as changed + then -- If the class is defined in this module we ensure that is marked as changed. maybe [] pure $ find ((==) clsRef) uRefs else case S.member clsRef <$> M.lookup clsMod depsDiffsMap of Just True -> - -- if the type class is in another module and it has - -- changed we don't need to care about instance types. + -- If the type class is in another module and it has + -- changed we don't need to care about instance types + -- (because the instance change affects modules that use + -- the type class/its methods). [] - -- Otherwise mark instance types as changed. _ -> + -- Otherwise mark instance types as changed. foldMap (\t -> filter (checkType t) uRefs) types go _ = mempty + + -- Check class instances in added, removed and changed. affected = foldMap (S.fromList . go . fst) (a <> r <> c) (uc, uu) = L.partition (flip S.member affected . fst) u in (a, r, c <> uc, uu) + -- Group/split exported refs of the module into (added, removed, changed, + -- unchanged) - (a, r, c, u). declsSplit = applyInstances $ splitRefs (getDecls newExts) (getDecls oldExts) (externsDeclarationToRef modName) @@ -115,7 +132,9 @@ diffExterns newExts oldExts depsDiffs = getRefsSet (a, r, c, u) = S.fromList $ map fst (a <> r <> c <> u) fixityCtx = M.insert modName (getRefsSet declsSplit) depsDiffsMap - -- Determine which declarations where directly changed or removed. + -- Determine which declarations where directly changed or removed by + -- combining Declarations, Fixities and Type Fixities - as they are + -- separated in externs we handle them separately. We don't care about added things. (_, removed, changed, unchangedRefs) = foldl zipTuple4 @@ -125,28 +144,46 @@ diffExterns newExts oldExts depsDiffs = , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) ] - removedSet = S.fromList (map fst removed) - changedRefs = S.fromList $ map fst (removed <> changed) - - diffsMapWithLocal - | null changedRefs = depsDiffsMap - | otherwise = M.insert modName changedRefs depsDiffsMap + changedRefs = + M.fromList $ + map ((,Removed) . fst) removed <> map ((,Updated) . fst) changed - -- Affected refs here are refs that depend on external or local changed refs. - -- - -- Rest local refs are refs that do not depend on external/local changed, but - -- may depend on affected local refs and need to be checked. +-- Gets set of type constructors from new externs that have changed. +getCtorsSets :: P.ExternsFile -> P.ExternsFile -> Set Ref +getCtorsSets newExts oldExts = + S.map CtorsSetRef $ + M.keysSet $ + M.differenceWith comp (getSets newExts) (getSets oldExts) + where + getSets = M.fromList . foldMap goDecl . P.efDeclarations + goDecl = \case + P.EDType n _ (P.DataType _ _ ctors) -> + [(n, S.fromList $ fst <$> ctors)] + _ -> [] + comp a b = if a == b then Nothing else Just a + +-- Takes a list unchanged local refs with dependencies and finds that are affected by +-- changed refs. Cyclic dependencies between local refs are searched using +-- directed graph. +getAffectedLocal :: ModuleName -> ModuleRefsMap -> [RefWithDeps] -> Set Ref +getAffectedLocal modName diffsMap unchangedRefs = + affectedLocalRefs + where hasChangedDeps (mn, ref) = - Just True == (S.member ref <$> M.lookup mn diffsMapWithLocal) - (affectedLocalRefs, restLocalRefs) = + Just True == (S.member ref <$> M.lookup mn diffsMap) + (affectedByChanged, restLocalRefs) = L.partition (any hasChangedDeps . snd) unchangedRefs -- Use graph to go though local refs and their cyclic dependencies on each other. -- The graph includes only local refs that depend on other local refs. - toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) deps) + toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) (S.toList deps)) - vtxs = toNode <$> (map (map S.toList) restLocalRefs <> (map (const mempty) <$> affectedLocalRefs)) + -- Make graph vertexes from the rest local refs with deps and affected refs + -- with no deps. + vtxs = toNode <$> restLocalRefs <> (map (const mempty) <$> affectedByChanged) (graph, fromVtx, toVtx) = G.graphFromEdges vtxs + + -- Graph is a list of refs with (refs) dependencies. refsGraph = do (_, t, _) <- vtxs let v = fromMaybe (internalError "diffExterns: vertex not found") $ toVtx t @@ -155,11 +192,37 @@ diffExterns newExts oldExts depsDiffs = pure (t, map toKey deps) -- Get local refs that depend on affected refs (affected refs are included - -- in the graph too). - allAffectedLocalRefs = + -- in the graph result because a node's reachable list includes the node + -- itself). + affectedLocalRefs = S.fromList $ map fst $ - filter (any (flip elem (fst <$> affectedLocalRefs)) . snd) refsGraph + filter (any (flip elem (fst <$> affectedByChanged)) . snd) refsGraph + +diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff +diffExterns newExts oldExts depsDiffs = + ExternsDiff modName $ + affectedReExported <> changedRefs <> affectedLocalRefs + where + modName = P.efModuleName newExts + + depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) + + -- To get changed reexported refs, we take those which were removed (not + -- present in new extern's exports) or changed in dependencies. + affectedReExported = getReExported newExts oldExts depsDiffsMap + + (changedRefs, unchangedRefs) = getChanged newExts oldExts depsDiffsMap + + ctorsSets = getCtorsSets newExts oldExts + + -- Extend dependencies' diffs map with local changes. + diffsMapWithLocal + | null changedRefs && null ctorsSets = depsDiffsMap + | otherwise = M.insert modName (M.keysSet changedRefs <> ctorsSets) depsDiffsMap + + affectedLocalRefs = + M.fromSet (const Updated) $ getAffectedLocal modName diffsMapWithLocal unchangedRefs checkDiffs :: P.Module -> [ExternsDiff] -> Bool checkDiffs (P.Module _ _ _ decls exports) diffs @@ -244,8 +307,8 @@ checkUsage searches decls = foldMap findUsage decls /= mempty -- | Traverses imports and returns a set of refs to be searched though the -- module. Returns Nothing if removed refs found in imports (no need to search --- through the module). If an empty set is returned then no changes apply to the --- module. +-- through the module - the module needs to be recompiled). If an empty set is +-- returned then no changes apply to the module. makeSearches :: [P.Declaration] -> [ExternsDiff] -> Maybe (Set (Maybe ModuleName, Ref)) makeSearches decls depsDiffs = foldM go mempty decls @@ -268,18 +331,18 @@ makeSearches decls depsDiffs = P.Explicit dRefs | any (flip S.member removed) refs -> Nothing | otherwise -> - -- search only refs encountered in the import. + -- Search only refs encountered in the import. Just $ M.filterWithKey (const . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs P.Hiding dRefs | any (flip S.member removed) refs -> Nothing | otherwise -> - -- search only refs not encountered in the import. + -- Search only refs not encountered in the import. Just $ M.filterWithKey (const . not . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs - -- search all changed refs + -- Search all changed refs. P.Implicit -> Just diffs go s _ = Just s @@ -340,8 +403,6 @@ qualified :: P.Qualified b -> (ModuleName, b) qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) qualified _ = internalError "ExternsDiff: type is not qualified" -type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) - -- | To get fixity's data constructor dependency we should provide it with the -- context (that contains all known refs) to search in. externsFixityToRef :: Map ModuleName (Set Ref) -> P.ExternsFixity -> RefWithDeps @@ -363,21 +424,25 @@ externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps externsDeclarationToRef moduleName = \case P.EDType n t tk - | isDictName n -> Nothing + | isDictTypeName n -> Nothing | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) -- P.EDTypeSynonym n args t -> Just (TypeRef n, typeDeps t <> foldArgs args) -- P.EDDataConstructor n _ tn t _ - | isDictName n -> Nothing + | isDictTypeName n -> Nothing | otherwise -> Just ( ConstructorRef tn n - , -- Add the type as a dependency: if the type has changed (e.g. - -- constructors removed/added) it should affect all the constructors - -- in the type. - S.insert (moduleName, TypeRef tn) (typeDeps t) + , -- Add the type as a dependency: if the type has changed (e.g. left side + -- param is added) we should recompile the module which uses the + -- constructor (even if there no the explicit type import). + -- Aso add the ad-hoc constructors set ref dependency: if a ctor + -- added/removed it should affect all constructors in the type, + -- because case statement's validity may be affected by newly added + -- or removed constructors. + typeDeps t <> S.fromList [(moduleName, TypeRef tn), (moduleName, CtorsSetRef tn)] ) -- P.EDValue n t -> @@ -415,12 +480,14 @@ externsDeclarationToRef moduleName = \case ) -- | Removes excessive info from declarations before comparing. +-- +-- TODO: params renaming will be needed to avoid recompilation because of params +-- name changes. stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration stripDeclaration = \case - P.EDType n t (P.DataType dt args ctors) -> - -- Remove data constructors types, we don't need them, we only need to know - -- if the list of ctors has changed. - P.EDType n t (P.DataType dt args (map (map (const [])) ctors)) + P.EDType n t (P.DataType dt args _) -> + -- Remove the notion of data constructors, we only compare type's left side. + P.EDType n t (P.DataType dt args []) -- P.EDInstance cn n fa ks ts cs ch chi ns ss -> P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss @@ -428,13 +495,7 @@ stripDeclaration = \case decl -> decl where emptySP = P.SourcePos 0 0 - -- emptySS = SourceSpan "" emptySP emptySP stripChain (ChainId (n, _)) = ChainId (n, emptySP) isPrimModule :: ModuleName -> Bool isPrimModule = flip S.member (S.fromList primModules) - --- | Check if type name is a type class dictionary name. -isDictName :: P.ProperName a -> Bool -isDictName = - T.isInfixOf "$" . P.runProperName diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 94f56fc449..97ea465999 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -147,7 +147,7 @@ setupSupportModules = do let modules = map snd ms supportExterns <- runExceptT $ do foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make' (makeActions modules foreigns) (CST.pureResult <$> modules) + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules) return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) @@ -231,7 +231,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do _ -> do unless hasExpectedModuleName $ error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." - compiledModulePath <$ P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + compiledModulePath <$ P.make_ actions (CST.pureResult <$> supportModules ++ map snd ms) getPsModuleName :: (a, AST.Module) -> T.Text getPsModuleName psModule = case snd psModule of From 28f3bf00491905f1e8cc1959644cd6f4419bea83 Mon Sep 17 00:00:00 2001 From: Alex Date: Fri, 7 Jul 2023 18:44:13 +0500 Subject: [PATCH 4/8] Add comments to BuildPlan --- src/Language/PureScript/Make/BuildPlan.hs | 41 +++++++++++++++++------ 1 file changed, 30 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 8669233b0e..21a221f55f 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -36,24 +36,35 @@ import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) +-- This status tells if a module's exiting build artifacts are up to date with a +-- current module's content. It would be safe to re-use them, but only if +-- changes in its dependencies do require the module's rebuild. newtype UpToDateStatus = UpToDateStatus Bool isUpToDate :: UpToDateStatus -> Bool isUpToDate (UpToDateStatus b) = b +data Prebuilt = Prebuilt + { pbExternsFile :: ExternsFile + } + -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt + -- ^ Valid prebuilt results for modules, that are needed for rebuild, but + -- their rebuild is not required. , bpPreviousBuilt :: M.Map ModuleName (UpToDateStatus, Prebuilt) + -- ^ Previously built results for modules that are potentially required to be + -- rebuilt. We will always rebuild not up to date modules. But we will only + -- rebuild up to date modules, if their deps' externs have effectively + -- changed. Previously built result is needed to compare previous and newly + -- built externs to know what have changed. , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int } -data Prebuilt = Prebuilt - { pbExternsFile :: ExternsFile - } newtype BuildJob = BuildJob { bjResult :: C.MVar BuildJobResult @@ -152,7 +163,6 @@ getPrevResult :: BuildPlan -> ModuleName -> Maybe (UpToDateStatus, ExternsFile) getPrevResult buildPlan moduleName = fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) - data Options = Options { optPreloadAllExterns :: Bool } @@ -278,24 +288,33 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (UpToDateStatus, UTCTime)), M.Map ModuleName UTCTime) splitModules = foldl' collectByStatus (M.empty, M.empty) - collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) - | Nothing <- mbPb = (M.insert mn Nothing build, prev) + collectByStatus (build, prebuilt) (RebuildStatus mn rebuildNever _ mbPb upToDate) + -- To build if no prebuilt result exits. + | Nothing <- mbPb = (M.insert mn Nothing build, prebuilt) + -- To build if not up to date. | Just pb <- mbPb, not upToDate = toRebuild (False, pb) + -- To prebuilt because of policy. | Just pb <- mbPb, rebuildNever = toPrebuilt pb + -- In other case analyze compilation times of dependencies. | Just pb <- mbPb = do let deps = moduleDeps mn - let modTimes = map (flip M.lookup prev) deps + let modTimes = map (flip M.lookup prebuilt) deps case maximumMaybe (catMaybes modTimes) of -- Check if any of deps where build later. This means we should - -- recompile even if the source is up-to-date. + -- recompile even if the module's source is up-to-date. This may + -- happen due to some partial builds or ide compilation + -- workflows involved that do not assume full project + -- compilation. We should treat those modules as NOT up to date + -- to ensure they are rebuilt. Just depModTime | pb < depModTime -> toRebuild (False, pb) - -- If one of the deps is not in the prebuilt, we should rebuild. + -- If one of the deps is not in the prebuilt, though the module + -- is up to date, we should add it in the rebuild queue. _ | any isNothing modTimes -> toRebuild (upToDate, pb) _ -> toPrebuilt pb where - toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prev) - toPrebuilt v = (build, M.insert mn v prev) + toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prebuilt) + toPrebuilt v = (build, M.insert mn v prebuilt) maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing From 1d25867b1793acfd0066d94f0c688c78c7e47909 Mon Sep 17 00:00:00 2001 From: Alex Date: Sat, 24 Feb 2024 21:03:31 +0500 Subject: [PATCH 5/8] Added requested changes, don't recompile downstream after the error, tests updated and commented. --- src/Language/PureScript/Make.hs | 10 +- src/Language/PureScript/Make/ExternsDiff.hs | 25 +- tests/TestMake.hs | 402 ++++++++++++-------- 3 files changed, 269 insertions(+), 168 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 07810192c9..55a17d3468 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -353,7 +353,15 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff - Nothing -> return BuildJobSkipped + -- If we got Nothing for deps externs, that means one of the deps failed + -- to compile. Though if we have a previous built result we will keep to + -- avoid potentially unnecessary recompilation next time. + Nothing -> return $ + case BuildPlan.getPrevResult buildPlan moduleName of + Just (_, exts) -> + BuildJobSucceeded (MultipleErrors []) exts (Just (emptyDiff moduleName)) + Nothing -> + BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 31530ccce0..910fd1a963 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -11,6 +11,7 @@ import Data.Graph as G (graphFromEdges, reachable) import Data.List qualified as L import Data.Map qualified as M import Data.Set qualified as S + import Language.PureScript.AST qualified as P import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) import Language.PureScript.Constants.Prim (primModules) @@ -20,7 +21,6 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P -import Language.PureScript.Environment (isDictTypeName) -- Refs structure appropriate for storing and checking externs diffs. data Ref @@ -63,7 +63,6 @@ isRefRemoved _ = False -- present in new extern's exports) or changed in dependencies. getReExported :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> RefsWithStatus getReExported newExts oldExts depsDiffsMap = - -- S.fromList $ map snd $ filter checkRe oldExports M.fromList $ mapMaybe checkRe oldExports where goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref @@ -136,9 +135,7 @@ getChanged newExts oldExts depsDiffsMap = -- combining Declarations, Fixities and Type Fixities - as they are -- separated in externs we handle them separately. We don't care about added things. (_, removed, changed, unchangedRefs) = - foldl - zipTuple4 - (mempty, mempty, mempty, mempty) + fold [ declsSplit , splitRefs (getFixities newExts) (getFixities oldExts) (pure . externsFixityToRef fixityCtx) , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) @@ -224,6 +221,8 @@ diffExterns newExts oldExts depsDiffs = affectedLocalRefs = M.fromSet (const Updated) $ getAffectedLocal modName diffsMapWithLocal unchangedRefs +-- Checks if the externs diffs effect the module (the module uses any diff's +-- entries). True if uses, False if not. checkDiffs :: P.Module -> [ExternsDiff] -> Bool checkDiffs (P.Module _ _ _ decls exports) diffs | all isEmpty diffs = False @@ -233,12 +232,14 @@ checkDiffs (P.Module _ _ _ decls exports) diffs where mbSearch = makeSearches decls diffs searches = fromMaybe S.empty mbSearch + -- Check if the module reexports any of searched refs. checkReExports = flip (maybe False) exports $ any $ \case P.ModuleRef _ mn -> not . null $ S.filter ((== Just mn) . fst) searches _ -> False -- Goes though the module and try to find any usage of the refs. +-- Takes a set of refs to search in module's declarations, if found returns True. checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool checkUsage searches decls = foldMap findUsage decls /= mempty where @@ -254,7 +255,7 @@ checkUsage searches decls = foldMap findUsage decls /= mempty stripCtorType x = x searches' = S.map (map stripCtorType) searches - check = (\x -> [x | x]) . flip S.member searches' . toSearched + check = Any . flip S.member searches' . toSearched checkType = check . map TypeRef checkTypeOp = check . map TypeOpRef @@ -362,10 +363,6 @@ isEmpty (ExternsDiff _ refs) type Tuple4 m a = (m a, m a, m a, m a) -zipTuple4 :: Monoid (m a) => Tuple4 m a -> Tuple4 m a -> Tuple4 m a -zipTuple4 (f1, s1, t1, fo1) (f2, s2, t2, fo2) = - (f1 <> f2, s1 <> s2, t1 <> t2, fo1 <> fo2) - -- | Returns refs as a tuple of four (added, removed, changed, unchanged). splitRefs :: Ord r => Eq a => [a] -> [a] -> (a -> Maybe r) -> Tuple4 [] r splitRefs new old toRef = @@ -378,8 +375,8 @@ splitRefs new old toRef = go ref decl (a, r, c, u) = case M.lookup ref newMap of Nothing -> (a, r <> [ref], c, u) Just newDecl - | decl /= newDecl -> (a, r, c <> [ref], u) - | otherwise -> (a, r, c, u <> [ref]) + | decl /= newDecl -> (a, r, ref : c, u) + | otherwise -> (a, r, c, ref : u) -- | Traverses the type and finds all the refs within. typeDeps :: P.Type a -> S.Set (ModuleName, Ref) @@ -424,14 +421,14 @@ externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps externsDeclarationToRef moduleName = \case P.EDType n t tk - | isDictTypeName n -> Nothing + | P.isDictTypeName n -> Nothing | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) -- P.EDTypeSynonym n args t -> Just (TypeRef n, typeDeps t <> foldArgs args) -- P.EDDataConstructor n _ tn t _ - | isDictTypeName n -> Nothing + | P.isDictTypeName n -> Nothing | otherwise -> Just ( ConstructorRef tn n diff --git a/tests/TestMake.hs b/tests/TestMake.hs index e08cda7314..c5d51f44c8 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -47,8 +47,8 @@ spec = do let foreignJsPath name = sourcesDir (T.unpack name <> ".js") -- Test helpers. - let testN fn name modules compile2 res = - fn name $ do + let testN itFn name modules compileFn res = + itFn name $ do let names = map (\(mn, _, _) -> mn) modules let paths = map modulePath names let timestamp = utcMidnightOnDate 2019 1 @@ -61,7 +61,7 @@ spec = do forM_ (zip [length modules..] modules) $ \(idx, (mn, _, mbContent)) -> do maybe (pure ()) (writeFile (modulePath mn) (timestamp idx)) mbContent - compile2 paths `shouldReturn` moduleNames res + compileFn paths `shouldReturn` moduleNames res let test2 fn name (mAContent1, mAContent2, mBContent) res = testN fn name @@ -73,7 +73,7 @@ spec = do testN fn name [ ("A", mAContent1, Just mAContent2) , ("B", mBContent, Nothing) - ] compileAllowingFailures res + ] compileWithFailure res let test3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = testN fn name @@ -87,16 +87,16 @@ spec = do [ ("A", mAContent1, Just mAContent2) , ("B", mBContent, Nothing) , ("C", mCContent, Nothing) - ] compileAllowingFailures res + ] compileWithFailure res let recompile2 fn name ms = - test2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + test2 fn ("recompiles downstream when " <> name) ms ["A", "B"] let recompileWithFailure2 fn name ms = - testWithFailure2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + testWithFailure2 fn ("recompiles downstream when " <> name) ms ["A", "B"] let noRecompile2 fn name ms = - test2 fn ("does not recompile when upstream not changed effectively: " <> name) ms ["A"] + test2 fn ("does not recompile downstream when " <> name) ms ["A"] before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do it "does not recompile if there are no changes" $ do @@ -157,6 +157,75 @@ spec = do removeFile mFFIPath compile [mPath] `shouldReturn` moduleNames ["Module"] + it "does not necessarily recompile modules which were not part of the previous batch" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + batch1 = [mAPath, mBPath] + batch2 = [mAPath, mCPath] + + mAContent = "module A where\nfoo = 0\n" + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + + compile batch1 `shouldReturn` moduleNames [] + compile batch2 `shouldReturn` moduleNames [] + + it "recompiles if a module fails to compile" $ do + let mPath = sourcesDir "Module.purs" + moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" + + writeFile mPath timestampA moduleContent + compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] + compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] + + it "recompiles if docs are requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" + + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } + go opts = compileWithOptions opts [mPath] >>= assertSuccess + + writeFile mPath timestampA moduleContent1 + go optsWithDocs `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing docs.json is now outdated, the module should be + -- recompiled. + go optsWithDocs `shouldReturn` moduleNames ["Module"] + + it "recompiles if CoreFn is requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } + go opts = compileWithOptions opts [mPath] >>= assertSuccess + + writeFile mPath timestampA moduleContent1 + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing CoreFn.json is now outdated, the module should be + -- recompiled. + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + + -- Cut off rebuild tests. + + -- If a module is compiled with effective changes for downstream they should + -- be rebuilt too. it "recompiles downstream modules when a module is rebuilt and externs changed" $ do let mAPath = modulePath "A" mBPath = modulePath "B" @@ -171,7 +240,9 @@ spec = do writeFile mAPath timestampC mAContent2 compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] - it "only recompiles downstream modules when a module is rebuilt end externs changed" $ do + -- If a module is compiled with no effective changes for downstream they should + -- not be rebuilt. + it "recompiles downstream modules only when a module is rebuilt end externs changed" $ do let mAPath = modulePath "A" mBPath = modulePath "B" mCPath = modulePath "C" @@ -190,6 +261,8 @@ spec = do writeFile mAPath timestampD mAContent2 compile modulePaths `shouldReturn` moduleNames ["A", "B"] + -- If module is compiled separately (e.g., with ide). Then downstream should + -- be rebuilt during the next build. it "recompiles downstream after a module has been rebuilt separately" $ do let mAPath = modulePath "A" mBPath = modulePath "B" @@ -214,8 +287,46 @@ spec = do compile mPaths `shouldReturn` moduleNames ["B", "C"] - -- Reexports. - test3 it "recompiles downstream modules when a reexported module changed" + -- If a module failed to compile, then the error is fixed and there are no + -- effective changes for downstream modules, they should not be recompiled. + it "does not recompile downstream modules after the error fixed and externs not changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" + mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" + mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + + writeFile mAPath timestampD mAContent1 + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + + -- If a module failed to compile, then the error is fixed and there are + -- effective changes for downstream modules, they should be recompiled. + it "recompiles downstream modules after the error fixed and externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" + mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" + mAContent3 = "module A where\nfoo :: Char\nfoo = '0'\n" + mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + writeFile mAPath timestampD mAContent3 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + -- Reexports: original ref is changed. + test3 it "recompiles downstream when a reexported ref changed" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here , "module B (module E) where\nimport A (foo) as E\n" @@ -223,13 +334,54 @@ spec = do ) ["A", "B", "C"] - -- test3 fit "reexported module changed" - -- ( "module A where\ndata ABC = A Int | B\n" - -- , "module A where\ndata ABC = A String | B\n" -- change externs here - -- , "module B (module E) where\nimport A (ABC(..)) as E\n" - -- , "module C where\nimport B as B\nbaz = B.A\n" - -- ) - -- ["A", "B", "C"] + -- Reexports: original ref is changed. Ref is imported but not used. + test3 it "does not recompile downstream when a reexported ref changed and the ref is imported but not used" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + -- Import but not use. + , "module C where\nimport B (foo)\nx = 1\n" + ) + ["A", "B"] + + -- Reexports: original export is removed from module. + testWithFailure3 it "recompiles downstream when a reexported ref removed" + ( "module A where\nfoo = 0\n" + , "module A where\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["A", "B", "C"] + + -- Reexports: ref is removed from reexporting module. + testWithFailure3 it "recompiles downstream when a reexported ref removed (from reexported)" + ( "module B (module E) where\nimport A (foo) as E\n" + , "module B where\nimport A (foo) as E\n" + , "module A where\nfoo = 0\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["B", "C"] + + -- Reexports: ref is imported but not used. Reexport ref is removed from + -- reexporting module. + testWithFailure3 it "recompiles downstream when a reexported ref removed (imported but not used)" + ( "module B (module E) where\nimport A (foo) as E\n" + , "module B where\nimport A (foo) as E\n" + , "module A where\nfoo = 0\n" + -- Import but not use. + , "module C where\nimport B (foo) as B\nx=1\n" + ) + ["B", "C"] + + -- Reexports: original ref Removed. Ref is imported but not used. + testWithFailure3 it "recompiles downstream when a reexported ref removed in original" + ( "module A where\nfoo = 0\n" + , "module A where\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + -- Import but not use. + , "module C where\nimport B (foo)\nx = 1\n" + ) + ["A", "B", "C"] -- Imports. testWithFailure2 it "recompiles downstream when removed reference found in imports" @@ -246,10 +398,8 @@ spec = do ) ["A"] - -- Usage in the code - -- signature - - -- inlined + -- We need to ensure that it finds refs everywhere inside a module. + -- Usage: Inlined type. testWithFailure2 it "recompiles downstream when found changed inlined type" ( "module A where\ntype T = Int\n" , "module A where\ntype T = String\n" @@ -257,7 +407,8 @@ spec = do ) ["A", "B"] - -- Transitive change. + -- Transitive change: module A changes, module B depends on A and module C + -- depends on B are both recompiled. test3 it "recompiles downstream due to transitive change" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\n" @@ -266,7 +417,7 @@ spec = do ) ["A", "B", "C"] - test3 it "do not recompile downstream if no transitive change" + test3 it "does not recompile downstream if no transitive change" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\n" , "module B where\nimport A (foo)\nbar = 1\nqux = foo" @@ -274,44 +425,50 @@ spec = do ) ["A", "B"] - noRecompile2 it "unused type changed" + -- Non effective change does not cause downstream rebuild. + test2 it "does not recompile downstream if unused type changed" ( "module A where\ntype SynA = Int\ntype SynA2 = Int" , "module A where\ntype SynA = String\ntype SynA2 = Int" , "module B where\nimport A as A\ntype SynB = A.SynA2" ) + ["A"] - -- Type synonyms. + -- Type synonym change. recompile2 it "type synonym changed" ( "module A where\ntype SynA = Int\n" , "module A where\ntype SynA = String\n" , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" ) + -- Type synonym indirect change. recompile2 it "type synonym dependency changed" ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" ) - -- Data types. + -- Data type: parameter added. recompile2 it "data type changed (parameter added)" ( "module A where\ndata T = A Int | B Int\n" , "module A where\ndata T a = A Int | B a\n" , "module B where\nimport A (T)\ntype B = T" ) + -- Data type: constructor added. recompile2 it "data type changed (constructor added)" - ( "module A where\ndata T = A Int | B Int\n" - , "module A where\ndata T = A Int | B Int | C Int\n" + ( "module A where\ndata T = A | B\n" + , "module A where\ndata T = A | B | C\n" , "module B where\nimport A (T(B))\nb = B" ) + -- Data type: constructor indirectly changed. recompile2 it "data type constructor dependency changed" ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" , "module B where\nimport A (AB(..))\nb = A" ) + -- Data type: constructor changed but not used. noRecompile2 it "data type constructor changed, but not used" ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" @@ -319,14 +476,40 @@ spec = do , "module B where\nimport A (AB(..))\ntype B = AB\nb = B" ) + -- Data type: constructor added, but not imported. + noRecompile2 it "data type constructor added, but ctors not imported" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use just type + , "module B where\nimport A (AB)\ntype B = AB\n" + ) - -- Value operators. + -- Data type: constructor added, but not used. + noRecompile2 it "data type constructor added, but ctors not imported" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use type + , "module B where\nimport A (AB(..))\ntype B = AB\n" + ) + + -- Data type: constructor added, and constructors are used in the downstream + -- module (this may be need when there is a case statement without wildcard, + -- but we don't analyze the usage that deep). + recompile2 it "data type constructor added and ctors are used" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use type and other constructor + , "module B where\nimport A (AB(..))\ntype B = AB\nb = B\n" + ) + + -- Value operator change. recompile2 it "value op changed" ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" , "module B where\nimport A\nt = 1 :+: \"1\" " ) + -- Value operator indirect change. recompile2 it "value op dependency changed" ( "module A where\ndata T a = T a String\ninfixl 2 T as :+:\n" , "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" @@ -334,20 +517,21 @@ spec = do ) - -- Type operators. + -- Type operator change. recompile2 it "type op changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" ) + -- Type operator indirect change. recompile2 it "type op dependency changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" , "module A where\ndata T b a = T a b\ninfixl 2 type T as :+:\n" , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" ) - -- Type classes. + -- Type classes changed. Downstream uses type class in signature. recompile2 it "type class changed" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Char\n" @@ -359,6 +543,7 @@ spec = do ] ) + -- Type classes changed. Downstream uses only its member. recompile2 it "type class changed (member affected)" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Char\n" @@ -369,6 +554,7 @@ spec = do ] ) + -- Type class instance added. recompile2 it "type class instance added" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" @@ -380,6 +566,7 @@ spec = do ] ) + -- Type class instance removed. recompileWithFailure2 it "type class instance removed" ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" , "module A where\nclass Cls a where m1 :: a -> Int\n" @@ -390,34 +577,26 @@ spec = do ] ) - test3 it "recompiles downstream if instance added for type" - ( "module A where\nimport B\nnewtype T = T Int\n" - , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module B where\nclass Cls a where m1 :: a -> Int\n" - , T.unlines - [ "module C where" - , "import A" - , "t = T 1" - ] - ) - ["A", "C"] - - test3 it "recompiles downstream if instance added for type" - ( "module A where\nimport B\nnewtype T = T Int\n" - , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module B where\nclass Cls a where m1 :: a -> Int\n" + -- Type class instance added for a type. We need to recompile downstream + -- modules that use this type, because it can be effected (even if it + -- doesn't use type class as we do not analyze this). + test3 it "recompiles downstream if instance added for a type" + ( "module B where\nimport A\nnewtype T = T Int\n" + , "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module A where\nclass Cls a where m1 :: a -> Int\n" , T.unlines [ "module C where" - , "import A" + , "import B" , "t = T 1" ] ) - ["A", "C"] + ["B", "C"] - testWithFailure3 it "recompiles downstream if instance removed for type" - ( "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module A where\nimport B\nnewtype T = T Int\n" - , "module B where\nclass Cls a where m1 :: a -> Int\n" + -- Type class instance removed for a type. + testWithFailure3 it "recompiles downstream if type class instance removed for a type" + ( "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nimport A\nnewtype T = T Int\n" + , "module A where\nclass Cls a where m1 :: a -> Int\n" , T.unlines [ "module C where" , "import A" @@ -426,9 +605,12 @@ spec = do , "i = m1 (T 1)" ] ) - ["A", "C"] + ["B", "C"] - testN it "doesn't recompile downstream if an instance added for the type and type class changed" + -- Type class instance added for the type and type class in another module + -- it self is modified. We don't need to recompile downstream modules that + -- depend only on type (if they use type class they will be recompiled). + testN it "does not recompile downstream if an instance added for the type and type class changed" [ ( "A" , "module A where\nclass Cls a where m1 :: a -> Char\n" , Just "module A where\nclass Cls a where m1 :: a -> Int\n" @@ -440,100 +622,6 @@ spec = do , ("C", "module C where\nimport B\ntype C = T", Nothing) ] compile ["A", "B"] - it "does not recompile downstream modules when a module is rebuilt but externs have not changed" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] - - mAContent1 = "module A where\nfoo = 0\n" - mAContent2 = "module A (foo) where\nbar = 1\nfoo = 1\n" - mBContent = - T.unlines - [ "module B where" - , "import A (foo)" - , "import C (baz)" - , "bar = foo" - , "qux = baz" - ] - mCContent = "module C where\nbaz = 3\n" - - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - -- - writeFile mAPath timestampD mAContent2 - threadDelay oneSecond - compile modulePaths `shouldReturn` moduleNames ["A"] - -- compile again to check that it won't try recompile skipped module again - compile modulePaths `shouldReturn` moduleNames [] - - it "does not necessarily recompile modules which were not part of the previous batch" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] - - batch1 = [mAPath, mBPath] - batch2 = [mAPath, mCPath] - - mAContent = "module A where\nfoo = 0\n" - mBContent = "module B where\nimport A (foo)\nbar = foo\n" - mCContent = "module C where\nbaz = 3\n" - - writeFile mAPath timestampA mAContent - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - - compile batch1 `shouldReturn` moduleNames [] - compile batch2 `shouldReturn` moduleNames [] - - it "recompiles if a module fails to compile" $ do - let mPath = sourcesDir "Module.purs" - moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" - - writeFile mPath timestampA moduleContent - compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] - compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] - - it "recompiles if docs are requested but not up to date" $ do - let mPath = sourcesDir "Module.purs" - - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - - optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } - go opts = compileWithOptions opts [mPath] >>= assertSuccess - - writeFile mPath timestampA moduleContent1 - go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 - -- See Note [Sleeping to avoid flaky tests] - threadDelay oneSecond - go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing docs.json is now outdated, the module should be - -- recompiled. - go optsWithDocs `shouldReturn` moduleNames ["Module"] - - it "recompiles if CoreFn is requested but not up to date" $ do - let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } - go opts = compileWithOptions opts [mPath] >>= assertSuccess - - writeFile mPath timestampA moduleContent1 - go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 - -- See Note [Sleeping to avoid flaky tests] - threadDelay oneSecond - go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing CoreFn.json is now outdated, the module should be - -- recompiled. - go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - -- Note [Sleeping to avoid flaky tests] -- -- One of the things we want to test here is that all requested output files @@ -595,14 +683,23 @@ assertSuccess (result, recompiled) = Right _ -> pure recompiled +assertFailure :: (Either P.MultipleErrors a, Set P.ModuleName) -> IO (Set P.ModuleName) +assertFailure (result, recompiled) = + case result of + Left _ -> + pure recompiled + Right _ -> + fail "should compile with errors" + -- | Compile, returning the set of modules which were rebuilt, and failing if -- any errors occurred. compile :: [FilePath] -> IO (Set P.ModuleName) compile input = compileWithResult input >>= assertSuccess -compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) -compileAllowingFailures input = fmap snd (compileWithResult input) +compileWithFailure :: [FilePath] -> IO (Set P.ModuleName) +compileWithFailure input = + compileWithResult input >>= assertFailure writeFile :: FilePath -> UTCTime -> T.Text -> IO () writeFile path mtime contents = do @@ -613,4 +710,3 @@ writeFile path mtime contents = do -- from other test results modulesDir :: FilePath modulesDir = ".test_modules" "make" - From bde9483c9d63593664820edfe9ae4f6390db8fa1 Mon Sep 17 00:00:00 2001 From: Alex Date: Wed, 29 May 2024 22:31:54 +0500 Subject: [PATCH 6/8] Update ExternsDiff.checkUsage, add tests --- src/Language/PureScript/Make/ExternsDiff.hs | 50 ++++++--------- tests/TestMake.hs | 68 +++++++++++++++++---- 2 files changed, 77 insertions(+), 41 deletions(-) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 910fd1a963..5877b2c722 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -241,21 +241,22 @@ checkDiffs (P.Module _ _ _ decls exports) diffs -- Goes though the module and try to find any usage of the refs. -- Takes a set of refs to search in module's declarations, if found returns True. checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool -checkUsage searches decls = foldMap findUsage decls /= mempty +checkUsage searches decls = anyUsages where - findUsage decl = - let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty - in extr mempty decl + -- Two traversals: one to pick up usages of types, one for the rest. + Any anyUsages = + foldMap checkUsageInTypes decls + <> foldMap checkOtherUsages decls - toSearched = (,) <$> P.getQual <*> P.disqualify + -- To check data constructors we remove an origin type from it (see `checkCtor`). + searches' = S.map (map stripCtorType) searches -- To check data constructors we remove an origin type from it. emptyName = P.ProperName "" stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n stripCtorType x = x - searches' = S.map (map stripCtorType) searches - check = Any . flip S.member searches' . toSearched + check q = Any $ S.member (P.getQual q, P.disqualify q) searches' checkType = check . map TypeRef checkTypeOp = check . map TypeOpRef @@ -264,31 +265,21 @@ checkUsage searches decls = foldMap findUsage decls /= mempty checkCtor = check . map (ConstructorRef emptyName) checkClass = check . map TypeClassRef - onTypes = P.everythingOnTypes (<>) $ \case - P.TypeConstructor _ n -> checkType n - P.TypeOp _ n -> checkTypeOp n - P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) - _ -> mempty - - foldCtor f (P.DataConstructorDeclaration _ _ vars) = - foldMap (f . snd) vars + -- A nested traversal: pick up types in the module then traverse the structure of the types + (checkUsageInTypes, _, _, _, _) = + P.accumTypes $ P.everythingOnTypes (<>) $ \case + P.TypeConstructor _ n -> checkType n + P.TypeOp _ n -> checkTypeOp n + P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) + _ -> mempty - constraintTypes = - foldMap (\c -> P.constraintArgs c <> P.constraintKindArgs c) + checkOtherUsages = + let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty + in extr mempty goDecl _ = \case - P.TypeDeclaration t -> onTypes (P.tydeclType t) - P.DataDeclaration _ _ _ _ ctors -> foldMap (foldCtor onTypes) ctors - P.TypeSynonymDeclaration _ _ _ t -> onTypes t - P.KindDeclaration _ _ _ t -> onTypes t - P.FixityDeclaration _ (Right (P.TypeFixity _ tn _)) -> - checkType tn - P.FixityDeclaration _ (Left (P.ValueFixity _ (P.Qualified by val) _)) -> - either (checkValue . P.Qualified by) (checkCtor . P.Qualified by) val - P.TypeClassDeclaration _ _ _ cs _ _ -> - foldMap onTypes (constraintTypes cs) - P.TypeInstanceDeclaration _ _ _ _ _ cs tc sts _ -> - foldMap onTypes (constraintTypes cs <> sts) <> checkClass tc + P.TypeInstanceDeclaration _ _ _ _ _ _ tc _ _ -> + checkClass tc _ -> mempty isLocal scope ident = P.LocalIdent ident `S.member` scope @@ -298,7 +289,6 @@ checkUsage searches decls = foldMap findUsage decls /= mempty | otherwise -> checkValue n P.Constructor _ n -> checkCtor n P.Op _ n -> checkValueOp n - P.TypedValue _ _ t -> onTypes t _ -> mempty goBinder _ binder = case binder of diff --git a/tests/TestMake.hs b/tests/TestMake.hs index c5d51f44c8..cf3e422c6f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -9,7 +9,7 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad (guard, void, forM_) +import Control.Monad (guard, void, forM_, when) import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) @@ -19,11 +19,13 @@ import Data.Text qualified as T import Data.Set (Set) import Data.Set qualified as Set import Data.Map qualified as M +import Data.Version (showVersion) +import Paths_purescript qualified as Paths import System.FilePath (()) import System.Directory (createDirectory, removeDirectoryRecursive, removeFile, setModificationTime) import System.IO.Error (isDoesNotExistError) -import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) +import System.IO.UTF8 (readUTF8FilesT, readUTF8FileT, writeUTF8FileT) import Test.Hspec (Spec, before_, it, shouldReturn) @@ -55,6 +57,9 @@ spec = do forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do writeFile (modulePath mn) (timestamp idx) content + -- Write a fake foreign module to bypass compiler's check. + when (T.isInfixOf "\nforeign import" content) $ + writeFile (foreignJsPath mn) (timestamp idx) content compile paths `shouldReturn` moduleNames names @@ -189,15 +194,15 @@ spec = do it "recompiles if docs are requested but not up to date" $ do let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + mContent1 = "module Module where\nx :: Int\nx = 1" + mContent2 = mContent1 <> "\ny :: Int\ny = 1" optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFile mPath timestampA moduleContent1 + writeFile mPath timestampA mContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 + writeFile mPath timestampB mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -207,14 +212,14 @@ spec = do it "recompiles if CoreFn is requested but not up to date" $ do let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + mContent1 = "module Module where\nx :: Int\nx = 1" + mContent2 = mContent1 <> "\ny :: Int\ny = 1" optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFile mPath timestampA moduleContent1 + writeFile mPath timestampA mContent1 go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 + writeFile mPath timestampB mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -222,6 +227,27 @@ spec = do -- recompiled. go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + it "recompiles if cache-db version differs from the current" $ do + let mPath = sourcesDir "Module.purs" + mContent = "module Module where\nfoo :: Int\nfoo = 1\n" + + writeFile mPath timestampA mContent + compile [mPath] `shouldReturn` moduleNames ["Module"] + + -- Replace version with illegal in cache-db file. + let cacheDbFilePath = P.cacheDbFile modulesDir + versionText ver = "\"version\":\"" <> ver <> "\"" + + cacheContent <- readUTF8FileT cacheDbFilePath + + let currentVer = T.pack (showVersion Paths.version) + let newContent = + T.replace (versionText currentVer) (versionText "0.0.0") cacheContent + + writeUTF8FileT cacheDbFilePath newContent + + compile [mPath] `shouldReturn` moduleNames ["Module"] + -- Cut off rebuild tests. -- If a module is compiled with effective changes for downstream they should @@ -433,6 +459,13 @@ spec = do ) ["A"] + -- Type synonym in foreign import. + recompile2 it "type synonym changed in foreign import" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nforeign import a :: A.SynA\n" + ) + -- Type synonym change. recompile2 it "type synonym changed" ( "module A where\ntype SynA = Int\n" @@ -440,6 +473,20 @@ spec = do , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" ) + -- Type synonym change in value. + recompile2 it "type synonym changed in value" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nvalue = ([] :: Array A.SynA)\n" + ) + + -- Type synonym change in pattern. + recompile2 it "type synonym changed in pattern" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nfn = \\(_ :: Array A.SynA) -> 0\n" + ) + -- Type synonym indirect change. recompile2 it "type synonym dependency changed" ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" @@ -516,7 +563,6 @@ spec = do , "module B where\nimport A\nt = 1 :+: \"1\" " ) - -- Type operator change. recompile2 it "type op changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" From 31aba1a6bccccc5c0cfcbd5026ab02d2f9d0ef87 Mon Sep 17 00:00:00 2001 From: Alex Date: Tue, 26 Nov 2024 13:38:59 +0500 Subject: [PATCH 7/8] Add serialize instances for saving warnings --- src/Language/PureScript/AST/Binders.hs | 3 +- src/Language/PureScript/AST/Declarations.hs | 49 ++++++++++--------- src/Language/PureScript/AST/Literals.hs | 3 +- src/Language/PureScript/Bundle.hs | 7 +-- src/Language/PureScript/CST/Errors.hs | 9 ++-- src/Language/PureScript/CST/Layout.hs | 3 +- src/Language/PureScript/CST/Types.hs | 13 ++++- src/Language/PureScript/Environment.hs | 4 +- src/Language/PureScript/Errors.hs | 8 +-- .../PureScript/TypeClassDictionaries.hs | 2 + 10 files changed, 61 insertions(+), 40 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 1f427755f0..59fdbd7ad4 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -7,6 +7,7 @@ module Language.PureScript.AST.Binders where import Prelude import Control.DeepSeq (NFData) +import Codec.Serialise (Serialise) import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (SourceSpan) import Language.PureScript.AST.Literals (Literal(..)) @@ -64,7 +65,7 @@ data Binder -- A binder with a type annotation -- | TypedBinder SourceType Binder - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing -- the `SourceSpan` values embedded in some of the data constructors of `Binder` diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 7184cbb812..1ec8fdae98 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -50,7 +50,7 @@ data TypeSearch -- ^ Record fields that are available on the first argument to the typed -- hole } - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) @@ -90,7 +90,7 @@ data ErrorMessageHint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) | RelatedPositions (NEL.NonEmpty SourceSpan) - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | Categories of hints data HintCategory @@ -112,7 +112,7 @@ data UnknownsHint = NoUnknowns | Unknowns | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]])) - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | -- A module declaration, consisting of comments about the module, a module name, @@ -323,7 +323,7 @@ data RoleDeclarationData = RoleDeclarationData { rdeclSourceAnn :: !SourceAnn , rdeclIdent :: !(ProperName 'TypeName) , rdeclRoles :: ![Role] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Serialise) -- | A type declaration assigns a type to an identifier, eg: -- @@ -334,7 +334,7 @@ data TypeDeclarationData = TypeDeclarationData { tydeclSourceAnn :: !SourceAnn , tydeclIdent :: !Ident , tydeclType :: !SourceType - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Serialise) getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d @@ -356,7 +356,7 @@ data ValueDeclarationData a = ValueDeclarationData -- ^ Whether or not this value is exported/visible , valdeclBinders :: ![Binder] , valdeclExpression :: !a - } deriving (Show, Functor, Generic, NFData, Foldable, Traversable) + } deriving (Show, Functor, Generic, NFData, Foldable, Traversable, Serialise) getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d @@ -370,7 +370,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration { dataCtorAnn :: !SourceAnn , dataCtorName :: !(ProperName 'ConstructorName) , dataCtorFields :: ![(Ident, SourceType)] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Serialise) mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. } @@ -445,13 +445,13 @@ data Declaration -- declaration, while the second @SourceAnn@ serves as the -- annotation for the type class and its arguments. | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Serialise) data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Serialise) pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op)) @@ -462,7 +462,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T data InstanceDerivationStrategy = KnownClassStrategy | NewtypeStrategy - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | The members of a type class instance declaration data TypeInstanceBody @@ -472,7 +472,7 @@ data TypeInstanceBody -- ^ This is an instance derived from a newtype | ExplicitInstance [Declaration] -- ^ This is a regular (explicit) instance - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -488,7 +488,7 @@ data KindSignatureFor | NewtypeSig | TypeSynonymSig | ClassSig - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Serialise) declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa @@ -625,13 +625,13 @@ flattenDecls = concatMap flattenOne -- data Guard = ConditionGuard Expr | PatternGuard Binder Expr - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | -- The right hand side of a binder in value declarations -- and case expressions. data GuardedExpr = GuardedExpr [Guard] Expr - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) pattern MkUnguarded :: Expr -> GuardedExpr pattern MkUnguarded e = GuardedExpr [] e @@ -762,7 +762,7 @@ data Expr -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | -- Metadata that tells where a let binding originated @@ -776,7 +776,7 @@ data WhereProvenance -- The let binding was always a let binding -- | FromLet - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | -- An alternative in a case statement @@ -790,7 +790,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: [GuardedExpr] - } deriving (Show, Generic, NFData) + } deriving (Show, Generic, NFData, Serialise) -- | -- A statement in a do-notation block @@ -812,7 +812,7 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- For a record update such as: @@ -839,15 +839,16 @@ data DoNotationElement -- newtype PathTree t = PathTree (AssocList PSString (PathNode t)) - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) - deriving newtype NFData + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving newtype (NFData, Serialise) + data PathNode t = Leaf t | Branch (PathTree t) - deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) + deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise) newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } - deriving (Show, Eq, Ord, Foldable, Functor, Traversable) - deriving newtype NFData + deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic) + deriving newtype (NFData, Serialise) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index 05e06ab8f9..ba94757811 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -5,6 +5,7 @@ module Language.PureScript.AST.Literals where import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import GHC.Generics (Generic) import Language.PureScript.PSString (PSString) @@ -38,4 +39,4 @@ data Literal a -- An object literal -- | ObjectLiteral [(PSString, a)] - deriving (Eq, Ord, Show, Functor, Generic, NFData) + deriving (Eq, Ord, Show, Functor, Generic, NFData, Serialise) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index f40cc44e9f..0510b1f20c 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -19,6 +19,7 @@ module Language.PureScript.Bundle import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) @@ -46,14 +47,14 @@ data ErrorMessage | ErrorInModule ModuleIdentifier ErrorMessage | MissingEntryPoint String | MissingMainModule String - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or -- foreign modules. data ModuleType = Regular | Foreign - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) showModuleType :: ModuleType -> String showModuleType Regular = "Regular" @@ -61,7 +62,7 @@ showModuleType Foreign = "Foreign" -- | A module is identified by its module name and its type. data ModuleIdentifier = ModuleIdentifier String ModuleType - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) instance A.ToJSON ModuleIdentifier where toJSON (ModuleIdentifier name mt) = diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 3682f2f0a5..c447d661cc 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -12,9 +12,10 @@ module Language.PureScript.CST.Errors import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) -import Data.Text qualified as Text import Data.Char (isSpace, toUpper) +import Data.Text qualified as Text import GHC.Generics (Generic) import Language.PureScript.CST.Layout (LayoutStack) import Language.PureScript.CST.Print (printToken) @@ -59,7 +60,7 @@ data ParserErrorType | ErrConstraintInForeignImportSyntax | ErrEof | ErrCustom String - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) data ParserWarningType = WarnDeprecatedRowSyntax @@ -67,14 +68,14 @@ data ParserWarningType | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax | WarnDeprecatedCaseOfOffsideSyntax - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) data ParserErrorInfo a = ParserErrorInfo { errRange :: SourceRange , errToks :: [SourceToken] , errStack :: LayoutStack , errType :: a - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Serialise) type ParserError = ParserErrorInfo ParserErrorType type ParserWarning = ParserErrorInfo ParserWarningType diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 2f41df6b4f..bd09ba6b1b 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -171,6 +171,7 @@ module Language.PureScript.CST.Layout where import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.DList (snoc) import Data.DList qualified as DList @@ -204,7 +205,7 @@ data LayoutDelim | LytOf | LytDo | LytAdo - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) isIndented :: LayoutDelim -> Bool isIndented = \case diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..8c400ed5d1 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -10,6 +10,7 @@ module Language.PureScript.CST.Types where import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) @@ -29,14 +30,22 @@ data SourceRange = SourceRange , srcEnd :: !SourcePos } deriving (Show, Eq, Ord, Generic, NFData) +instance Serialise SourcePos +instance Serialise SourceRange + +instance Serialise TokenAnn +instance Serialise SourceStyle +instance Serialise Token +instance Serialise SourceToken + data Comment l = Comment !Text | Space {-# UNPACK #-} !Int | Line !l - deriving (Show, Eq, Ord, Generic, Functor, NFData) + deriving (Show, Eq, Ord, Generic, Functor, NFData, Serialise) data LineFeed = LF | CRLF - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) data TokenAnn = TokenAnn { tokRange :: !SourceRange diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 0c087e9cf1..4346336209 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -48,6 +48,7 @@ data Environment = Environment } deriving (Show, Generic) instance NFData Environment +instance Serialise Environment -- | Information about a type class data TypeClassData = TypeClassData @@ -74,6 +75,7 @@ data TypeClassData = TypeClassData } deriving (Show, Generic) instance NFData TypeClassData +instance Serialise TypeClassData -- | A functional dependency indicates a relationship between two sets of -- type arguments in a class declaration. @@ -137,7 +139,7 @@ makeTypeClassData args m s deps = TypeClassData args m' s deps determinedArgs co coveringSets' = S.toList coveringSets m' = map (\(a, b) -> (a, b, addVtaInfo b)) m - + addVtaInfo :: SourceType -> Maybe (S.Set (NEL.NonEmpty Int)) addVtaInfo memberTy = do let mentionedArgIndexes = S.fromList (mapMaybe argToIndex $ freeTypeVariables memberTy) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..74ad6d609f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -7,6 +7,7 @@ module Language.PureScript.Errors import Prelude import Protolude (unsnoc) +import Codec.Serialise (Serialise) import Control.Arrow ((&&&)) import Control.DeepSeq (NFData) import Control.Lens (both, head1, over) @@ -199,12 +200,12 @@ data SimpleErrorMessage | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool | CannotSkipTypeApplication SourceType | CannotApplyExpressionOfTypeOnType SourceType SourceType - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) newtype ErrorSuggestion = ErrorSuggestion Text @@ -374,7 +375,8 @@ newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] } deriving stock (Show) - deriving newtype (Semigroup, Monoid, NFData) + deriving newtype (Semigroup, Monoid, NFData, Serialise) + -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 593e8c1a8d..64d36c7c6d 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -3,6 +3,7 @@ module Language.PureScript.TypeClassDictionaries where import Prelude import GHC.Generics (Generic) +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Text (Text, pack) @@ -40,6 +41,7 @@ data TypeClassDictionaryInScope v deriving (Show, Functor, Foldable, Traversable, Generic) instance NFData v => NFData (TypeClassDictionaryInScope v) +instance Serialise v => Serialise (TypeClassDictionaryInScope v) type NamedDict = TypeClassDictionaryInScope (Qualified Ident) From a49b44661e7251cb923dbb42c9db2a7a6a7ca6c1 Mon Sep 17 00:00:00 2001 From: Alex Date: Mon, 9 Jun 2025 21:02:57 +0500 Subject: [PATCH 8/8] Cut off update: warnings, build reason, log file --- app/Command/Compile.hs | 14 +- src/Language/PureScript/AST/SourcePos.hs | 3 + src/Language/PureScript/Docs/Collect.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 6 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Make.hs | 284 ++--- src/Language/PureScript/Make/Actions.hs | 203 +++- src/Language/PureScript/Make/BuildPlan.hs | 231 ++-- src/Language/PureScript/Make/Cache.hs | 28 +- src/Language/PureScript/Make/ExternsDiff.hs | 176 ++- src/Language/PureScript/Make/Monad.hs | 17 +- src/Language/PureScript/ModuleDependencies.hs | 33 +- tests/TestMake.hs | 1003 +++++++---------- tests/TestUtils.hs | 2 +- 14 files changed, 1096 insertions(+), 908 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d43338580d..9933b55bab 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -16,12 +16,13 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound) -import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake) +import Language.PureScript.Make (buildMakeActions, inferForeignModules, progressWithFile, printProgress, runMake) import Options.Applicative qualified as Opts import SharedCLI qualified import System.Console.ANSI qualified as ANSI import System.Exit (exitSuccess, exitFailure) -import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import System.IO (hPutStr, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) @@ -68,11 +69,18 @@ compile PSCMakeOptions{..} = do ] exitFailure moduleFiles <- readUTF8FilesT input + + _ <- createDirectoryIfMissing True pscmOutputDir + let logFile = pscmOutputDir "compile.log" + let cleanFile = True + (makeErrors, makeWarnings) <- runMake pscmOpts $ do ms <- CST.parseModulesFromFiles id moduleFiles 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 + logProgress <- progressWithFile logFile cleanFile + let makeActions = (buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix) + { P.progress = (*>) <$> printProgress <*> logProgress } P.make_ makeActions (map snd ms) printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 262d44b6a1..dade61bf39 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -116,3 +116,6 @@ widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) = widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, []) + +replaceSpanName :: String -> SourceSpan -> SourceSpan +replaceSpanName name (SourceSpan _ sps spe) = SourceSpan name sps spe diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index ad538c1ae4..2ef9c85e67 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -96,7 +96,7 @@ compileForDocs outputDir inputFiles = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions outputDir filePathMap foreigns False) - { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for " + { P.progress = liftIO . maybe (pure ()) (TIO.hPutStr stdout . (<> "\n")) . P.renderProgressMessage "documentation for " } P.make makeActions (map snd ms) either throwError return result diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339eb..d6d90b64e7 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -80,7 +80,7 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do - newExterns <- P.rebuildModule makeEnv externs m + newExterns <- P.rebuildModule makeEnv externs (pwarnings, m) unless pureRebuild $ updateCacheDb codegenTargets outputDirectory file actualFile moduleName pure newExterns @@ -166,7 +166,7 @@ rebuildModuleOpen -> m () rebuildModuleOpen makeEnv externs m = void $ runExceptT do (openResult, _) <- liftIO $ P.runMake P.defaultOptions $ - P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m) + P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (mempty, openModuleExports m) case openResult of Left _ -> throwError (GeneralError "Failed when rebuilding with open exports") @@ -183,7 +183,7 @@ shushProgress ma = -- | Stops any kind of codegen shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m shushCodegen ma = - ma { P.codegen = \_ _ _ -> pure () + ma { P.codegen = \_ _ _ _ -> pure () , P.ffiCodegen = \_ -> pure () } diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 5f88b079c3..479c2a0520 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -60,7 +60,7 @@ rebuild -> P.Module -> P.Make (P.ExternsFile, P.Environment) rebuild loadedExterns m = do - externs <- P.rebuildModule buildActions loadedExterns m + externs <- P.rebuildModule buildActions loadedExterns (mempty, m) return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs])) where buildActions :: P.MakeActions P.Make diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 55a17d3468..14a5bfdc33 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,7 +1,10 @@ module Language.PureScript.Make ( make , make_ + , make' + , MakeOptions(..) , rebuildModule + -- Exported for external use (trypurescript) #4095 , rebuildModule' , inferForeignModules , module Monad @@ -12,64 +15,45 @@ import Prelude import Control.Concurrent.Lifted as C import Control.DeepSeq (force) -import Control.Exception.Lifted (onException, bracket_, evaluate) -import Control.Monad (foldM, unless, void, when, (<=<)) -import Control.Monad.Base (MonadBase(liftBase)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) +import Control.Exception.Lifted (bracket_, evaluate, onException) +import Control.Monad ( foldM, unless, void, when, (<=<)) +import Control.Monad.Base (MonadBase (liftBase)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT) -import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.State (runStateT) -import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.Writer.Class (MonadWriter (..), censor) import Control.Monad.Writer.Strict (runWriterT) -import Data.Function (on) import Data.Foldable (fold, for_) +import Data.Function (on) import Data.List (foldl', sortOn) import Data.List.NonEmpty qualified as NEL -import Data.Maybe (fromMaybe, mapMaybe) import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) import Data.Set qualified as S import Data.Text qualified as T +import Data.Time (diffUTCTime) import Debug.Trace (traceMarkerIO) -import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) -import Language.PureScript.Crash (internalError) +import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim) import Language.PureScript.CST qualified as CST +import Language.PureScript.CoreFn qualified as CF +import Language.PureScript.Crash (internalError) import Language.PureScript.Docs.Convert qualified as Docs import Language.PureScript.Environment (initEnvironment) -import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Errors (MultipleErrors (..), SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) -import Language.PureScript.Linter (Name(..), lint, lintImports) -import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) -import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName) -import Language.PureScript.Renamer (renameInModule) -import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) -import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) -import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult, isUpToDate) -import Language.PureScript.Make.BuildPlan qualified as BuildPlan -import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) -import Language.PureScript.Make.Cache qualified as Cache +import Language.PureScript.Linter (Name (..), lint, lintImports) import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult) +import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.ExternsDiff qualified as ED import Language.PureScript.Make.Monad as Monad - ( Make(..), - writeTextFile, - writeJSONFile, - writeCborFileIO, - writeCborFile, - setTimestamp, - runMake, - readTextFile, - readJSONFileIO, - readJSONFile, - readExternsFile, - readCborFileIO, - readCborFile, - makeIO, - hashFile, - getTimestampMaybe, - getTimestamp, - getCurrentTime, - copyFile ) -import Language.PureScript.CoreFn qualified as CF +import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules') +import Language.PureScript.Names (ModuleName (..), isBuiltinModuleName, runModuleName) +import Language.PureScript.Renamer (renameInModule) +import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) +import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule) import System.Directory (doesFileExist) import System.FilePath (replaceExtension) @@ -80,7 +64,7 @@ rebuildModule . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] - -> Module + -> ([CST.ParserWarning], Module) -> m ExternsFile rebuildModule actions externs m = do env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs @@ -92,31 +76,25 @@ rebuildModule' => MakeActions m -> Env -> [ExternsFile] - -> Module + -> ([CST.ParserWarning], Module) + -- ^ Parser warnings to save them while codegen. -> m ExternsFile -rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing - -rebuildModuleWithIndex - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> Env - -> [ExternsFile] - -> Module - -> Maybe (Int, Int) - -> m ExternsFile -rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do - progress $ CompilingModule moduleName moduleIndex +rebuildModule' MakeActions{..} exEnv externs (pwarnings, m@(Module _ _ moduleName _ _)) = do let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m - lint withPrim - ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do + (_, lintWarns) <- listen $ lint withPrim + + (((Module ss coms _ elaborated exps, env'), nextVar), checkWarns) <- listen $ runSupplyT 0 $ do (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) + let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' + (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env + let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible + -- Imports cannot be linted before type checking because we need to -- known which newtype constructors are used to solve Coercible -- constraints in order to not report them as unused. @@ -135,6 +113,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized exts = moduleToExternsFile mod' env' renamedIdents + ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, @@ -144,13 +123,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- a bug in the compiler, which should be reported as such. -- 2. We do not want to perform any extra work generating docs unless the -- user has asked for docs to be generated. - let docs = case Docs.convertModule externs exEnv env' m of + + let docs = case Docs.convertModule externs exEnv env' withPrim of Left errs -> internalError $ "Failed to produce docs for " ++ T.unpack (runModuleName moduleName) ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs Right d -> d - evalSupplyT nextVar'' $ codegen renamed docs exts + -- We may use empty filePath here, as we still remove it while codegen. + let parseWarns = CST.toMultipleWarnings "" pwarnings + + evalSupplyT nextVar'' $ codegen renamed docs exts (parseWarns <> lintWarns <> checkWarns) return exts data MakeOptions = MakeOptions @@ -190,7 +173,8 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do checkModuleNames cacheDb <- readCacheDb - (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms + (sorted, graph) <- sortModules' Transitive (moduleSignature . CST.resPartial) ms + let opts = BuildPlan.Options {optPreloadAllExterns = moCollectAllExterns} (buildPlan, newCacheDb) <- BuildPlan.construct opts ma cacheDb (sorted, graph) @@ -206,34 +190,45 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do 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 let moduleName = getModuleName . CST.resPartial $ m let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) + let directDeps = S.fromList $ map snd $ filter ((==) Direct . fst) deps buildModule lock buildPlan moduleName totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) - (deps `inOrderOf` sortedModuleNames) + (map snd deps `inOrderOf` sortedModuleNames) + (flip S.member directDeps) -- Prevent hanging on other modules when there is an internal error -- (the exception is thrown, but other threads waiting on MVars are released) `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) -- Wait for all threads to complete, and collect results (and errors). - (failures, successes) <- + (failures, successes') <- let splitResults = \case - BuildJobSucceeded _ exts _ -> - Right exts + BuildJobSucceeded _ warns exts _ -> + Right (exts, warns) BuildJobFailed errs -> Left errs BuildJobSkipped -> Left mempty in - M.mapEither splitResults <$> BuildPlan.collectResults buildPlan + M.mapEither splitResults <$> BuildPlan.collectResults buildPlan moCollectAllExterns - -- Write the updated build cache database to disk - writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb + let successes = fmap fst successes' + let warnings = foldMap snd successes' + -- Tell prebuilt warnings. + tell warnings + + -- Write the updated build cache database to disk. There is not need to remove + -- failed modules and their deps from cache-db as on the next run we may have + -- fixed failed modules (without any changes from previously compiled or ` with + -- externs diffs that will not require rebuild of deps). + writeCacheDb newCacheDb writePackageJson @@ -287,82 +282,97 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do - result <- flip catchError (return . BuildJobFailed) $ do - let pwarnings' = CST.toMultipleWarnings fp pwarnings - tell pwarnings' + buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> (ModuleName -> Bool) -> m () + buildModule lock buildPlan moduleName cnt fp pwarnings mres deps isDirect = do + idx <- C.takeMVar (bpIndex buildPlan) + C.putMVar (bpIndex buildPlan) (idx + 1) + + let moduleIndex = Just (idx, cnt) + let onFailure errs = do + progress $ ModuleFailed moduleName moduleIndex errs + pure $ BuildJobFailed errs + + result <- flip catchError onFailure $ do m <- CST.unwrapParserError fp mres - -- We need to wait for dependencies to be built, before checking if the current - -- module should be rebuilt, so the first thing to do is to wait on the - -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps - - case mexterns of - Just (_, depsDiffExterns) -> do - let externs = fst <$> depsDiffExterns - let prevResult = BuildPlan.getPrevResult buildPlan moduleName - let depsDiffs = traverse snd depsDiffExterns - let maySkipBuild moduleIndex - -- We may skip built only for up-to-date modules. - | Just (status, exts) <- prevResult - , isUpToDate status - -- Check if no dep's externs have changed. If any of the diffs - -- is Nothing means we can not check and need to rebuild. - , Just False <- checkDiffs m <$> depsDiffs = do - -- We should update modification times to mark existing - -- 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 - if updated then do - progress $ SkippingModule moduleName moduleIndex - pure $ Just (exts, MultipleErrors [], Just (emptyDiff moduleName)) - else - pure Nothing - | otherwise = pure Nothing - - -- We need to ensure that all dependencies have been included in Env. - C.modifyMVar_ (bpEnv buildPlan) $ \env -> do - let - go :: Env -> ModuleName -> m Env - go e dep = case lookup dep (zip deps externs) of - Just exts - | not (M.member dep e) -> externsEnv e exts - _ -> return e - foldM go env deps - env <- C.readMVar (bpEnv buildPlan) - idx <- C.takeMVar (bpIndex buildPlan) - C.putMVar (bpIndex buildPlan) (idx + 1) - - (exts, warnings, diff) <- do - let doBuild = do - -- Bracket all of the per-module work behind the semaphore, including - -- forcing the result. This is done to limit concurrency and keep - -- memory usage down; see comments above. - (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do - -- Eventlog markers for profiling; see debug/eventlog.js - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" - -- Force the externs and warnings to avoid retaining excess module - -- data after the module is finished compiling. - extsAndWarnings <- evaluate . force <=< listen $ do - rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" - return extsAndWarnings - let diff = diffExterns exts <$> (snd <$> prevResult) <*> depsDiffs - pure (exts, warnings, diff) - maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure - return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff + -- We need to wait for dependencies to be built, before checking if the + -- current module should be rebuilt, so the first thing to do is to wait + -- on the MVars for the module's dependencies. + -- + -- The result wil contain externs and externs diffs to check against if + -- the build is needed. + + depsExts <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps + let prevResult = BuildPlan.getPrevResult buildPlan moduleName + + case depsExts of -- If we got Nothing for deps externs, that means one of the deps failed -- to compile. Though if we have a previous built result we will keep to -- avoid potentially unnecessary recompilation next time. - Nothing -> return $ - case BuildPlan.getPrevResult buildPlan moduleName of - Just (_, exts) -> - BuildJobSucceeded (MultipleErrors []) exts (Just (emptyDiff moduleName)) + Nothing -> pure $ case prevResult of + Just (exts, warnings) -> do + -- Previously built warnings already contain parser warnings. + BuildJobSucceeded Nothing warnings exts (Just (ED.emptyDiff moduleName)) Nothing -> BuildJobSkipped + Just (externs, mbDiffs) -> do + -- If any of deps returns Nothing for diff, means it had no previous result. + -- Also only diffs of direct deps are needed. + let depsDiffs = filter (isDirect . ED.edModuleName) <$> sequenceA mbDiffs + + (br, warnings, exts, diff) <- do + -- Get the reason for building or skipping the compilation. + case BuildPlan.getBuildReason buildPlan m depsDiffs of + -- No rebuild reason skipping the module. + Left (exts, warnings) -> do + _ <- updateOutputTimestamp moduleName Nothing + progress $ SkippingModule moduleName (Just (idx, cnt)) + -- Prebuilt result warnings already contain parser warnings. + pure (Nothing, warnings, exts, Just (ED.emptyDiff moduleName)) + + Right br -> do + start <- liftBase getCurrentTime + -- We need to ensure that all dependencies have been included in Env. + C.modifyMVar_ (bpEnv buildPlan) $ \env -> do + let + go :: Env -> ModuleName -> m Env + go e dep = case lookup dep (zip deps externs) of + Just exts + | not (M.member dep e) -> externsEnv e exts + _ -> return e + foldM go env deps + env <- C.readMVar (bpEnv buildPlan) + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + progress $ CompilingModule moduleName moduleIndex br + rebuildModule' ma env externs (pwarnings, m) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + -- Add parser warnings. + let pwarnings' = CST.toMultipleWarnings fp pwarnings + tell pwarnings' + return ((<>) pwarnings' <$> extsAndWarnings) + -- Find externs diff of new and previous build results. + let diff = ED.diffExterns <$> depsDiffs <*> Just exts <*> (fst <$> prevResult) + + end <- liftBase getCurrentTime + + let timeDiff = diffUTCTime end start + progress $ ModuleCompiled moduleName moduleIndex timeDiff diff warnings + + -- Do not put warnings in job result because they are already told. + pure (Just br, mempty, exts, diff) + + pure $ BuildJobSucceeded br warnings exts diff + BuildPlan.markComplete buildPlan moduleName result -- | Infer the module name for a module by looking for the same filename with diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 6774457ac5..2e5c41c5ff 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -1,9 +1,13 @@ module Language.PureScript.Make.Actions ( MakeActions(..) , RebuildPolicy(..) + , RebuildReason(..) , ProgressMessage(..) , renderProgressMessage + , printProgress + , progressWithFile , buildMakeActions + , makeOutputFilename , checkForeignDecls , cacheDbFile , readCacheDb' @@ -13,7 +17,7 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Monad (guard, unless, when) +import Control.Monad (guard, unless, void, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (asks) @@ -31,7 +35,8 @@ import Data.Set qualified as S import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Text.Encoding qualified as TE -import Data.Time.Clock (UTCTime) +import Data.Time (formatTime, defaultTimeLocale) +import Data.Time.Clock (UTCTime, NominalDiffTime) import Data.Version (showVersion) import Language.JavaScript.Parser qualified as JS import Language.PureScript.AST (SourcePos(..)) @@ -44,10 +49,11 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Prim qualified as Docs.Prim import Language.PureScript.Docs.Types qualified as Docs -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', nonEmpty, ErrorMessage (..), onErrorMessages, replaceSpanName, runMultipleErrors) import Language.PureScript.Externs (ExternsFile, externsFileName) -import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile) +import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readWarningsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile, removeFileIfExists) import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVersion, fromCacheDbVersioned, normaliseForCache, toCacheDbVersioned) +import Language.PureScript.Make.ExternsDiff qualified as ED import Language.PureScript.Names (Ident(..), ModuleName, runModuleName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.Pretty.Common (SMap(..)) @@ -57,7 +63,12 @@ import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..)) import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix -import System.IO (stderr) +import System.IO (stderr, IOMode (..)) +import Language.PureScript.AST.Declarations (ErrorMessageHint(..)) +import Control.Concurrent.Lifted (newMVar, putMVar, takeMVar) +import GHC.IO.StdHandles (withFile) +import GHC.IO.Handle (hFlush) +import Numeric (showFFloat) -- | Determines when to rebuild a module data RebuildPolicy @@ -65,39 +76,102 @@ data RebuildPolicy = RebuildNever -- | Always rebuild this module | RebuildAlways + deriving (Show, Ord, Eq) + +-- | Specifies reason for module compilation while incremental build. +data RebuildReason + -- | Compiled because of RebuildAlways policy + = RebuildAlwaysPolicy + -- | Compiled because of no previously built result available + | NoCached + -- | Compiled because of no previously built result for one of dependencies is available. + | NoCachedDependency + -- | Compiled because the module has changed since its previous compilation. + | CacheOutdated + -- | Compiled because has later dependency (that previously has been built after the module). + | LaterDependency ModuleName + -- | Compiled because of (the first found) changed reference in a dependency. + | UpstreamRef ED.DiffRef deriving (Show, Eq, Ord) -- | Progress messages from the make process data ProgressMessage - = CompilingModule ModuleName (Maybe (Int, Int)) + = CompilingModule ModuleName (Maybe (Int, Int)) RebuildReason -- ^ Compilation started for the specified module | SkippingModule ModuleName (Maybe (Int, Int)) - deriving (Show, Eq, Ord) + | ModuleCompiled ModuleName (Maybe (Int, Int)) NominalDiffTime (Maybe ED.ExternsDiff) MultipleErrors + | ModuleFailed ModuleName (Maybe (Int, Int)) MultipleErrors + deriving (Show) --- | Render a progress message -renderProgressMessage :: T.Text -> ProgressMessage -> T.Text -renderProgressMessage infx msg = case msg of - CompilingModule mn mi -> +renderProgressIndex :: Maybe (Int, Int) -> T.Text +renderProgressIndex = maybe "" $ \(start, end) -> + let start' = T.pack (show start) + end' = T.pack (show end) + preSpace = T.replicate (T.length end' - T.length start') " " + in "[" <> preSpace <> start' <> " of " <> end' <> "] " + +sSuffix :: Int -> T.Text +sSuffix n = if n > 1 then "s" else "" + +renderProgressVerboseMessage :: T.Text -> ProgressMessage -> T.Text +renderProgressVerboseMessage infx msg = case msg of + CompilingModule mn mi br -> T.concat [ renderProgressIndex mi , "Compiling " , infx , runModuleName mn + , (flip (<>) ")" . (<>) " (rebuild reason: " . T.pack . show) br ] SkippingModule mn mi -> T.concat - [renderProgressIndex mi + [ renderProgressIndex mi , "Skipping " , infx , runModuleName mn ] - where - renderProgressIndex :: Maybe (Int, Int) -> T.Text - renderProgressIndex = maybe "" $ \(start, end) -> - let start' = T.pack (show start) - end' = T.pack (show end) - preSpace = T.replicate (T.length end' - T.length start') " " - in "[" <> preSpace <> start' <> " of " <> end' <> "] " + ModuleCompiled mn mi time extDiff warnings -> + T.concat + [ renderProgressIndex mi + , "Compiled " + , infx + , runModuleName mn + , " in " <> (T.pack . toMs) time <> " ms" + , if nonEmpty warnings + then + " with " + <> (T.pack . show) wLen + <> " warning" + <> sSuffix wLen + else "" + , maybe "" (flip (<>) ")" . (<>) " (changed refs: " . T.pack . show . ED.edRefs) extDiff + ] + where + wLen = length $ runMultipleErrors warnings + toMs ndt = showFFloat (Just 3) (realToFrac ndt * 1000 :: Double) "" + ModuleFailed mn mi errors -> + T.concat + [ renderProgressIndex mi + , "Failed to compile " + , infx + , runModuleName mn + , " with " <> (T.pack . show) eLen <> " error" <> sSuffix eLen + ] + where + eLen = length $ runMultipleErrors errors + +-- | Render a progress message +-- infix in used, i.g in docs generation. +renderProgressMessage :: T.Text -> ProgressMessage -> Maybe T.Text +renderProgressMessage infx msg = case msg of + CompilingModule mn mi _ -> + Just $ T.concat + [ renderProgressIndex mi + , "Compiling " + , infx + , runModuleName mn + ] + _ -> Nothing -- | Actions that require implementations when running in "make" mode. -- @@ -119,13 +193,17 @@ data MakeActions m = MakeActions -- externs file, or if any of the requested codegen targets were not produced -- the last time this module was compiled, this function must return Nothing; -- this indicates that the module will have to be recompiled. - , updateOutputTimestamp :: ModuleName -> m Bool + , updateOutputTimestamp :: ModuleName -> Maybe UTCTime -> m Bool -- ^ Updates the modification time of existing output files to mark them as -- actual. , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m () + , readWarnings :: (ModuleName, FilePath) -> m (FilePath, Maybe MultipleErrors) + -- ^ Read the file with cached warnings for a module and also return the + -- actual path for the warnings file. It also requires module's filePath to place + -- it in source spans to personalize warnings. + , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> MultipleErrors -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , ffiCodegen :: CF.Module CF.Ann -> m () -- ^ Check ffi and print it in the output directory. @@ -149,6 +227,20 @@ data MakeActions m = MakeActions cacheDbFile :: FilePath -> FilePath cacheDbFile = ( "cache-db.json") +warningsFileName :: FilePath +warningsFileName = "warnings.cbor" + +replaceSpanNameInErrors :: FilePath -> MultipleErrors -> MultipleErrors +replaceSpanNameInErrors fp = + onErrorMessages replace + where + replaceSpan = replaceSpanName fp + replaceHint = \case + PositionedError ss -> PositionedError (replaceSpan <$> ss) + RelatedPositions ss -> RelatedPositions (replaceSpan <$> ss) + h -> h + replace (ErrorMessage hints e) = ErrorMessage (replaceHint <$> hints) e + readCacheDb' :: (MonadIO m, MonadError MultipleErrors m) => FilePath @@ -179,6 +271,40 @@ writePackageJson' outputDir = writeJSONFile (outputDir "package.json") $ obj [ "type" .= String "module" ] +makeOutputFilename :: FilePath -> ModuleName -> String -> FilePath +makeOutputFilename outputDir mn fn = + let filePath = T.unpack (runModuleName mn) + in outputDir filePath fn + +printProgress :: ProgressMessage -> Make () +printProgress = liftIO . maybe (pure ()) (TIO.hPutStr stderr . (<> "\n")) . renderProgressMessage "" + +toLogTime :: UTCTime -> T.Text +toLogTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S.%3q" + +withLogTime :: UTCTime -> T.Text -> T.Text +withLogTime time = + (<>) (toLogTime time <> " - ") + +progressWithFile :: FilePath -> Bool -> Make (ProgressMessage -> Make()) +progressWithFile logFilePath cleanFile = do + lock <- newMVar () + let mode = if cleanFile then WriteMode else AppendMode + curTime <- getCurrentTime + let initMsg = "Starting new build" + liftIO $ withFile logFilePath mode $ \handle -> + TIO.hPutStrLn handle (withLogTime curTime initMsg) + pure (logToFile lock) + where + logToFile lock pm = void $ liftIO $ do + takeMVar lock + curTime <- getCurrentTime + let msg = withLogTime curTime (renderProgressVerboseMessage "" pm) + liftIO $ withFile logFilePath AppendMode $ \handle -> do + TIO.hPutStrLn handle msg + hFlush handle + putMVar lock () + -- | A set of make actions that read and write modules from the given directory. buildMakeActions :: FilePath @@ -196,6 +322,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp updateOutputTimestamp readExterns + readWarnings codegen ffiCodegen progress @@ -223,9 +350,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = return $ Right $ M.fromList pathsWithInfo outputFilename :: ModuleName -> String -> FilePath - outputFilename mn fn = - let filePath = T.unpack (runModuleName mn) - in outputDir filePath fn + outputFilename = makeOutputFilename outputDir targetFilename :: ModuleName -> CodegenTarget -> FilePath targetFilename mn = \case @@ -262,16 +387,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = then Just externsTimestamp else Nothing - updateOutputTimestamp :: ModuleName -> Make Bool - updateOutputTimestamp mn = do - curTime <- getCurrentTime + updateOutputTimestamp :: ModuleName -> Maybe UTCTime -> Make Bool + updateOutputTimestamp mn mbTime = do + curTime <- maybe getCurrentTime pure mbTime ok <- setTimestamp (outputFilename mn externsFileName) curTime - -- Then update timestamps of all actual codegen targets. + _ <- setTimestamp (outputFilename mn warningsFileName) curTime + -- then update 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 (any of targets doesn't exit, a file system - -- error), return False. + -- if something goes wrong, something failed to update, return Nothing pure $ and (ok : results) readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) @@ -279,16 +404,27 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let path = outputDir T.unpack (runModuleName mn) externsFileName (path, ) <$> readExternsFile path + readWarnings :: (ModuleName, FilePath) -> Make (FilePath, Maybe MultipleErrors) + readWarnings (mn, fp) = do + let path = outputDir T.unpack (runModuleName mn) warningsFileName + (path, ) . fmap (replaceSpanNameInErrors fp) <$> readWarningsFile path + outputPrimDocs :: Make () outputPrimDocs = do codegenTargets <- asks optionsCodegenTargets when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} -> writeJSONFile (outputFilename modName "docs.json") docsMod - codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () - codegen m docs exts = do + codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> MultipleErrors -> SupplyT Make () + codegen m docs exts warnings = do let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts + let warningsFile = outputFilename mn warningsFileName + lift $ if nonEmpty warnings then + -- Remove spanName from the errors + writeCborFile warningsFile (replaceSpanNameInErrors "" warnings) + else + removeFileIfExists warningsFile codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn @@ -354,7 +490,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "" + progress msg = do + printProgress msg readCacheDb :: Make CacheDb readCacheDb = readCacheDb' outputDir diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 21a221f55f..72a6aae980 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -2,7 +2,7 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) , Options(..) - , isUpToDate + , getBuildReason , construct , getResult , getPrevResult @@ -15,79 +15,77 @@ import Prelude import Control.Concurrent.Async.Lifted qualified as A import Control.Concurrent.Lifted qualified as C -import Control.Monad.Base (liftBase) import Control.Monad (foldM, guard) -import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Base (liftBase) +import Control.Monad.Trans.Control (MonadBaseControl (..)) import Data.Foldable (foldl') +import Data.Function (on) +import Data.List (maximumBy) import Data.Map qualified as M -import Data.Maybe (fromMaybe, isNothing, catMaybes) +import Data.Maybe (catMaybes, fromMaybe, isNothing) import Data.Set qualified as S import Data.Text qualified as T import Data.Time.Clock (UTCTime) -import Language.PureScript.AST (Module, getModuleName) -import Language.PureScript.Crash (internalError) +import Language.PureScript.AST (Module, getModuleName, getModuleSourceSpan, spanName) import Language.PureScript.CST qualified as CST -import Language.PureScript.Errors (MultipleErrors(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors (..)) import Language.PureScript.Externs (ExternsFile) -import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Actions (MakeActions (..), RebuildPolicy (..), RebuildReason (..)) import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged) -import Language.PureScript.Make.ExternsDiff (ExternsDiff, emptyDiff) +import Language.PureScript.Make.ExternsDiff (ExternsDiff, checkDiffs, emptyDiff) +import Language.PureScript.ModuleDependencies (ModuleGraph', DependencyDepth (..)) import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) - --- This status tells if a module's exiting build artifacts are up to date with a --- current module's content. It would be safe to re-use them, but only if --- changes in its dependencies do require the module's rebuild. -newtype UpToDateStatus = UpToDateStatus Bool - -isUpToDate :: UpToDateStatus -> Bool -isUpToDate (UpToDateStatus b) = b +import Control.Applicative ((<|>)) data Prebuilt = Prebuilt - { pbExternsFile :: ExternsFile + { pbExterns :: ExternsFile + , pbWarnings :: MultipleErrors } -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt - -- ^ Valid prebuilt results for modules, that are needed for rebuild, but - -- their rebuild is not required. - , bpPreviousBuilt :: M.Map ModuleName (UpToDateStatus, Prebuilt) - -- ^ Previously built results for modules that are potentially required to be - -- rebuilt. We will always rebuild not up to date modules. But we will only - -- rebuild up to date modules, if their deps' externs have effectively - -- changed. Previously built result is needed to compare previous and newly - -- built externs to know what have changed. + -- ^ Valid prebuilt results for modules (rebuild it not required), that are + -- needed for rebuild. + , bpPrevious :: M.Map ModuleName (Maybe RebuildReason, Prebuilt) + -- ^ Modules with available previously compiled results that may need to be + -- re-compiled (if upstream effectively changed). If rebuild reason is known + -- in advance (CacheOutdated, LaterDependency), the module will be rebuilt + -- anyway, otherwise will be checked against deps for effective changes. + , bpNoPrevious :: M.Map ModuleName RebuildReason + -- ^ Modules with no previously built results that have to be rebuilt. , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int } - newtype BuildJob = BuildJob { bjResult :: C.MVar BuildJobResult -- ^ Note: an empty MVar indicates that the build job has not yet finished. } data BuildJobResult - = BuildJobSucceeded !MultipleErrors !ExternsFile (Maybe ExternsDiff) - -- ^ Succeeded, with warnings and externs, also holds externs diff with - -- previous build result if any (lazily evaluated). + = BuildJobSucceeded (Maybe RebuildReason) !MultipleErrors !ExternsFile (Maybe ExternsDiff) + -- ^ Succeeded, with warnings and externs, also holds (lazily evaluated) + -- externs diff with previous build result if there was one. -- | BuildJobFailed !MultipleErrors -- ^ Failed, with errors. - + -- | BuildJobSkipped -- ^ The build job was not run, because an upstream build job failed. -type SuccessResult = (MultipleErrors, (ExternsFile, Maybe ExternsDiff)) - -buildJobSuccess :: BuildJobResult -> Maybe SuccessResult -buildJobSuccess (BuildJobSucceeded warnings externs diff) = Just (warnings, (externs, diff)) +buildJobSuccess :: BuildJobResult -> Maybe (ExternsFile, Maybe ExternsDiff) +buildJobSuccess (BuildJobSucceeded _ _ externs diff) = Just (externs, diff) buildJobSuccess _ = Nothing +-- Just a wrapper to make it clear what this time is about. +newtype OutputTimestamp = OutputTimestamp UTCTime deriving (Eq, Ord, Show) + -- | Information obtained about a particular module while constructing a build -- plan; used to decide whether a module needs rebuilding. data RebuildStatus = RebuildStatus @@ -98,12 +96,12 @@ data RebuildStatus = RebuildStatus -- 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. - , rsPrebuilt :: Maybe UTCTime + , rsPrevious :: Maybe OutputTimestamp -- ^ Prebuilt timestamp (compilation time) for this module. , rsUpToDate :: Bool -- ^ Whether or not module (timestamp or content) changed since previous -- compilation (checked against provided cache-db info). - } + } deriving Show -- | Construct common error message indicating a bug in the internal logic barrierError :: T.Text -> a @@ -132,13 +130,15 @@ needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp) collectResults :: (MonadBaseControl IO m) => BuildPlan + -> Bool -> m (M.Map ModuleName BuildJobResult) -collectResults buildPlan = do - let mapExts exts = BuildJobSucceeded (MultipleErrors []) exts Nothing +collectResults buildPlan withPrebuilt = do + let mapExts pb = BuildJobSucceeded Nothing (pbWarnings pb) (pbExterns pb) Nothing let prebuiltResults = - M.map (mapExts . pbExternsFile) (bpPrebuilt buildPlan) + M.map mapExts (bpPrebuilt buildPlan) + barrierResults <- traverse (C.readMVar . bjResult) $ bpBuildJobs buildPlan - pure (M.union prebuiltResults barrierResults) + pure $ if withPrebuilt then M.union prebuiltResults barrierResults else barrierResults -- | Gets the the build result for a given module name independent of whether it -- was rebuilt or prebuilt. Prebuilt modules always return no warnings. @@ -146,27 +146,48 @@ getResult :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> m (Maybe SuccessResult) + -> m (Maybe (ExternsFile, Maybe ExternsDiff)) getResult buildPlan moduleName = case M.lookup moduleName (bpBuildJobs buildPlan) of Just bj -> buildJobSuccess <$> C.readMVar (bjResult bj) + -- If not build job for modules means it has prebuilt results. Nothing -> do - let exts = pbExternsFile + let exts = pbExterns $ fromMaybe (barrierError "getResult") $ M.lookup moduleName (bpPrebuilt buildPlan) - pure (Just (MultipleErrors [], (exts, Just $ emptyDiff moduleName ))) + pure (Just (exts, Just $ emptyDiff moduleName )) -- | Gets preloaded previous built result for modules that are going to be built. This -- will be used to skip compilation if dep's externs have not changed. -getPrevResult :: BuildPlan -> ModuleName -> Maybe (UpToDateStatus, ExternsFile) +getPrevResult :: BuildPlan -> ModuleName -> Maybe (ExternsFile, MultipleErrors) getPrevResult buildPlan moduleName = - fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) + (,) <$> pbExterns <*> pbWarnings <$> snd <$> M.lookup moduleName (bpPrevious buildPlan) + +-- Get the build reason. +getBuildReason :: BuildPlan -> Module -> Maybe [ExternsDiff] -> Either (ExternsFile, MultipleErrors) RebuildReason +getBuildReason (BuildPlan {..}) m depsDiffs + -- This should be refactored. + | Nothing <- depsDiffs = Right NoCachedDependency + | Just (Just reason, _) <- prevResult = Right reason + | Just (Nothing, exts) <- prevResult = + case checkDiffs m <$> depsDiffs of + Just (Just diffRef) -> Right (UpstreamRef diffRef) + (Just Nothing) -> Left (pbExterns exts, pbWarnings exts) + Nothing -> Right NoCachedDependency + | otherwise = Right $ fromMaybe (barrierError "getBuildReason") (M.lookup mn bpNoPrevious) + + where + prevResult = M.lookup mn bpPrevious + mn = getModuleName m data Options = Options { optPreloadAllExterns :: Bool } +type RebuildMap = M.Map ModuleName (Maybe RebuildReason, Maybe OutputTimestamp) +type PrebuiltMap = M.Map ModuleName OutputTimestamp + -- | Constructs a BuildPlan for the given module graph. -- -- The given MakeActions are used to collect various timestamps in order to @@ -176,12 +197,11 @@ construct => Options -> MakeActions m -> CacheDb - -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) + -> ([CST.PartialResult Module], ModuleGraph') -> m (BuildPlan, CacheDb) construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do - let sortedModuleNames = map (getModuleName . CST.resPartial) sorted + let sortedModuleNames = map getMName sorted rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus - -- Split modules into those that have to be rebuilt and those that have a valid -- prebuilt input. The Bool value in rebuildMap means if we may skip the -- compilation (if externs of dependencies have not changed). If it is False we @@ -195,7 +215,7 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do let allBuildDeps = S.unions (S.fromList . moduleDeps <$> toBeRebuilt) let inBuildDeps = flip S.member allBuildDeps - -- We only need prebuilt results for deps of the modules to be build. + -- We only need prebuilt results for deps will be required during the build. let toLoadPrebuilt = if optPreloadAllExterns then prebuiltMap @@ -205,20 +225,25 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do -- to skip rebuilding if deps have not changed. let toLoadPrev = M.mapMaybeWithKey - ( \mn prev -> do + ( \mn (mbRebuildReason, mbTs) -> do -- We load previous build result for all up-to-date modules, and - -- also for changed modules that have dependants. - status <- fst <$> prev - guard (isUpToDate status || inBuildDeps mn) - prev + -- also for changed modules that have dependants (to get diffs). + -- We don't load for those who have no dependencies, because diffs + -- will not be needed. + ts <- mbTs + guard (isNothing mbRebuildReason || inBuildDeps mn) + pure (mbRebuildReason, ts) ) rebuildMap + -- Store known build reasons for modules that do not have actual prebuilt. + let noPrebuilt = M.mapMaybe id $ fst <$> M.difference rebuildMap toLoadPrev + (prebuiltLoad, prevLoad) <- A.concurrently - (A.mapConcurrently id $ M.mapWithKey loadPrebuilt toLoadPrebuilt) + (A.mapConcurrently id $ M.mapWithKey loadPrevious toLoadPrebuilt) (A.mapConcurrently id $ M.mapWithKey - (\mn (up, ts) -> fmap (up,) <$> loadPrebuilt mn ts) toLoadPrev) + (\mn (up, ts) -> fmap (up,) <$> loadPrevious mn ts) toLoadPrev) let prebuilt = M.mapMaybe id prebuiltLoad let previous = M.mapMaybe id prevLoad @@ -231,7 +256,7 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do env <- C.newMVar primEnv idx <- C.newMVar 1 pure - ( BuildPlan prebuilt previous buildJobs env idx + ( BuildPlan prebuilt previous noPrebuilt buildJobs env idx , let update = flip $ \s -> M.alter (const (rsNewCacheInfo s)) (rsModuleName s) @@ -239,10 +264,27 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do foldl' update cacheDb rebuildStatuses ) where + getMName = getModuleName . CST.resPartial + getSpName = spanName . getModuleSourceSpan . CST.resPartial + + -- Module to FilePath map used for loading prebuilt warnings. + fpMap = M.fromList $ (,) <$> getMName <*> getSpName <$> sorted + -- 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 + loadPrevious :: ModuleName -> OutputTimestamp -> m (Maybe Prebuilt) + loadPrevious mn _ = do + externs <- snd <$> readExterns mn + case externs of + Just exts -> do + warnings <- fromMaybe (MultipleErrors []) <$> + case M.lookup mn fpMap of + Just fp -> snd <$> readWarnings (mn, fp) + _ -> pure Nothing + pure $ Just $ Prebuilt exts warnings + _ -> + pure Nothing + makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar @@ -253,69 +295,84 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do inputInfo <- getInputTimestampsAndHashes moduleName case inputInfo of Left RebuildNever -> do - timestamp <- getOutputTimestamp moduleName + timestamp <- fmap OutputTimestamp <$> getOutputTimestamp moduleName pure (RebuildStatus { rsModuleName = moduleName , rsRebuildNever = True - , rsPrebuilt = timestamp - , rsUpToDate = True + -- rsRebuildReason: Nothing -- if not prebuilt? + , rsPrevious = timestamp , rsNewCacheInfo = Nothing + , rsUpToDate = True }) Left RebuildAlways -> do pure (RebuildStatus { rsModuleName = moduleName , rsRebuildNever = False - , rsPrebuilt = Nothing - , rsUpToDate = False + , rsPrevious = Nothing , rsNewCacheInfo = Nothing + , rsUpToDate = False }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory (newCacheInfo, upToDate) <- checkChanged cacheDb moduleName cwd cacheInfo - timestamp <- getOutputTimestamp moduleName + timestamp <- fmap OutputTimestamp <$> getOutputTimestamp moduleName + pure (RebuildStatus { rsModuleName = moduleName , rsRebuildNever = False - , rsPrebuilt = timestamp - , rsUpToDate = upToDate + , rsPrevious = timestamp , rsNewCacheInfo = Just newCacheInfo + , rsUpToDate = upToDate }) - moduleDeps = fromMaybe graphError . flip lookup graph + moduleDeps = map snd . fromMaybe graphError . flip lookup graph where graphError = internalError "make: module not found in dependency graph." - splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (UpToDateStatus, UTCTime)), M.Map ModuleName UTCTime) + moduleDirectDeps = map snd . filter ((==) Direct . fst) . fromMaybe graphError . flip lookup graph + where + graphError = internalError "make: module not found in dependency graph." + + splitModules :: [RebuildStatus] -> (RebuildMap, PrebuiltMap) splitModules = foldl' collectByStatus (M.empty, M.empty) - collectByStatus (build, prebuilt) (RebuildStatus mn rebuildNever _ mbPb upToDate) - -- To build if no prebuilt result exits. - | Nothing <- mbPb = (M.insert mn Nothing build, prebuilt) - -- To build if not up to date. - | Just pb <- mbPb, not upToDate = toRebuild (False, pb) - -- To prebuilt because of policy. + collectByStatus (build, prebuilt) (RebuildStatus mn rebuildNever cacheInfo mbPb upToDate) + -- If no cacheInfo => RebuildAlwaysPolicy. + | Nothing <- mbPb, Nothing <- cacheInfo, not upToDate = + (M.insert mn (Just RebuildAlwaysPolicy, Nothing) build, prebuilt) + -- In other cases if no previous, even if RebuildNever policy. + | Nothing <- mbPb = + (M.insert mn (Just NoCached, Nothing) build, prebuilt) + | Just pb <- mbPb, not upToDate = toRebuild (Just CacheOutdated, pb) + -- Treat as prebuilt because of RebuildNever policy. | Just pb <- mbPb, rebuildNever = toPrebuilt pb -- In other case analyze compilation times of dependencies. | Just pb <- mbPb = do - let deps = moduleDeps mn - let modTimes = map (flip M.lookup prebuilt) deps + -- We may check only direct dependencies here because transitive + -- changes (caused by reexports) will be propagated by externs diffs + -- of direct dependencies. + let deps = moduleDirectDeps mn + + let modTimes = map (\dmn -> (,) dmn <$> (M.lookup dmn prebuilt <|> (snd =<< M.lookup dmn build))) deps + let modTimes' = map (\dmn -> (,) dmn <$> M.lookup dmn prebuilt) deps case maximumMaybe (catMaybes modTimes) of -- Check if any of deps where build later. This means we should -- recompile even if the module's source is up-to-date. This may -- happen due to some partial builds or ide compilation -- workflows involved that do not assume full project - -- compilation. We should treat those modules as NOT up to date - -- to ensure they are rebuilt. - Just depModTime | pb < depModTime -> toRebuild (False, pb) - -- If one of the deps is not in the prebuilt, though the module - -- is up to date, we should add it in the rebuild queue. - _ | any isNothing modTimes -> toRebuild (upToDate, pb) + -- compilation. + Just (dmn, depModTime) | pb < depModTime -> toRebuild (Just (LaterDependency dmn), pb) + -- If one of the deps (even though it may have previous result + -- available) is not in the prebuilt, we should add the module + -- in the rebuild queue (where it will be checked against deps' + -- changes). + _ | any isNothing modTimes' -> toRebuild (Nothing, pb) _ -> toPrebuilt pb where - toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prebuilt) + toRebuild (mbReason, t) = (M.insert mn (mbReason, Just t) build, prebuilt) toPrebuilt v = (build, M.insert mn v prebuilt) -maximumMaybe :: Ord a => [a] -> Maybe a +maximumMaybe :: Ord a => [(ModuleName, a)] -> Maybe (ModuleName, a) maximumMaybe [] = Nothing -maximumMaybe xs = Just $ maximum xs +maximumMaybe xs = Just $ maximumBy (compare `on` snd) xs diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 4582d2fdf7..1c26218cfd 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -4,7 +4,6 @@ module Language.PureScript.Make.Cache , CacheDb , CacheInfo(..) , checkChanged - , removeModules , normaliseForCache , cacheDbIsCurrentVersion , toCacheDbVersioned @@ -25,7 +24,6 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Monoid (All(..)) -import Data.Set (Set) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) @@ -77,7 +75,7 @@ data CacheDbVersioned = CacheDbVersioned { cdbVersion :: Text, cdbModules :: Cac instance Aeson.FromJSON CacheDbVersioned where parseJSON = Aeson.withObject "CacheDb" $ \v -> CacheDbVersioned - <$> v .: "version" + <$> v .: "version" <*> v .: "modules" instance Aeson.ToJSON CacheDbVersioned where @@ -106,6 +104,19 @@ newtype CacheInfo = CacheInfo deriving stock (Show) deriving newtype (Eq, Ord, Semigroup, Monoid, Aeson.FromJSON, Aeson.ToJSON) +-- Maps old paths to current by extension. +-- "Old/Module.purs" => "New/Module.urs" +mapFilePaths :: Map FilePath b -> Map FilePath a -> Map FilePath a +mapFilePaths cur = + Map.mapKeys $ + \fp -> if Map.member fp cur then fp else curFp fp + where + ext = FilePath.takeExtension + filterExt fp fp' = ext fp == ext fp' + curFp fp = case filter (filterExt fp) (Map.keys cur) of + (fp' : _) -> fp' + _ -> fp + -- | Given a module name, and a map containing the associated input files -- together with current metadata i.e. timestamps and hashes, check whether the -- input files have changed, based on comparing with the database stored in the @@ -134,7 +145,11 @@ checkChanged -> m (CacheInfo, Bool) checkChanged cacheDb mn basePath currentInfo = do - let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) + -- Replace paths in cachedDb entry with paths from new info to handle module + -- file rename/move without recompilation. + let dbInfo = mapFilePaths currentInfo + $ unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) + (newInfo, isUpToDate) <- fmap mconcat $ for (Map.toList (align dbInfo currentInfo)) $ \(normaliseForCache basePath -> fp, aligned) -> do @@ -162,11 +177,6 @@ checkChanged cacheDb mn basePath currentInfo = do pure (CacheInfo newInfo, getAll isUpToDate) --- | Remove any modules from the given set from the cache database; used when --- they failed to build. -removeModules :: Set ModuleName -> CacheDb -> CacheDb -removeModules = flip Map.withoutKeys - -- | 1. Any path that is beneath our current working directory will be -- stored as a normalised relative path -- 2. Any path that isn't will be stored as an absolute path diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 5877b2c722..d0cf298ba4 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -1,5 +1,9 @@ module Language.PureScript.Make.ExternsDiff - ( ExternsDiff + ( ExternsDiff(..) + , RefStatus(..) + , DiffRef(..) + , Ref(..) + , isEmpty , emptyDiff , diffExterns , checkDiffs @@ -36,10 +40,11 @@ data Ref | ValueOpRef (P.OpName 'P.ValueOpName) | -- Instance ref points to the class and types defined in the same module. TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show) -data RefStatus = Removed | Updated - deriving (Show) +-- In diff we track removed, changed) and added refs. +data RefStatus = Added | Removed | Updated + deriving (Eq, Ord, Show) type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) @@ -48,8 +53,8 @@ type RefsWithStatus = M.Map Ref RefStatus type ModuleRefsMap = Map ModuleName (Set Ref) data ExternsDiff = ExternsDiff - {edModuleName :: ModuleName, edRefs :: Map Ref RefStatus} - deriving (Show) + { edModuleName :: ModuleName, edRefs :: Map Ref RefStatus } + deriving (Eq, Ord, Show) -- | Empty diff means no effective difference between externs. emptyDiff :: P.ModuleName -> ExternsDiff @@ -84,7 +89,7 @@ getChanged newExts oldExts depsDiffsMap = where modName = P.efModuleName newExts - getDecls = map stripDeclaration . P.efDeclarations + getDecls = map refineDeclaration . P.efDeclarations getTypeFixities = P.efTypeFixities getFixities = P.efFixities @@ -134,16 +139,17 @@ getChanged newExts oldExts depsDiffsMap = -- Determine which declarations where directly changed or removed by -- combining Declarations, Fixities and Type Fixities - as they are -- separated in externs we handle them separately. We don't care about added things. - (_, removed, changed, unchangedRefs) = + (added, removed, changed, unchangedRefs) = fold [ declsSplit , splitRefs (getFixities newExts) (getFixities oldExts) (pure . externsFixityToRef fixityCtx) , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) ] + withStatus status refs = map ((,status) . fst) refs changedRefs = M.fromList $ - map ((,Removed) . fst) removed <> map ((,Updated) . fst) changed + withStatus Added added <> withStatus Removed removed <> withStatus Updated changed -- Gets set of type constructors from new externs that have changed. getCtorsSets :: P.ExternsFile -> P.ExternsFile -> Set Ref @@ -196,8 +202,9 @@ getAffectedLocal modName diffsMap unchangedRefs = map fst $ filter (any (flip elem (fst <$> affectedByChanged)) . snd) refsGraph -diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff -diffExterns newExts oldExts depsDiffs = +-- Compares two externs file versions using list with diffs of dependencies. +diffExterns :: [ExternsDiff] -> P.ExternsFile -> P.ExternsFile -> ExternsDiff +diffExterns depsDiffs newExts oldExts = ExternsDiff modName $ affectedReExported <> changedRefs <> affectedLocalRefs where @@ -221,30 +228,43 @@ diffExterns newExts oldExts depsDiffs = affectedLocalRefs = M.fromSet (const Updated) $ getAffectedLocal modName diffsMapWithLocal unchangedRefs --- Checks if the externs diffs effect the module (the module uses any diff's --- entries). True if uses, False if not. -checkDiffs :: P.Module -> [ExternsDiff] -> Bool +-- This type defines a reason for module to be rebuilt. It contains the fhe +-- first found reference to changed elements. +data DiffRef + = ImportedRef (ModuleName, Ref) + | ReExportedRef (ModuleName, Ref) + | UsedRef (ModuleName, Ref) + deriving (Show, Eq, Ord) + +-- Checks if the module effectively uses any of diff's refs. +checkDiffs :: P.Module -> [ExternsDiff] -> Maybe DiffRef checkDiffs (P.Module _ _ _ decls exports) diffs - | all isEmpty diffs = False - | isNothing mbSearch = True - | null searches = False - | otherwise = checkReExports || checkUsage searches decls + | all isEmpty diffs = Nothing + | otherwise = case makeSearches decls diffs of + Left r -> Just (ImportedRef r) + Right searches + | null searches -> Nothing + | otherwise -> + (ReExportedRef <$> checkReExports searches) + <|> (UsedRef <$> checkUsage searches decls) where - mbSearch = makeSearches decls diffs - searches = fromMaybe S.empty mbSearch - -- Check if the module reexports any of searched refs. - checkReExports = flip (maybe False) exports $ any $ \case - P.ModuleRef _ mn -> not . null $ S.filter ((== Just mn) . fst) searches - _ -> False - --- Goes though the module and try to find any usage of the refs. --- Takes a set of refs to search in module's declarations, if found returns True. -checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool -checkUsage searches decls = anyUsages + checkReExports searches = + map (\(mn, _, ref) -> (mn, ref)) $ + exports >>= + listToMaybe . foldMap + ( \case + P.ModuleRef _ mn -> maybeToList $ find (\(_, mn' ,_) -> mn' == Just mn ) searches + _ -> [] + ) + +-- Takes a set of refs to search in module's declarations,. +-- Goes though the module and searches for the first usage of any. +checkUsage :: Set (ModuleName, Maybe ModuleName, Ref) -> [P.Declaration] -> Maybe (ModuleName, Ref) +checkUsage searches decls = listToMaybe anyUsages where -- Two traversals: one to pick up usages of types, one for the rest. - Any anyUsages = + anyUsages = foldMap checkUsageInTypes decls <> foldMap checkOtherUsages decls @@ -256,7 +276,9 @@ checkUsage searches decls = anyUsages stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n stripCtorType x = x - check q = Any $ S.member (P.getQual q, P.disqualify q) searches' + -- Check if a declaration is searchable element and map it to result. + check q = maybeToList $ (\(mn, _, ref) -> (mn, ref)) <$> + find (\(_, qual, ref) -> (qual, ref) == (P.getQual q, P.disqualify q)) searches' checkType = check . map TypeRef checkTypeOp = check . map TypeOpRef @@ -296,16 +318,17 @@ checkUsage searches decls = anyUsages P.OpBinder _ n -> checkValueOp n _ -> mempty + -- | Traverses imports and returns a set of refs to be searched though the --- module. Returns Nothing if removed refs found in imports (no need to search +-- module. Returns Left with the first removed ref found in imports (no need to search -- through the module - the module needs to be recompiled). If an empty set is -- returned then no changes apply to the module. -makeSearches :: [P.Declaration] -> [ExternsDiff] -> Maybe (Set (Maybe ModuleName, Ref)) +makeSearches :: [P.Declaration] -> [ExternsDiff] -> Either (ModuleName, Ref) (Set (ModuleName, Maybe ModuleName, Ref)) makeSearches decls depsDiffs = foldM go mempty decls where diffsMap = M.fromList (map (liftM2 (,) edModuleName edRefs) depsDiffs) - + searchRef = find . flip S.member -- Add data constructors to refs if all are implicitly imported using (..). getCtor n (ConstructorRef tn _) = tn == n getCtor _ _ = False @@ -318,24 +341,24 @@ makeSearches decls depsDiffs = -- We return Nothing if we encounter removed refs in imports. | Just diffs <- M.lookup mn diffsMap , removed <- M.keysSet $ M.filter isRefRemoved diffs = - fmap ((s <>) . S.map (qual,) . M.keysSet) $ case dt of + fmap ((s <>) . S.map (mn, qual,) . M.keysSet) $ case dt of P.Explicit dRefs - | any (flip S.member removed) refs -> Nothing + | Just ref <- searchRef removed refs -> Left (mn, ref) | otherwise -> -- Search only refs encountered in the import. - Just $ M.filterWithKey (const . flip elem refs) diffs + Right $ M.filterWithKey (const . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs P.Hiding dRefs - | any (flip S.member removed) refs -> Nothing + | Just ref <- searchRef removed refs -> Left (mn, ref) | otherwise -> -- Search only refs not encountered in the import. - Just $ M.filterWithKey (const . not . flip elem refs) diffs + Right $ M.filterWithKey (const . not . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs -- Search all changed refs. - P.Implicit -> Just diffs - go s _ = Just s + P.Implicit -> Right diffs + go s _ = Right s toRefs :: P.DeclarationRef -> [Ref] toRefs = \case @@ -425,7 +448,7 @@ externsDeclarationToRef moduleName = \case , -- Add the type as a dependency: if the type has changed (e.g. left side -- param is added) we should recompile the module which uses the -- constructor (even if there no the explicit type import). - -- Aso add the ad-hoc constructors set ref dependency: if a ctor + -- Also add the ad-hoc constructors set ref dependency: if a ctor -- added/removed it should affect all constructors in the type, -- because case statement's validity may be affected by newly added -- or removed constructors. @@ -466,23 +489,62 @@ externsDeclarationToRef moduleName = \case <> foldMap typeDeps args ) --- | Removes excessive info from declarations before comparing. --- --- TODO: params renaming will be needed to avoid recompilation because of params --- name changes. -stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration -stripDeclaration = \case - P.EDType n t (P.DataType dt args _) -> - -- Remove the notion of data constructors, we only compare type's left side. - P.EDType n t (P.DataType dt args []) - -- - P.EDInstance cn n fa ks ts cs ch chi ns ss -> - P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss - -- - decl -> decl + +-- | Replace type arguments with ordered names, this allows to handle +-- generated arg names (like t43) and user's rename of args. +refineType :: P.Type P.SourceAnn -> P.Type P.SourceAnn +refineType = fst . flip runState M.empty . + P.everywhereOnTypesM + (\case + P.ForAll ann vis var mbK ty sco -> getName var <&> \v -> P.ForAll ann vis v mbK ty sco + P.TypeVar ann var -> getName var <&> P.TypeVar ann + other -> pure other + ) + where + getName varName = do + m <- get + case M.lookup varName m of + Just rep -> + pure rep + Nothing -> do + let rep = "a" <> show (M.size m) + put (M.insert varName rep m) + pure rep + +-- | Removes excessive info from declarations and rename type arguments before +-- comparing. +refineDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration +refineDeclaration = \case + P.EDType n t k -> + P.EDType n (refineType t) (refineTypeKind k) + + P.EDTypeSynonym n args t -> + P.EDTypeSynonym n (refineArgs args) (refineType t) + + P.EDDataConstructor n org tn t ident -> + P.EDDataConstructor n org tn (refineType t) ident + + P.EDValue n t -> + P.EDValue n (refineType t) + + P.EDClass n args mem con dep emt -> + P.EDClass n (refineArgs args) (map (map refineType) mem) con dep emt + + P.EDInstance cn n fa ks ts cs ch chi ns _ss -> + P.EDInstance cn n (map (map refineType) fa) (map refineType ks) (map refineType ts) + cs (map refineChain ch) chi ns emptySpan + where + emptySpan = P.SourceSpan "" emptySP emptySP emptySP = P.SourcePos 0 0 - stripChain (ChainId (n, _)) = ChainId (n, emptySP) + refineChain (ChainId (_, _)) = ChainId ("", emptySP) + refineArgs = map (map (map refineType)) + refineTypeKind = \case + -- Remove the notion of data constructors, we only compare type's left side. + P.DataType dt args _ -> P.DataType dt (refineDataArgs args) [] + other -> other + refineDataArgs = + zipWith (\idx (_, t, role) -> ("a" <> show idx, refineType <$> t, role)) [(0 :: Int)..] isPrimModule :: ModuleName -> Bool isPrimModule = flip S.member (S.fromList primModules) diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index ed553cf28f..838ab2a5e3 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -13,6 +13,8 @@ module Language.PureScript.Make.Monad , readCborFile , readCborFileIO , readExternsFile + , readWarningsFile + , removeFileIfExists , hashFile , writeTextFile , writeJSONFile @@ -26,7 +28,7 @@ import Prelude import Codec.Serialise (Serialise) import Codec.Serialise qualified as Serialise import Control.Exception (fromException, tryJust, Exception (displayException)) -import Control.Monad (join, guard) +import Control.Monad (join, guard, void) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -46,7 +48,7 @@ import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleError import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options (Options) -import System.Directory (createDirectoryIfMissing, getModificationTime, setModificationTime) +import System.Directory (createDirectoryIfMissing, getModificationTime, removeFile, setModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) @@ -143,6 +145,17 @@ readExternsFile path = do guard $ externsIsCurrentVersion externs return externs +-- | Read an externs file, returning 'Nothing' if the file does not exist, +-- could not be parsed, or was generated by a different version of the +-- compiler. +readWarningsFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe MultipleErrors) +readWarningsFile path = do + readCborFile path + +removeFileIfExists :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m () +removeFileIfExists path = + makeIO ("remove file if eixsts: " <> Text.pack path) $ (void . catchDoesNotExist) $ removeFile path + hashFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ContentHash hashFile path = do makeIO ("hash file: " <> Text.pack path) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 3bcb914fb6..99f2837f55 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -2,7 +2,9 @@ module Language.PureScript.ModuleDependencies ( DependencyDepth(..) , sortModules + , sortModules' , ModuleGraph + , ModuleGraph' , ModuleSignature(..) , moduleSignature ) where @@ -29,6 +31,8 @@ data ModuleSignature = ModuleSignature } data DependencyDepth = Direct | Transitive + deriving (Eq, Ord, Show) +--data DependencyDepth = Direct | ReExports | Transitive -- | Sort a collection of modules based on module dependencies. -- @@ -40,7 +44,19 @@ sortModules -> (a -> ModuleSignature) -> [a] -> m ([a], ModuleGraph) -sortModules dependencyDepth toSig ms = do +sortModules dependencyDepth toSig ms = + map (map (map (map snd))) <$> sortModules' dependencyDepth toSig ms + +type ModuleGraph' = [(ModuleName, [(DependencyDepth, ModuleName)])] + +sortModules' + :: forall m a + . MonadError MultipleErrors m + => DependencyDepth + -> (a -> ModuleSignature) + -> [a] + -> m ([a], ModuleGraph') +sortModules' dependencyDepth toSig ms = do let ms' = (\m -> (m, toSig m)) <$> ms mns = S.fromList $ map (sigModuleName . snd) ms' @@ -49,11 +65,13 @@ sortModules dependencyDepth toSig ms = do let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) - deps = case dependencyDepth of - Direct -> graph ! v - Transitive -> reachable graph v - toKey i = case fromVertex i of (_, key, _) -> key - return (mn, filter (/= mn) (map toKey deps)) + vxDepth vx = (if vx `elem` (graph ! v) then Direct else Transitive, vx) + deps = case dependencyDepth of + Direct -> (Direct,) <$> graph ! v + Transitive -> vxDepth <$> reachable graph v + toKey (depth, i) = case fromVertex i of (_, key, _) -> (depth, key) + return (mn, filter ((/= mn) . snd) (map toKey deps)) + --return (mn, [(Direct, mn)]) return (fst <$> ms'', moduleGraph) where toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName]) @@ -86,4 +104,5 @@ toModule (CyclicSCC ms) = $ CycleInModules (map (sigModuleName . snd) ms') moduleSignature :: Module -> ModuleSignature -moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn (ordNub (mapMaybe usedModules ds)) +moduleSignature (Module ss _ mn ds _) = + ModuleSignature ss mn (ordNub (mapMaybe usedModules ds)) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index cf3e422c6f..2954cecf7d 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -9,179 +9,148 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad (guard, void, forM_, when) +import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) import Control.Exception (tryJust) +import Control.Monad ( guard, void ) import Control.Monad.IO.Class (liftIO) -import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) -import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime(..), secondsToDiffTime) -import Data.Text qualified as T +import Data.Map qualified as M import Data.Set (Set) import Data.Set qualified as Set -import Data.Map qualified as M +import Data.Text qualified as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) import Data.Version (showVersion) import Paths_purescript qualified as Paths +import System.Directory (createDirectory, createDirectoryIfMissing, getModificationTime, listDirectory, removeDirectoryRecursive, removeFile, setModificationTime) import System.FilePath (()) -import System.Directory (createDirectory, removeDirectoryRecursive, removeFile, setModificationTime) import System.IO.Error (isDoesNotExistError) -import System.IO.UTF8 (readUTF8FilesT, readUTF8FileT, writeUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT, writeUTF8FileT) -import Test.Hspec (Spec, before_, it, shouldReturn) +import Data.Time (getCurrentTime) +import Test.Hspec (Spec, before_, it, shouldBe, shouldReturn, shouldSatisfy) -utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime -utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) +spec :: Spec +spec = do + -- Before each test. + before_ cleanUp $ do -timestampA, timestampB, timestampC, timestampD :: UTCTime -timestampA = utcMidnightOnDate 2019 1 1 -timestampB = utcMidnightOnDate 2019 1 2 -timestampC = utcMidnightOnDate 2019 1 3 -timestampD = utcMidnightOnDate 2019 1 4 + -- RESULTING EXTERNS -oneSecond :: Int -oneSecond = 10 ^ (6::Int) -- microseconds. + it "returns all externs even when modules not compiled" $ do + writeModule "A" "module A where foo = 1" + writeModule "B" "module B where bar = 2" + ((Right exts1, _), c1) <- compileAll -spec :: Spec -spec = do - let sourcesDir = "tests/purs/make" - let moduleNames = Set.fromList . map P.moduleNameFromString - let modulePath name = sourcesDir (T.unpack name <> ".purs") - let foreignJsPath name = sourcesDir (T.unpack name <> ".js") - - -- Test helpers. - let testN itFn name modules compileFn res = - itFn name $ do - let names = map (\(mn, _, _) -> mn) modules - let paths = map modulePath names - let timestamp = utcMidnightOnDate 2019 1 - - forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do - writeFile (modulePath mn) (timestamp idx) content - -- Write a fake foreign module to bypass compiler's check. - when (T.isInfixOf "\nforeign import" content) $ - writeFile (foreignJsPath mn) (timestamp idx) content - - compile paths `shouldReturn` moduleNames names - - forM_ (zip [length modules..] modules) $ \(idx, (mn, _, mbContent)) -> do - maybe (pure ()) (writeFile (modulePath mn) (timestamp idx)) mbContent - - compileFn paths `shouldReturn` moduleNames res - - let test2 fn name (mAContent1, mAContent2, mBContent) res = - testN fn name - [ ("A", mAContent1, Just mAContent2) - , ("B", mBContent, Nothing) - ] compile res - - let testWithFailure2 fn name (mAContent1, mAContent2, mBContent) res = - testN fn name - [ ("A", mAContent1, Just mAContent2) - , ("B", mBContent, Nothing) - ] compileWithFailure res - - let test3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = - testN fn name - [ ("A", mAContent1, Just mAContent2) - , ("B", mBContent, Nothing) - , ("C", mCContent, Nothing) - ] compile res - - let testWithFailure3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = - testN fn name - [ ("A", mAContent1, Just mAContent2) - , ("B", mBContent, Nothing) - , ("C", mCContent, Nothing) - ] compileWithFailure res - - let recompile2 fn name ms = - test2 fn ("recompiles downstream when " <> name) ms ["A", "B"] - - let recompileWithFailure2 fn name ms = - testWithFailure2 fn ("recompiles downstream when " <> name) ms ["A", "B"] - - let noRecompile2 fn name ms = - test2 fn ("does not recompile downstream when " <> name) ms ["A"] - - before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do - it "does not recompile if there are no changes" $ do - let mPath = sourcesDir "Module.purs" + c1 `shouldBe` moduleNames ["A", "B"] + length exts1 `shouldBe` 2 - writeFile mPath timestampA "module Module where\nfoo = 0\n" - compile [mPath] `shouldReturn` moduleNames ["Module"] - compile [mPath] `shouldReturn` moduleNames [] + ((Right exts2, _), c2) <- compileAll + c2 `shouldBe` moduleNames [] - it "recompiles if files have changed" $ do - let mPath = sourcesDir "Module.purs" + length exts2 `shouldBe` 2 - writeFile mPath timestampA "module Module where\nfoo = 0\n" - compile [mPath] `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB "module Module where\nfoo = 1\n" - compile [mPath] `shouldReturn` moduleNames ["Module"] + it "returns all externs even when modules skipped" $ do + writeModule "A" "module A where foo = 1" + writeModule "B" "module B where\nimport A\nbar = foo" + ((Right exts1, _), c1) <- compileAll - it "does not recompile if hashes have not changed" $ do - let mPath = modulePath "Module" - moduleContent = "module Module where\nfoo = 0\n" + c1 `shouldBe` moduleNames ["A", "B"] + length exts1 `shouldBe` 2 - writeFile mPath timestampA moduleContent - compile [mPath] `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent - compile [mPath] `shouldReturn` moduleNames [] + writeModule "A" "module A where foo = 2" - it "recompiles if the file path for a module has changed" $ do - let modulePath1 = sourcesDir "Module1.purs" - modulePath2 = sourcesDir "Module2.purs" - moduleContent = "module Module where\nfoo = 0\n" + ((Right exts2, _), c2) <- compileAll + c2 `shouldBe` moduleNames ["A"] - writeFile modulePath1 timestampA moduleContent - writeFile modulePath2 timestampA moduleContent + length exts2 `shouldBe` 2 - compile [modulePath1] `shouldReturn` moduleNames ["Module"] - compile [modulePath2] `shouldReturn` moduleNames ["Module"] + -- PRESERVING WARNINGS - it "recompiles if an FFI file was added" $ do - let mPath = modulePath "Module" - mFFIPath = foreignJsPath "Module" - moduleContent = "module Module where\nfoo = 0\n" + -- Warnings should are preserved even if modules are not recompiled. + it "preserves warnings between rebuilds when compilation skipped" $ do + writeModule "A" $ + T.unlines + [ "module A (bar) where" + , -- Unused function. + "foo :: Int" + , "foo = 0" + , "bar :: Int" + , "bar = 0" + ] + ((_, warns), c1) <- compileAll + c1 `shouldBe` moduleNames ["A"] + length (P.runMultipleErrors warns) `shouldBe` 1 + -- + ((_, warns2), c2) <- compileAll + c2 `shouldBe` moduleNames [] + length (P.runMultipleErrors warns2) `shouldBe` 1 - writeFile mPath timestampA moduleContent - compile [mPath] `shouldReturn` moduleNames ["Module"] + -- CACHE DB - writeFile mFFIPath timestampB "export var bar = 1;\n" - compile [mPath] `shouldReturn` moduleNames ["Module"] + it "recompiles if cache-db version differs from the current" $ do + writeModule "Module" "module Module where\nfoo :: Int\nfoo = 1\n" + compileAll >>= expectCompiled ["Module"] - it "recompiles if an FFI file was removed" $ do - let mPath = modulePath "Module" - mFFIPath = foreignJsPath "Module" - moduleContent = "module Module where\nfoo = 0\n" + -- Replace version with illegal in cache-db file. + let cacheDbFilePath = P.cacheDbFile outputDir + versionText ver = "\"version\":\"" <> ver <> "\"" - writeFile mPath timestampA moduleContent - writeFile mFFIPath timestampB "export var bar = 1;\n" - compile [mPath] `shouldReturn` moduleNames ["Module"] + cacheContent <- readUTF8FileT cacheDbFilePath - removeFile mFFIPath - compile [mPath] `shouldReturn` moduleNames ["Module"] + let currentVer = T.pack (showVersion Paths.version) + let newContent = + T.replace (versionText currentVer) (versionText "0.0.0") cacheContent - it "does not necessarily recompile modules which were not part of the previous batch" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] + writeUTF8FileT cacheDbFilePath newContent - batch1 = [mAPath, mBPath] - batch2 = [mAPath, mCPath] + compileAll >>= expectCompiled ["Module"] - mAContent = "module A where\nfoo = 0\n" - mBContent = "module B where\nimport A (foo)\nbar = foo\n" - mCContent = "module C where\nbaz = 3\n" + -- COMPILATION SCENARIOS - writeFile mAPath timestampA mAContent - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + it "does not recompile if there are no changes" $ do + writeModule "Module" "module Module where\nfoo = 0\n" + compileAll >>= expectCompiled ["Module"] + + compileAll >>= expectCompiled [] + + it "recompiles if files have changed" $ do + writeModule "Module" "module Module where\nfoo = 0\n" + compileAll >>= expectCompiled ["Module"] + + writeModule "Module" "module Module where\nfoo = 1\n" + compileAll >>= expectCompiled ["Module"] + + -- If module was re-written with the same content. + it "does not recompile if hashes have not changed" $ do + let content = "module Module where\nfoo = 0\n" + + writeModule "Module" content + compileAll >>= expectCompiled ["Module"] + + writeModule "Module" content + compileAll >>= expectCompiled [] + + -- Allow to rename/move module's source file without recompilation. + -- This behaviour is changed, previously in was recompiled. + it "does not recompile if the file path for a module has changed" $ do + let content = "module Module where\nfoo = 0\n" + + writeModule "Module" content + compileAll >>= expectCompiled ["Module"] + deleteModule "Module" - compile batch1 `shouldReturn` moduleNames [] - compile batch2 `shouldReturn` moduleNames [] + writeModule "Module2" content + compileAll >>= expectCompiled [] + + it "does not necessarily recompile modules which were not part of the previous batch" $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A (foo)\nbar = foo\n" + writeModule "C" "module C where\nbaz = 3\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + compileSome ["A", "B"] >>= expectCompiled [] + compileSome ["A", "C"] >>= expectCompiled [] it "recompiles if a module fails to compile" $ do let mPath = sourcesDir "Module.purs" @@ -191,14 +160,29 @@ spec = do compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] + it "recompiles if an FFI file was added" $ do + writeModule "Module" "module Module where\nfoo = 0\n" + compileAll >>= expectCompiled ["Module"] + + writeForeign "Module" "export var bar = 1;\n" + compileAll >>= expectCompiled ["Module"] + + it "recompiles if an FFI file was removed" $ do + writeModule "Module" "module Module where\nfoo = 0\n" + writeForeign "Module" "export var bar = 1;\n" + compileAll >>= expectCompiled ["Module"] + + deleteForeign "Module" + compileAll >>= expectCompiled ["Module"] + it "recompiles if docs are requested but not up to date" $ do let mPath = sourcesDir "Module.purs" mContent1 = "module Module where\nx :: Int\nx = 1" mContent2 = mContent1 <> "\ny :: Int\ny = 1" - optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } - go opts = compileWithOptions opts [mPath] >>= assertSuccess + optsWithDocs = P.defaultOptions {P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs]} + go opts = compileWithOptions opts mempty [mPath] >>= assertSuccess writeFile mPath timestampA mContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] @@ -214,8 +198,8 @@ spec = do let mPath = sourcesDir "Module.purs" mContent1 = "module Module where\nx :: Int\nx = 1" mContent2 = mContent1 <> "\ny :: Int\ny = 1" - optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } - go opts = compileWithOptions opts [mPath] >>= assertSuccess + optsCoreFnOnly = P.defaultOptions {P.optionsCodegenTargets = Set.singleton P.CoreFn} + go opts = compileWithOptions opts mempty [mPath] >>= assertSuccess writeFile mPath timestampA mContent1 go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] @@ -227,446 +211,315 @@ spec = do -- recompiled. go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - it "recompiles if cache-db version differs from the current" $ do - let mPath = sourcesDir "Module.purs" - mContent = "module Module where\nfoo :: Int\nfoo = 1\n" + it "recompile failed deps in previous compilation" $ do + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\n" + writeModule "B" "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + compileAll >>= expectCompiled ["A", "B"] - writeFile mPath timestampA mContent - compile [mPath] `shouldReturn` moduleNames ["Module"] + threadDelay oneSecond - -- Replace version with illegal in cache-db file. - let cacheDbFilePath = P.cacheDbFile modulesDir - versionText ver = "\"version\":\"" <> ver <> "\"" + writeModule "A" "module A where\nfoo :: Char\nfoo = '0'\n" + compileAll >>= expectCompiledWithFailure ["A", "B"] - cacheContent <- readUTF8FileT cacheDbFilePath + threadDelay oneSecond - let currentVer = T.pack (showVersion Paths.version) - let newContent = - T.replace (versionText currentVer) (versionText "0.0.0") cacheContent + writeModule "A" "module A where\nfoo :: Char\nfoo = '0'\nfar = 1" + compileAll >>= expectCompiledWithFailure ["A", "B"] - writeUTF8FileT cacheDbFilePath newContent + it "does not recompile not affected deps after the error fixed" $ do + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\n" + writeModule "B" "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + compileAll >>= expectCompiled ["A", "B"] - compile [mPath] `shouldReturn` moduleNames ["Module"] + writeModule "A" "module A where\nfoo :: Char\nfoo = 0\n" + compileAll >>= expectCompiledWithFailure ["A"] - -- Cut off rebuild tests. + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\nzaar = 1" + compileAll >>= expectCompiled ["A"] - -- If a module is compiled with effective changes for downstream they should - -- be rebuilt too. - it "recompiles downstream modules when a module is rebuilt and externs changed" $ do + -- If a module failed to compile, then the error is fixed and there are + -- effective changes for downstream modules, they should be recompiled. + it "recompiles affected deps after the error fixed" $ do let mAPath = modulePath "A" mBPath = modulePath "B" - mAContent1 = "module A where\nfoo = 0\n" - mAContent2 = "module A where\nfoo = '1'\n" - mBContent = "module B where\nimport A as A\nbar = A.foo\n" + mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" + mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" + mAContent3 = "module A where\nfoo :: Char\nfoo = '0'\n" + mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" writeFile mAPath timestampA mAContent1 writeFile mBPath timestampB mBContent compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] writeFile mAPath timestampC mAContent2 - compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + writeFile mAPath timestampD mAContent3 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] - -- If a module is compiled with no effective changes for downstream they should - -- not be rebuilt. - it "recompiles downstream modules only when a module is rebuilt end externs changed" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] + -- REBUILD CUT OFF: rebuilds only modules that are affected by changes. - mAContent1 = "module A where\nfoo = 0\n" - mAContent2 = "module A where\nfoo = '1'\n" -- change externs here - mBContent = "module B where\nimport A (foo)\nbar = foo\n" - mCContent = "module C where\nbaz = 3\n" + -- RebuildReason:: LaterDependency - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + it "recompiles downstream in case of later dependency" $ do + -- C and B depends on A. + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A\nbar = 1\nbaz = foo\n" + writeModule "C" "module C where\nimport A\nimport B\nqux = bar\nthud = foo" - writeFile mAPath timestampD mAContent2 - compile modulePaths `shouldReturn` moduleNames ["A", "B"] + compileAll >>= expectCompiled ["A", "B", "C"] - -- If module is compiled separately (e.g., with ide). Then downstream should - -- be rebuilt during the next build. - it "recompiles downstream after a module has been rebuilt separately" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - mPaths = [mAPath, mBPath, mCPath] + threadDelay oneSecond - mAContent1 = "module A where\nfoo = 0\n" - mAContent2 = "module A where\nfoo = 1\n" - mBContent = "module B where\nimport A\nbar = 1\nbaz = foo\n" - mCContent = "module C where\nimport B\nqux = bar" + writeModule "A" "module A where\nfoo = '1'\n" + _ <- compileOne "A" - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - writeFile mCPath timestampB mCContent + compileAll >>= expectCompiled ["B", "C"] - compile mPaths `shouldReturn` moduleNames ["A", "B", "C"] + -- Later dependency should only require compilation of direct downstream modules. + it "recompiles only direct deps in case of later dependency" $ do + -- Only B depends on A. C not effected. + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A\nbar = 1\nbaz = foo\n" + writeModule "C" "module C where\nimport B\nqux = baz" + + compileAll >>= expectCompiled ["A", "B", "C"] threadDelay oneSecond - writeFile mAPath timestampC mAContent2 - compile [mAPath] `shouldReturn` moduleNames ["A"] + writeModule "A" "module A where\nfoo = 1\n" + _ <- compileOne "A" - compile mPaths `shouldReturn` moduleNames ["B", "C"] + compileAll >>= expectCompiled ["B"] - -- If a module failed to compile, then the error is fixed and there are no - -- effective changes for downstream modules, they should not be recompiled. - it "does not recompile downstream modules after the error fixed and externs not changed" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" - mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" - mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + -- Check timestamp for C is modified. + tsB <- getOutputTimestamp "B" + tsC <- getOutputTimestamp "C" + tsC `shouldSatisfy` (<=) tsB - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + it "recompiles downstream in case of later dependency with transitive change" $ do + -- C and B depends on A. A effects C. + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A\nbar = 1\nbaz = foo\n" + writeModule "C" "module C where\nimport B\nqux = baz" - writeFile mAPath timestampC mAContent2 - compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + compileAll >>= expectCompiled ["A", "B", "C"] - writeFile mAPath timestampD mAContent1 - compile [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + threadDelay oneSecond - -- If a module failed to compile, then the error is fixed and there are - -- effective changes for downstream modules, they should be recompiled. - it "recompiles downstream modules after the error fixed and externs changed" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" - mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" - mAContent3 = "module A where\nfoo :: Char\nfoo = '0'\n" - mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + -- Change foo's type (effect on C). + writeModule "A" "module A where\nfoo = '1'\n" + _ <- compileOne "A" - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + compileAll >>= expectCompiled ["B", "C"] - writeFile mAPath timestampC mAContent2 - compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] - writeFile mAPath timestampD mAContent3 - compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + -- RebuildReason: UpstreamRef - -- Reexports: original ref is changed. - test3 it "recompiles downstream when a reexported ref changed" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here - , "module B (module E) where\nimport A (foo) as E\n" - , "module C where\nimport B as B\nbaz = B.foo\n" - ) - ["A", "B", "C"] - - -- Reexports: original ref is changed. Ref is imported but not used. - test3 it "does not recompile downstream when a reexported ref changed and the ref is imported but not used" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here - , "module B (module E) where\nimport A as E\n" - -- Import but not use. - , "module C where\nimport B (foo)\nx = 1\n" - ) - ["A", "B"] - - -- Reexports: original export is removed from module. - testWithFailure3 it "recompiles downstream when a reexported ref removed" - ( "module A where\nfoo = 0\n" - , "module A where\nbar = 1\n" -- change externs here - , "module B (module E) where\nimport A as E\n" - , "module C where\nimport B as B\nbaz = B.foo\n" - ) - ["A", "B", "C"] - - -- Reexports: ref is removed from reexporting module. - testWithFailure3 it "recompiles downstream when a reexported ref removed (from reexported)" - ( "module B (module E) where\nimport A (foo) as E\n" - , "module B where\nimport A (foo) as E\n" - , "module A where\nfoo = 0\n" - , "module C where\nimport B as B\nbaz = B.foo\n" - ) - ["B", "C"] - - -- Reexports: ref is imported but not used. Reexport ref is removed from - -- reexporting module. - testWithFailure3 it "recompiles downstream when a reexported ref removed (imported but not used)" - ( "module B (module E) where\nimport A (foo) as E\n" - , "module B where\nimport A (foo) as E\n" - , "module A where\nfoo = 0\n" - -- Import but not use. - , "module C where\nimport B (foo) as B\nx=1\n" - ) - ["B", "C"] - - -- Reexports: original ref Removed. Ref is imported but not used. - testWithFailure3 it "recompiles downstream when a reexported ref removed in original" - ( "module A where\nfoo = 0\n" - , "module A where\nbar = 1\n" -- change externs here - , "module B (module E) where\nimport A as E\n" - -- Import but not use. - , "module C where\nimport B (foo)\nx = 1\n" - ) - ["A", "B", "C"] - - -- Imports. - testWithFailure2 it "recompiles downstream when removed reference found in imports" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo2 = 1\n" - , "module B where\nimport A (foo)\nbar = 1" - ) - ["A", "B"] - - test2 it "does not recompiles downstream when removed reference is not used" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo2 = 1\n" - , "module B where\nimport A\nbar = 1" - ) - ["A"] - - -- We need to ensure that it finds refs everywhere inside a module. - -- Usage: Inlined type. - testWithFailure2 it "recompiles downstream when found changed inlined type" - ( "module A where\ntype T = Int\n" - , "module A where\ntype T = String\n" - , "module B where\nimport A\nx = (1 :: T)" - ) - ["A", "B"] - - -- Transitive change: module A changes, module B depends on A and module C - -- depends on B are both recompiled. - test3 it "recompiles downstream due to transitive change" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo = '1'\n" - , "module B where\nimport A (foo)\nbar = qux\nqux = foo" - , "module C where\nimport B (bar)\nbaz = bar\n" - ) - ["A", "B", "C"] - - test3 it "does not recompile downstream if no transitive change" - ( "module A where\nfoo = 0\n" - , "module A where\nfoo = '1'\n" - , "module B where\nimport A (foo)\nbar = 1\nqux = foo" - , "module C where\nimport B (bar)\nbaz = bar\n" - ) - ["A", "B"] - - -- Non effective change does not cause downstream rebuild. - test2 it "does not recompile downstream if unused type changed" - ( "module A where\ntype SynA = Int\ntype SynA2 = Int" - , "module A where\ntype SynA = String\ntype SynA2 = Int" - , "module B where\nimport A as A\ntype SynB = A.SynA2" - ) - ["A"] - - -- Type synonym in foreign import. - recompile2 it "type synonym changed in foreign import" - ( "module A where\ntype SynA = Int\n" - , "module A where\ntype SynA = String\n" - , "module B where\nimport A as A\nforeign import a :: A.SynA\n" - ) - - -- Type synonym change. - recompile2 it "type synonym changed" - ( "module A where\ntype SynA = Int\n" - , "module A where\ntype SynA = String\n" - , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" - ) - - -- Type synonym change in value. - recompile2 it "type synonym changed in value" - ( "module A where\ntype SynA = Int\n" - , "module A where\ntype SynA = String\n" - , "module B where\nimport A as A\nvalue = ([] :: Array A.SynA)\n" - ) - - -- Type synonym change in pattern. - recompile2 it "type synonym changed in pattern" - ( "module A where\ntype SynA = Int\n" - , "module A where\ntype SynA = String\n" - , "module B where\nimport A as A\nfn = \\(_ :: Array A.SynA) -> 0\n" - ) - - -- Type synonym indirect change. - recompile2 it "type synonym dependency changed" - ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" - , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" - , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" - ) - - -- Data type: parameter added. - recompile2 it "data type changed (parameter added)" - ( "module A where\ndata T = A Int | B Int\n" - , "module A where\ndata T a = A Int | B a\n" - , "module B where\nimport A (T)\ntype B = T" - ) - - -- Data type: constructor added. - recompile2 it "data type changed (constructor added)" - ( "module A where\ndata T = A | B\n" - , "module A where\ndata T = A | B | C\n" - , "module B where\nimport A (T(B))\nb = B" - ) - - -- Data type: constructor indirectly changed. - recompile2 it "data type constructor dependency changed" - ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" - , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" - , "module B where\nimport A (AB(..))\nb = A" - ) - - -- Data type: constructor changed but not used. - noRecompile2 it "data type constructor changed, but not used" - ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" - , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" - -- use type and other constructor - , "module B where\nimport A (AB(..))\ntype B = AB\nb = B" - ) - - -- Data type: constructor added, but not imported. - noRecompile2 it "data type constructor added, but ctors not imported" - ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" - , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" - -- use just type - , "module B where\nimport A (AB)\ntype B = AB\n" - ) - - -- Data type: constructor added, but not used. - noRecompile2 it "data type constructor added, but ctors not imported" - ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" - , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" - -- use type - , "module B where\nimport A (AB(..))\ntype B = AB\n" - ) - - -- Data type: constructor added, and constructors are used in the downstream - -- module (this may be need when there is a case statement without wildcard, - -- but we don't analyze the usage that deep). - recompile2 it "data type constructor added and ctors are used" - ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" - , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" - -- use type and other constructor - , "module B where\nimport A (AB(..))\ntype B = AB\nb = B\n" - ) - - -- Value operator change. - recompile2 it "value op changed" - ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" - , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" - , "module B where\nimport A\nt = 1 :+: \"1\" " - ) - - -- Value operator indirect change. - recompile2 it "value op dependency changed" - ( "module A where\ndata T a = T a String\ninfixl 2 T as :+:\n" - , "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" - , "module B where\nimport A\nt = 1 :+: \"1\" " - ) - - -- Type operator change. - recompile2 it "type op changed" - ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" - , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" - , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" - ) - - -- Type operator indirect change. - recompile2 it "type op dependency changed" - ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" - , "module A where\ndata T b a = T a b\ninfixl 2 type T as :+:\n" - , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" - ) - - -- Type classes changed. Downstream uses type class in signature. - recompile2 it "type class changed" - ( "module A where\nclass Cls a where m1 :: a -> Int\n" - , "module A where\nclass Cls a where m1 :: a -> Char\n" - , T.unlines - [ "module B where" - , "import A as A" - , "fn :: forall a. A.Cls a => a -> Int" - , "fn _ = 1" - ] - ) - - -- Type classes changed. Downstream uses only its member. - recompile2 it "type class changed (member affected)" - ( "module A where\nclass Cls a where m1 :: a -> Int\n" - , "module A where\nclass Cls a where m1 :: a -> Char\n" - , T.unlines - [ "module B where" - , "import A as A" - , "fn x = A.m1 x" - ] - ) - - -- Type class instance added. - recompile2 it "type class instance added" - ( "module A where\nclass Cls a where m1 :: a -> Int\n" - , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" - , T.unlines - [ "module B where" - , "import A as A" - , "fn :: forall a. A.Cls a => a -> Int" - , "fn _ = 1" - ] - ) - - -- Type class instance removed. - recompileWithFailure2 it "type class instance removed" - ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" - , "module A where\nclass Cls a where m1 :: a -> Int\n" - , T.unlines - [ "module B where" - , "import A (m1)" - , "x = m1 1" - ] - ) - - -- Type class instance added for a type. We need to recompile downstream - -- modules that use this type, because it can be effected (even if it - -- doesn't use type class as we do not analyze this). - test3 it "recompiles downstream if instance added for a type" - ( "module B where\nimport A\nnewtype T = T Int\n" - , "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module A where\nclass Cls a where m1 :: a -> Int\n" - , T.unlines - [ "module C where" - , "import B" - , "t = T 1" - ] - ) - ["B", "C"] - - -- Type class instance removed for a type. - testWithFailure3 it "recompiles downstream if type class instance removed for a type" - ( "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module B where\nimport A\nnewtype T = T Int\n" - , "module A where\nclass Cls a where m1 :: a -> Int\n" - , T.unlines - [ "module C where" - , "import A" - , "import B" - , "i :: Int" - , "i = m1 (T 1)" - ] - ) - ["B", "C"] - - -- Type class instance added for the type and type class in another module - -- it self is modified. We don't need to recompile downstream modules that - -- depend only on type (if they use type class they will be recompiled). - testN it "does not recompile downstream if an instance added for the type and type class changed" - [ ( "A" - , "module A where\nclass Cls a where m1 :: a -> Char\n" - , Just "module A where\nclass Cls a where m1 :: a -> Int\n" - ) - , ( "B" - , "module B where\nimport A\nnewtype T = T Int\n" - , Just "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - ) - , ("C", "module C where\nimport B\ntype C = T", Nothing) - ] compile ["A", "B"] + it "recompiles downstream modules when module's externs change (Updated ref)" $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A as A\nbar = A.foo\n" + + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\nfoo = '1'\n" -- change foo type + compileAll >>= expectCompiled ["A", "B"] + + it "skips downstream rebuild when externs has not changed" $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A as A\nbar = A.foo\n" + + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\n\nfoo = 1\n" -- no type change + compileAll >>= expectCompiled ["A"] + + it "skips downstream rebuild when externs changed but do not affect (Added ref)" $ do + writeModule "A" "module A where\nfoo = 0" + writeModule "B" "module B where\nimport A as A\nbar = A.foo\n" + + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\n\nfoo = 0\n\nbaz = 1" + + compileAll >>= expectCompiled ["A"] + + it "recompiles downstream rebuild when externs add ref which cause conflict" $ do + writeModule "A" "module A where\nfoo = 0" + writeModule "B" "module B where\nbar = '1'\n" + writeModule "C" "module C where\nimport A\nimport B\ncar = bar\n" + + compileAll >>= expectCompiled ["A", "B", "C"] + + -- Add `bar` in A which is present in B too. + writeModule "A" "module A where\nfoo = 0\nbar = 1" + + compileAll >>= expectCompiledWithFailure ["A", "C"] + + it "recompiles downstream rebuild when added ref causes ScopeShadowing" $ do + writeModule "A" "module A where\nfoo = 0" + writeModule "B" "module B where\nbar = '1'\n" + writeModule "C" "module C where\nimport A\nimport B (bar)\ncar = bar\n" + + compileAll >>= expectCompiled ["A", "B", "C"] + + -- Add `bar` in A which is present in B too. Will cause ScopeShadowing in C. + writeModule "A" "module A where\nfoo = 0\nbar = 1" + + compileAll >>= expectCompiled ["A", "C"] + + -- Type arguments changes. + + it "renaming type arguments doesn't cause downstream rebuild" $ do + let typ = "data Foo a = Foo\n" + let fn = "foo :: forall a. Int -> Foo a\nfoo _ = Foo\n" + + writeModule "A" $ "module A where\n" <> typ <> fn + writeModule "B" "module B where\nimport A as A\nbar = A.foo\n" + + compileAll >>= expectCompiled ["A", "B"] + + let typ2 = "data Foo x = Foo\n" + let fn2 = "foo :: forall y. Int -> Foo y\nfoo _ = Foo\n" + writeModule "A" $ "module A where\n" <> typ2 <> fn2 <> "x = 1\n" + + compileAll >>= expectCompiled ["A"] + + it "changing order of type arguments causes downstream rebuild" $ do + let fn = "foo :: forall a b. a -> b -> Int\nfoo _ _ = 1\n" + + writeModule "A" $ "module A where\n" <> fn + writeModule "B" "module B where\nimport A as A\nbar = A.foo\n" + + compileAll >>= expectCompiled ["A", "B"] + + let fn2 = "foo :: forall b a. a -> b -> Int\nfoo _ _ = 1\n" + writeModule "A" $ "module A where\n" <> fn2 + + compileAll >>= expectCompiled ["A", "B"] + + it "renaming data type arguments doesn't cause downstream rebuild" $ do + let typ = "data Baz a b = Foo a | Bar b\n" + + writeModule "A" $ "module A where\n" <> typ + writeModule "B" "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + + compileAll >>= expectCompiled ["A", "B"] + + -- Rename a <-> b, this doesn't change types. + let typ2 = "data Baz b a = Foo b | Bar a\n" + writeModule "A" $ "module A where\n" <> typ2 + + compileAll >>= expectCompiled ["A"] + + it "changing order of data type arguments causes downstream rebuild" $ do + let typ = "data Baz a b = Foo a | Bar b\n" + + writeModule "A" $ "module A where\n" <> typ + writeModule "B" "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + + compileAll >>= expectCompiled ["A", "B"] + + -- Changing a <-> b order (on the left) will cause change in forall + -- signature of constructors. + let typ2 = "data Baz b a = Foo a | Bar b\n" + writeModule "A" $ "module A where\n" <> typ2 + + compileAll >>= expectCompiledWithFailure ["A", "B"] + + -- This is because adding/removing a constructor may affect cases + -- statements that do not use it explicitly. + -- Though this potentially could be optimized while searching though the module. + it "adding type constructor causes downstream rebuild if it uses (another) constructor" $ do + let typ = "data Baz a b = Foo a | Bar b\n" + + writeModule "A" $ "module A where\n" <> typ + writeModule "B" "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + + compileAll >>= expectCompiled ["A", "B"] + + let typ2 = "data Baz b a = Foo b | Bar a | Car\n" + writeModule "A" $ "module A where\n" <> typ2 + + -- As B uses constructor adding constructor affects + compileAll >>= expectCompiled ["A", "B"] + + -- If dependency uses only a type without constructors, it should not care + -- about right side changes. + it "adding type constructor doesn't cause downstream rebuild if it uses only the type" $ do + let typ = "data Baz a b = Foo a | Bar b\n" + + writeModule "A" $ "module A where\n" <> typ + writeModule "B" "module B where\nimport A\nbar (x :: Baz String Int) = 1" + + compileAll >>= expectCompiled ["A", "B"] + + let typ2 = "data Baz b a = Foo b | Bar a | Car\n" + writeModule "A" $ "module A where\n" <> typ2 + + compileAll >>= expectCompiled ["A"] + + where + + sourcesDir = "tests/purs/make" + moduleNames = Set.fromList . map P.moduleNameFromString + modulePath name = sourcesDir (T.unpack name <> ".purs") + foreignJsPath name = sourcesDir (T.unpack name <> ".js") + + cleanUp = do + rimraf outputDir >> rimraf sourcesDir >> createDirectory sourcesDir + + writeModule mn content = do + ts <- getCurrentTime + writeFile (modulePath mn) ts content + + deleteModule mn = do + removeFile (modulePath mn) + + writeForeign mn content = do + ts <- getCurrentTime + writeFile (foreignJsPath mn) ts content + + getOutputTimestamp mn = + getModificationTime (modulePath mn) + + deleteForeign mn = do + removeFile (foreignJsPath mn) + + listModulePaths = + fmap (() sourcesDir) + <$> filter (T.isSuffixOf ".purs" . T.pack) + <$> listDirectory sourcesDir + + compileAll = do + sources <- listModulePaths + compileWithResult mempty sources + + compileSome mns = do + let sources = modulePath <$> mns + compileWithResult mempty sources + + compileOne mn = do + compileWithResult mempty [modulePath mn] + + expectCompiled mns r = do + compiled <- assertSuccess r + compiled `shouldBe` moduleNames mns + + expectCompiledWithFailure mns r = do + compiled <- assertFailure r + compiled `shouldBe` moduleNames mns + + +utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime +utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) + +timestampA, timestampB, timestampC, timestampD :: UTCTime +timestampA = utcMidnightOnDate 2019 1 1 +timestampB = utcMidnightOnDate 2019 1 2 +timestampC = utcMidnightOnDate 2019 1 3 +timestampD = utcMidnightOnDate 2019 1 4 + +oneSecond :: Int +oneSecond = 10 ^ (5 :: Int) -- microseconds. -- Note [Sleeping to avoid flaky tests] -- @@ -688,49 +541,65 @@ rimraf :: FilePath -> IO () rimraf = void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive +type CompileResult = (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) + -- | Compile a group of modules, returning a set of the modules for which a -- rebuild was attempted, allowing the caller to set the compiler options and -- including the make result in the return value. compileWithOptions :: P.Options -> + M.Map P.ModuleName P.RebuildPolicy -> [FilePath] -> - IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) -compileWithOptions opts input = do + IO (CompileResult, Set P.ModuleName) +compileWithOptions opts policyMap input = do recompiled <- newMVar Set.empty moduleFiles <- readUTF8FilesT input - (makeResult, _) <- P.runMake opts $ do + + _ <- createDirectoryIfMissing True outputDir + + (makeResult, warnings) <- P.runMake opts $ do ms <- CST.parseModulesFromFiles id moduleFiles - let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms + + let filePathMap = + M.union (Left <$> policyMap) $ + M.fromList (map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms) + foreigns <- P.inferForeignModules filePathMap + + let logFile = outputDir "compile.log" + let cleanLog = False + logProgress <- P.progressWithFile logFile cleanLog let makeActions = - (P.buildMakeActions modulesDir filePathMap foreigns True) - { P.progress = \case - P.CompilingModule mn _ -> - liftIO $ modifyMVar_ recompiled (return . Set.insert mn) - _ -> pure () + (P.buildMakeActions outputDir filePathMap foreigns True) + { P.progress = + (*>) <$> logProgress <*> \case + P.CompilingModule mn _ _ -> + liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + _ -> pure () } P.make makeActions (map snd ms) recompiledModules <- readMVar recompiled - pure (makeResult, recompiledModules) + pure ((makeResult, warnings), recompiledModules) -- | Compile a group of modules using the default options, and including the -- make result in the return value. compileWithResult :: + M.Map P.ModuleName P.RebuildPolicy -> [FilePath] -> - IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) + IO (CompileResult, Set P.ModuleName) compileWithResult = compileWithOptions P.defaultOptions -assertSuccess :: (Either P.MultipleErrors a, Set P.ModuleName) -> IO (Set P.ModuleName) -assertSuccess (result, recompiled) = +assertSuccess :: (CompileResult, Set P.ModuleName) -> IO (Set P.ModuleName) +assertSuccess ((result, _), recompiled) = case result of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) Right _ -> pure recompiled -assertFailure :: (Either P.MultipleErrors a, Set P.ModuleName) -> IO (Set P.ModuleName) -assertFailure (result, recompiled) = +assertFailure :: (CompileResult, Set P.ModuleName) -> IO (Set P.ModuleName) +assertFailure ((result, _), recompiled) = case result of Left _ -> pure recompiled @@ -741,11 +610,11 @@ assertFailure (result, recompiled) = -- any errors occurred. compile :: [FilePath] -> IO (Set P.ModuleName) compile input = - compileWithResult input >>= assertSuccess + compileWithResult mempty input >>= assertSuccess compileWithFailure :: [FilePath] -> IO (Set P.ModuleName) compileWithFailure input = - compileWithResult input >>= assertFailure + compileWithResult mempty input >>= assertFailure writeFile :: FilePath -> UTCTime -> T.Text -> IO () writeFile path mtime contents = do @@ -754,5 +623,5 @@ writeFile path mtime contents = do -- | Use a different output directory to ensure that we don't get interference -- from other test results -modulesDir :: FilePath -modulesDir = ".test_modules" "make" +outputDir :: FilePath +outputDir = ".test_modules" "make" diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 97ea465999..68df9f52cc 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -227,7 +227,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do unless hasExpectedModuleName $ error ("While testing a single PureScript file, the expected module name was '" <> expectedModuleName <> "' but got '" <> T.unpack (getPsModuleName singleModule) <> "'.") - compiledModulePath <$ P.rebuildModule actions supportExterns (snd singleModule) + compiledModulePath <$ P.rebuildModule actions supportExterns (mempty, snd singleModule) _ -> do unless hasExpectedModuleName $ error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'."