diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..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,12 +69,19 @@ 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 - P.make makeActions (map snd ms) + 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/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/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 cf0c83a42d..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, @@ -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 @@ -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/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/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/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/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/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 0da65d2251..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 "Compiling 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/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..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. @@ -82,7 +84,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 @@ -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/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/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 5228dc86e6..14a5bfdc33 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,9 +1,11 @@ module Language.PureScript.Make - ( - -- * Make API - rebuildModule + ( make + , make_ + , make' + , MakeOptions(..) + , rebuildModule + -- Exported for external use (trypurescript) #4095 , rebuildModule' - , make , inferForeignModules , module Monad , module Actions @@ -13,56 +15,56 @@ 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.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) 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) -import Language.PureScript.Make.BuildPlan qualified as BuildPlan -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 -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) -- | 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) => MakeActions m -> [ExternsFile] - -> Module + -> ([CST.ParserWarning], Module) -> m ExternsFile rebuildModule actions externs m = do env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs @@ -74,31 +76,25 @@ rebuildModule' => MakeActions m -> Env -> [ExternsFile] - -> Module - -> 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) + -> ([CST.ParserWarning], Module) + -- ^ Parser warnings to save them while codegen. -> 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. @@ -117,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, @@ -126,30 +123,60 @@ 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 --- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. +data MakeOptions = MakeOptions + { moCollectAllExterns :: Bool + } + +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file +-- and an @externs.cbor@ file. +-- +-- If timestamps or hashes have not changed, existing externs files can be used +-- to provide upstream modules' types without having to typecheck those modules +-- again. -- --- 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. +-- 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@MakeActions{..} ms = do +make = make' (MakeOptions {moCollectAllExterns = True}) + +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file +-- and an @externs.cbor@ file. +-- +-- This version of make returns nothing. +make_ :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [CST.PartialResult Module] + -> m () +make_ ma ms = void $ make' (MakeOptions {moCollectAllExterns = False}) ma ms + +make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeOptions + -> MakeActions m + -> [CST.PartialResult Module] + -> m [ExternsFile] +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 - (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) + 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`. @@ -160,42 +187,53 @@ 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 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` map (getModuleName . CST.resPartial) sorted) + (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 -- 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 +241,15 @@ 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) + + pure $ + if moCollectAllExterns then + map lookupResult sortedModuleNames + else + mapMaybe (flip M.lookup successes) sortedModuleNames where checkModuleNames :: m () @@ -239,46 +282,96 @@ make 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 (_, externs) -> do - -- 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) - - -- 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 - Nothing -> return BuildJobSkipped + -- 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 -> 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 diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f138327c8d..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 (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, 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, 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,30 +76,103 @@ 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 - deriving (Show, Eq, Ord) + | SkippingModule ModuleName (Maybe (Int, Int)) + | 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 (CompilingModule mn mi) = - T.concat - [ renderProgressIndex mi - , infx - , runModuleName mn - ] - where - renderProgressIndex :: Maybe (Int, Int) -> T.Text - renderProgressIndex = maybe "" $ \(start, end) -> +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 + , "Skipping " + , infx + , runModuleName mn + ] + 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. -- -- This type exists to make two things abstract: @@ -109,10 +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 -> 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. @@ -136,13 +227,31 @@ 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 -- ^ The path to the output directory -> m CacheDb -readCacheDb' outputDir = - fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) +readCacheDb' outputDir = do + mdb <- readJSONFile (cacheDbFile outputDir) + pure $ fromMaybe mempty $ do + db <- mdb + guard $ cacheDbIsCurrentVersion db + pure $ fromCacheDbVersioned db writeCacheDb' :: (MonadIO m, MonadError MultipleErrors m) @@ -151,7 +260,7 @@ writeCacheDb' -> CacheDb -- ^ The CacheDb to be written -> m () -writeCacheDb' = writeJSONFile . cacheDbFile +writeCacheDb' = (. toCacheDbVersioned) . writeJSONFile . cacheDbFile writePackageJson' :: (MonadIO m, MonadError MultipleErrors m) @@ -162,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 @@ -174,7 +317,19 @@ 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 + readWarnings + codegen + ffiCodegen + progress + readCacheDb + writeCacheDb + writePackageJson + outputPrimDocs where getInputTimestampsAndHashes @@ -195,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 @@ -234,21 +387,44 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = then Just externsTimestamp else Nothing + updateOutputTimestamp :: ModuleName -> Maybe UTCTime -> Make Bool + updateOutputTimestamp mn mbTime = do + curTime <- maybe getCurrentTime pure mbTime + ok <- setTimestamp (outputFilename mn externsFileName) curTime + _ <- 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, 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 (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 @@ -314,7 +490,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling " + 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 3eba2359a3..72a6aae980 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,9 +1,11 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) - , buildJobSuccess + , Options(..) + , getBuildReason , construct , getResult + , getPrevResult , collectResults , markComplete , needsRebuild @@ -11,73 +13,99 @@ 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 (foldM, guard) import Control.Monad.Base (liftBase) -import Control.Monad (foldM) -import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +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, mapMaybe) +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, 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) +import Control.Applicative ((<|>)) + +data Prebuilt = Prebuilt + { 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 (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 } -data Prebuilt = Prebuilt - { pbModificationTime :: UTCTime - , pbExternsFile :: ExternsFile - } - 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 - -- ^ Succeeded, with warnings and externs + = 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 - + -- ^ 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) +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 - { 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. - } + , 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 +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. @@ -88,8 +116,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 @@ -101,11 +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 prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) - barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan - pure (M.union prebuiltResults barrierResults) +collectResults buildPlan withPrebuilt = do + let mapExts pb = BuildJobSucceeded Nothing (pbWarnings pb) (pbExterns pb) Nothing + let prebuiltResults = + M.map mapExts (bpPrebuilt buildPlan) + + barrierResults <- traverse (C.readMVar . bjResult) $ bpBuildJobs buildPlan + 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. @@ -113,14 +146,47 @@ getResult :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> m (Maybe (MultipleErrors, ExternsFile)) + -> m (Maybe (ExternsFile, Maybe ExternsDiff)) getResult buildPlan moduleName = - case M.lookup moduleName (bpPrebuilt buildPlan) of - Just es -> - pure (Just (MultipleErrors [], pbExternsFile es)) + 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 - r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) - pure $ buildJobSuccess r + let exts = pbExterns + $ fromMaybe (barrierError "getResult") + $ M.lookup moduleName (bpPrebuilt buildPlan) + 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 (ExternsFile, MultipleErrors) +getPrevResult buildPlan moduleName = + (,) <$> 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. -- @@ -128,29 +194,98 @@ getResult buildPlan moduleName = -- determine whether a module needs rebuilding. construct :: forall m. MonadBaseControl IO m - => MakeActions m + => Options + -> MakeActions m -> CacheDb - -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) + -> ([CST.PartialResult Module], ModuleGraph') -> m (BuildPlan, CacheDb) -construct MakeActions{..} cacheDb (sorted, graph) = do - let sortedModuleNames = map (getModuleName . CST.resPartial) sorted +construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do + let sortedModuleNames = map getMName 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 will be required during the build. + let toLoadPrebuilt = + if optPreloadAllExterns + then prebuiltMap + else M.filterWithKey (const . inBuildDeps) prebuiltMap + + -- We will need previously built results for modules to be built + -- to skip rebuilding if deps have not changed. + let toLoadPrev = + M.mapMaybeWithKey + ( \mn (mbRebuildReason, mbTs) -> do + -- We load previous build result for all up-to-date modules, and + -- 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 loadPrevious toLoadPrebuilt) + (A.mapConcurrently id $ M.mapWithKey + (\mn (up, ts) -> fmap (up,) <$> loadPrevious mn ts) toLoadPrev) + + let prebuilt = M.mapMaybe id prebuiltLoad + let previous = M.mapMaybe id prevLoad + + -- 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) + env <- C.newMVar primEnv idx <- C.newMVar 1 pure - ( BuildPlan prebuilt buildJobs env idx + ( BuildPlan prebuilt previous noPrebuilt 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 + 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. + 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 pure (M.insert moduleName buildJob prev) @@ -160,57 +295,84 @@ construct MakeActions{..} cacheDb (sorted, graph) = do inputInfo <- getInputTimestampsAndHashes moduleName case inputInfo of Left RebuildNever -> do - prebuilt <- findExistingExtern moduleName + timestamp <- fmap OutputTimestamp <$> getOutputTimestamp moduleName pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = True - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = True + -- rsRebuildReason: Nothing -- if not prebuilt? + , rsPrevious = timestamp + , rsNewCacheInfo = Nothing + , rsUpToDate = True }) Left RebuildAlways -> do pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = Nothing - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrevious = Nothing + , rsNewCacheInfo = Nothing + , rsUpToDate = False }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory - (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo - prebuilt <- - if isUpToDate - then findExistingExtern moduleName - else pure Nothing + (newCacheInfo, upToDate) <- checkChanged cacheDb moduleName cwd cacheInfo + timestamp <- fmap OutputTimestamp <$> getOutputTimestamp moduleName + pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Just newCacheInfo + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrevious = timestamp + , rsNewCacheInfo = Just newCacheInfo + , rsUpToDate = upToDate }) - 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 - -maximumMaybe :: Ord a => [a] -> Maybe a + moduleDeps = map snd . fromMaybe graphError . flip lookup graph + where + graphError = internalError "make: module not found in dependency graph." + + 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 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 + -- 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. + 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 (mbReason, t) = (M.insert mn (mbReason, Just t) build, prebuilt) + toPrebuilt v = (build, M.insert mn v prebuilt) + +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 092544fa73..1c26218cfd 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -4,8 +4,10 @@ module Language.PureScript.Make.Cache , CacheDb , CacheInfo(..) , checkChanged - , removeModules , normaliseForCache + , cacheDbIsCurrentVersion + , toCacheDbVersioned + , fromCacheDbVersioned ) where import Prelude @@ -22,15 +24,19 @@ 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) +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 +69,34 @@ hash = ContentHash . Hash.hash type CacheDb = Map ModuleName CacheInfo +data CacheDbVersioned = CacheDbVersioned { cdbVersion :: Text, cdbModules :: CacheDb } + 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 @@ -70,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 @@ -98,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 @@ -126,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 new file mode 100644 index 0000000000..d0cf298ba4 --- /dev/null +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -0,0 +1,550 @@ +module Language.PureScript.Make.ExternsDiff + ( ExternsDiff(..) + , RefStatus(..) + , DiffRef(..) + , Ref(..) + , isEmpty + , 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 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 + +-- 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) + | -- 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 (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] + deriving (Eq, Ord, 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)) + +type RefsWithStatus = M.Map Ref RefStatus + +type ModuleRefsMap = Map ModuleName (Set Ref) + +data ExternsDiff = ExternsDiff + { edModuleName :: ModuleName, edRefs :: Map Ref RefStatus } + deriving (Eq, Ord, 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 = + 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 = 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 refineDeclaration . 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 -- 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. + 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 + -- (because the instance change affects modules that use + -- the type class/its methods). + [] + _ -> + -- 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) + + -- 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 by + -- combining Declarations, Fixities and Type Fixities - as they are + -- separated in externs we handle them separately. We don't care about added things. + (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 $ + 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 +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 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) (S.toList deps)) + + -- 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 + 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 result because a node's reachable list includes the node + -- itself). + affectedLocalRefs = + S.fromList $ + map fst $ + filter (any (flip elem (fst <$> affectedByChanged)) . snd) refsGraph + +-- 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 + 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 + +-- 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 = 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 + -- Check if the module reexports any of searched refs. + 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. + anyUsages = + foldMap checkUsageInTypes decls + <> foldMap checkOtherUsages decls + + -- 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 + + -- 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 + checkValue = check . map ValueRef + checkValueOp = check . map ValueOpRef + checkCtor = check . map (ConstructorRef emptyName) + checkClass = check . map TypeClassRef + + -- 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 + + checkOtherUsages = + let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty + in extr mempty + + goDecl _ = \case + P.TypeInstanceDeclaration _ _ _ _ _ _ tc _ _ -> + 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 + _ -> 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 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] -> 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 + 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 (mn, qual,) . M.keysSet) $ case dt of + P.Explicit dRefs + | Just ref <- searchRef removed refs -> Left (mn, ref) + | otherwise -> + -- Search only refs encountered in the import. + Right $ M.filterWithKey (const . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + P.Hiding dRefs + | Just ref <- searchRef removed refs -> Left (mn, ref) + | otherwise -> + -- Search only refs not encountered in the import. + Right $ M.filterWithKey (const . not . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + -- Search all changed refs. + P.Implicit -> Right diffs + go s _ = Right 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) + +-- | 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, 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) +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" + +-- | 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 + | 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 _ + | P.isDictTypeName n -> Nothing + | otherwise -> + Just + ( ConstructorRef tn n + , -- 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). + -- 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. + typeDeps t <> S.fromList [(moduleName, TypeRef tn), (moduleName, CtorsSetRef tn)] + ) + -- + 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 + ) + + +-- | 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 + 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 8c86144e9a..838ab2a5e3 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -5,12 +5,16 @@ module Language.PureScript.Make.Monad , makeIO , getTimestamp , getTimestampMaybe + , getCurrentTime + , setTimestamp , readTextFile , readJSONFile , readJSONFileIO , readCborFile , readCborFileIO , readExternsFile + , readWarningsFile + , removeFileIfExists , hashFile , writeTextFile , writeJSONFile @@ -24,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(..)) @@ -35,14 +39,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, removeFile, setModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) @@ -85,6 +91,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 @@ -127,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/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) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 610e8465c8..2954cecf7d 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -1,176 +1,192 @@ -- 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 +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.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, writeUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT, writeUTF8FileT) -import Test.Hspec (Spec, before_, it, shouldReturn) - -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 +import Data.Time (getCurrentTime) +import Test.Hspec (Spec, before_, it, shouldBe, shouldReturn, shouldSatisfy) spec :: Spec spec = do - let sourcesDir = "tests/purs/make" - let moduleNames = Set.fromList . map P.moduleNameFromString - before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do - it "does not recompile if there are no changes" $ do - let modulePath = sourcesDir "Module.purs" + -- Before each test. + before_ cleanUp $ do - writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - compile [modulePath] `shouldReturn` moduleNames [] + -- RESULTING EXTERNS - it "recompiles if files have changed" $ do - let modulePath = sourcesDir "Module.purs" + 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 - 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"] + c1 `shouldBe` moduleNames ["A", "B"] + length exts1 `shouldBe` 2 - it "does not recompile if hashes have not changed" $ do - let modulePath = sourcesDir "Module.purs" - moduleContent = "module Module where\nfoo = 0\n" + ((Right exts2, _), c2) <- compileAll + c2 `shouldBe` moduleNames [] - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent - compile [modulePath] `shouldReturn` moduleNames [] + length exts2 `shouldBe` 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" + 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 - writeFileWithTimestamp modulePath1 timestampA moduleContent - writeFileWithTimestamp modulePath2 timestampA moduleContent + c1 `shouldBe` moduleNames ["A", "B"] + length exts1 `shouldBe` 2 - compile [modulePath1] `shouldReturn` moduleNames ["Module"] - compile [modulePath2] `shouldReturn` moduleNames ["Module"] + writeModule "A" "module A where foo = 2" - it "recompiles if an FFI file was added" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" - moduleContent = "module Module where\nfoo = 0\n" + ((Right exts2, _), c2) <- compileAll + c2 `shouldBe` moduleNames ["A"] - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] + length exts2 `shouldBe` 2 - writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] + -- PRESERVING WARNINGS - it "recompiles if an FFI file was removed" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" - 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 - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - - writeFileWithTimestamp moduleAPath timestampD moduleAContent2 - compile modulePaths `shouldReturn` moduleNames ["A", "B"] + -- 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 + + -- CACHE DB + + it "recompiles if cache-db version differs from the current" $ do + writeModule "Module" "module Module where\nfoo :: Int\nfoo = 1\n" + compileAll >>= expectCompiled ["Module"] + + -- Replace version with illegal in cache-db file. + let cacheDbFilePath = P.cacheDbFile outputDir + 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 + + compileAll >>= expectCompiled ["Module"] + + -- COMPILATION SCENARIOS + + 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" + + writeModule "Module2" content + compileAll >>= expectCompiled [] 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 - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - - compile batch1 `shouldReturn` moduleNames [] - compile batch2 `shouldReturn` moduleNames [] + 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 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 + 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 modulePath = 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. - - writeFileWithTimestamp modulePath timestampA moduleContent1 + 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 mempty [mPath] >>= assertSuccess + + writeFile mPath timestampA mContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeFile mPath timestampB mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -178,30 +194,339 @@ 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" - 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. - - writeFileWithTimestamp modulePath timestampA moduleContent1 - go optsCorefnOnly `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + it "recompiles if CoreFn is 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" + 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"] + writeFile mPath timestampB mContent2 -- 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"] + + 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"] + + threadDelay oneSecond + + writeModule "A" "module A where\nfoo :: Char\nfoo = '0'\n" + compileAll >>= expectCompiledWithFailure ["A", "B"] + + threadDelay oneSecond + + writeModule "A" "module A where\nfoo :: Char\nfoo = '0'\nfar = 1" + compileAll >>= expectCompiledWithFailure ["A", "B"] + + 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"] + + writeModule "A" "module A where\nfoo :: Char\nfoo = 0\n" + compileAll >>= expectCompiledWithFailure ["A"] + + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\nzaar = 1" + compileAll >>= expectCompiled ["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 affected deps after the error fixed" $ 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"] + + -- REBUILD CUT OFF: rebuilds only modules that are affected by changes. + + -- RebuildReason:: LaterDependency + + 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" + + compileAll >>= expectCompiled ["A", "B", "C"] + + threadDelay oneSecond + + writeModule "A" "module A where\nfoo = '1'\n" + _ <- compileOne "A" + + compileAll >>= expectCompiled ["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 + + writeModule "A" "module A where\nfoo = 1\n" + _ <- compileOne "A" + + compileAll >>= expectCompiled ["B"] + + -- Check timestamp for C is modified. + tsB <- getOutputTimestamp "B" + tsC <- getOutputTimestamp "C" + tsC `shouldSatisfy` (<=) tsB + + 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" + + compileAll >>= expectCompiled ["A", "B", "C"] + + threadDelay oneSecond + + -- Change foo's type (effect on C). + writeModule "A" "module A where\nfoo = '1'\n" + _ <- compileOne "A" + + compileAll >>= expectCompiled ["B", "C"] + + -- RebuildReason: UpstreamRef + + 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] -- -- 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. @@ -216,61 +541,87 @@ 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 = \(P.CompilingModule mn _) -> - liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + (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 :: (CompileResult, 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 + compileWithResult mempty input >>= assertSuccess -compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) -compileAllowingFailures input = fmap snd (compileWithResult input) +compileWithFailure :: [FilePath] -> IO (Set P.ModuleName) +compileWithFailure input = + compileWithResult mempty input >>= assertFailure -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 -- | 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 146093c452..68df9f52cc 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -227,11 +227,11 @@ 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 <> "'." - 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