diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 15532faa32..b73b5cbdd3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -60,7 +60,7 @@ jobs: - image: quay.io/benz0li/ghc-musl:9.8.4 os: ubuntu-24.04-arm - - os: macos-13 # x64 + - os: macos-15-intel # x64 - os: macos-14 # arm64 - os: windows-2022 # x64 @@ -164,7 +164,7 @@ jobs: # Moreover, npm has a hook issue that will cause spago to fail to install # We upgrade npm to fix this run: | - apk add jq + apk add jq coreutils ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary diff --git a/CHANGELOG.d/fix_issue-4535.md b/CHANGELOG.d/fix_issue-4535.md deleted file mode 100644 index 77341885a9..0000000000 --- a/CHANGELOG.d/fix_issue-4535.md +++ /dev/null @@ -1 +0,0 @@ -* Fix compiler crash when a type operator is used in a type argument diff --git a/CHANGELOG.d/fix_issue-4545.md b/CHANGELOG.d/fix_issue-4545.md deleted file mode 100644 index 1d6462ee9c..0000000000 --- a/CHANGELOG.d/fix_issue-4545.md +++ /dev/null @@ -1 +0,0 @@ -* Speed up IDE performance on large projects diff --git a/CHANGELOG.d/internal_fix-typo-in-traversal.md b/CHANGELOG.d/internal_fix-typo-in-traversal.md new file mode 100644 index 0000000000..98dfa19747 --- /dev/null +++ b/CHANGELOG.d/internal_fix-typo-in-traversal.md @@ -0,0 +1 @@ +* Fix typo in CoreFn.Traversals.traverseCoreFn which caused it to not recurse into Let bodies diff --git a/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md b/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md deleted file mode 100644 index f7f622a96e..0000000000 --- a/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md +++ /dev/null @@ -1 +0,0 @@ -* Remove the step that upgraded Git from the CI workflow diff --git a/CHANGELOG.d/internal_tool_updates.md b/CHANGELOG.d/internal_tool_updates.md deleted file mode 100644 index 3dcd762162..0000000000 --- a/CHANGELOG.d/internal_tool_updates.md +++ /dev/null @@ -1,2 +0,0 @@ -* Update weeder version in CI to 2.9.0 -* Add happy ==2.0.2 as build-tool-depends diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md deleted file mode 100644 index 6622b6baed..0000000000 --- a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md +++ /dev/null @@ -1,2 +0,0 @@ -* Upgrade GHC to [`9.6.6`](https://downloads.haskell.org/~ghc/9.6.6/docs/users_guide/9.6.6-notes.html), Stackage LTS `22.43` -* Minimum required glibc version is bumped from [`2.28` to `2.31`](https://sourceware.org/glibc/wiki/Glibc%20Timeline) diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md deleted file mode 100644 index 7f3fb0e074..0000000000 --- a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md +++ /dev/null @@ -1,2 +0,0 @@ -* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` -* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI diff --git a/CHANGELOG.d/misc_ghc-bump.md b/CHANGELOG.d/misc_ghc-bump.md deleted file mode 100644 index a1222cf6d0..0000000000 --- a/CHANGELOG.d/misc_ghc-bump.md +++ /dev/null @@ -1 +0,0 @@ -* Update Stackage snapshot to lts-20.26 and GHC to 9.2.8 diff --git a/CHANGELOG.d/misc_static_linking.md b/CHANGELOG.d/misc_static_linking.md deleted file mode 100644 index 3a4ec56549..0000000000 --- a/CHANGELOG.d/misc_static_linking.md +++ /dev/null @@ -1,4 +0,0 @@ -* Enable statically-linked binaries using [ghc-musl](https://github.com/benz0li/ghc-musl) -* Update haskeline version bounds to >=0.8.2.1 && <0.9 - - Consequently, this fixes Cabal-based builds on GHC 9.8.4 diff --git a/CHANGELOG.md b/CHANGELOG.md index 27a87cc478..d2dbd016b3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,40 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.16 + +Bugfixes: + +* Fix compiler crash when a type operator is used in a type argument (#4536 by @purefunctor) + +* Speed up IDE performance on large projects (#4546 by @roryc89) + +* Fix double click select of titles in generated documentation (#4579 by @ad-si) + +Other improvements: + +* Update Stackage snapshot to lts-20.26 and GHC to 9.2.8 (#4537 by @purefunctor) + +* Enable statically-linked binaries using [ghc-musl](https://github.com/benz0li/ghc-musl) (#4573 by @purefunctor) +* Update haskeline version bounds to >=0.8.2.1 && <0.9 + + Consequently, this fixes Cabal-based builds on GHC 9.8.4 + +Internal: + +* Remove the step that upgraded Git from the CI workflow (#4541 by @rhendric) + +* Upgrade GHC to [`9.6.6`](https://downloads.haskell.org/~ghc/9.6.6/docs/users_guide/9.6.6-notes.html), Stackage LTS `22.43` (#4568 by @ad-si) +* Minimum required glibc version is bumped from [`2.28` to `2.31`](https://sourceware.org/glibc/wiki/Glibc%20Timeline) + +* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` (#4574 by @ad-si) +* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI + +* Update weeder version in CI to 2.9.0 (#4573 by @purefunctor) +* Add happy ==2.0.2 as build-tool-depends + +* Use `-fspecialize-aggressively` GHC option to improve compiler performance by ~30% on large builds (#4584 by @seastian) + ## 0.15.15 New features: diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index cfbb98e362..3a4fb44ab8 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -169,6 +169,7 @@ If you would prefer to use different terms, please use the section below instead | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license] | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license] | | [@roryc89](https://github.com/roryc89) | Rory Campbell | [MIT license] | +| [@drathier](https://github.com/drathier) | Drathier | [MIT license] | ### Contributors using Modified Terms diff --git a/LICENSE b/LICENSE index 86b917570e..6b8251ded8 100644 --- a/LICENSE +++ b/LICENSE @@ -94,7 +94,6 @@ PureScript uses the following Haskell library packages. Their license files foll ghc-prim half happy - happy-lib hashable haskeline indexed-traversable diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..c0ed9c8472 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 (MakeOptions(..), 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) @@ -30,6 +31,9 @@ data PSCMakeOptions = PSCMakeOptions , pscmInputFromFile :: Maybe FilePath , pscmExclude :: [FilePath] , pscmOutputDir :: FilePath + , pscmLogFile :: FilePath + , pscmNoDiffCheck :: Bool + , pscmIncWarnings :: Bool , pscmOpts :: P.Options , pscmUsePrefix :: Bool , pscmJSONErrors :: Bool @@ -68,12 +72,23 @@ compile PSCMakeOptions{..} = do ] exitFailure moduleFiles <- readUTF8FilesT input + + _ <- createDirectoryIfMissing True pscmOutputDir + let logFile = pscmOutputDir pscmLogFile + 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 } + let makeOpts = MakeOptions + { moCollectAll = not pscmIncWarnings + , moDiffCheck = not pscmNoDiffCheck + } + P.make' makeOpts makeActions (map snd ms) printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess @@ -119,6 +134,28 @@ codegenTargets = Opts.option targetParser $ <> " The default target is 'js', but if this option is used only the targets specified will be used." ) +compileLogFile :: Opts.Parser FilePath +compileLogFile = Opts.strOption $ + Opts.short 'l' + <> Opts.long "log-file" + <> Opts.value "compile.log" + <> Opts.showDefault + <> Opts.help + "File name for compile progress log put in output directory." + +noDiffCheck :: Opts.Parser Bool +noDiffCheck = Opts.switch $ + Opts.long "no-diff-check" + <> Opts.help + ( "Disable module external changes check while incremental build." + <> " Useful for diagnosing an unexpected build result." + ) + +incWarnings :: Opts.Parser Bool +incWarnings = Opts.switch $ + Opts.long "incremental-warnings" + <> Opts.help "Output warnings only for incrementally compiled modules." + targetsMessage :: String targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'." @@ -147,6 +184,9 @@ pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile <*> SharedCLI.globInputFile <*> many SharedCLI.excludeFiles <*> outputDirectory + <*> compileLogFile + <*> noDiffCheck + <*> incWarnings <*> options <*> (not <$> noPrefix) <*> jsonErrors diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index f11b556871..174757d384 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -16,7 +16,7 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago@0.93.43 +which spago || npm install spago echo ::endgroup:: echo ::group::Create dummy project diff --git a/ci/build.sh b/ci/build.sh index c551dfd51a..180c3545a3 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -176,9 +176,11 @@ tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 (echo "::endgroup::"; echo "::group::Build and test PureScript") 2>/dev/null pushd sdist-test -# Haddock -Werror goes here to keep us honest but prevent failing on -# documentation errors in dependencies -$STACK build $STACK_OPTS --haddock-arguments --optghc=-Werror +# --ghc-options -Werror applies only to local packages, catching our own +# haddock doc-comment errors without failing on warnings in dependencies. +# (--haddock-arguments --optghc=-Werror would pass -Werror to all packages +# via haddock, which breaks when the dependency cache is cold.) +$STACK build $STACK_OPTS --ghc-options -Werror if [ "$do_prerelease" ] then diff --git a/license-generator/generate.hs b/license-generator/generate.hs index f755ee8c2d..09f7ab89b6 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -79,6 +79,7 @@ depsNamesAndVersions = do name == "purescript" || name == "rts" || name == "ghc-boot-th" + || name == "happy-lib" parse line = case splitOn " " line of diff --git a/npm-package/package.json b/npm-package/package.json index 56772d2b55..a1bbc7f452 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.15", + "version": "0.15.16", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.15", + "postinstall": "install-purescript --purs-ver=0.15.16", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 7601ec3954..13c2b9d1c8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.15 +version: 0.15.16 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -335,7 +335,9 @@ library Language.PureScript.Make.Actions Language.PureScript.Make.BuildPlan Language.PureScript.Make.Cache + Language.PureScript.Make.ExternsDiff Language.PureScript.Make.Monad + Language.PureScript.Make.Patch Language.PureScript.ModuleDependencies Language.PureScript.Names Language.PureScript.Options @@ -487,6 +489,8 @@ test-suite tests TestSourceMaps TestUtils Paths_purescript + autogen-modules: + Paths_purescript flag static description: Builds a statically-linked version of the PureScript compiler. diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 1f427755f0..b39b28ff51 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} -- | -- Case binders -- @@ -7,12 +7,14 @@ 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(..)) import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified) import Language.PureScript.Comments (Comment) import Language.PureScript.Types (SourceType) +import Data.Data (Data) -- | -- Data type for binders @@ -64,7 +66,7 @@ data Binder -- A binder with a type annotation -- | TypedBinder SourceType Binder - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, 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..b51579dccd 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} -- | @@ -33,6 +33,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Comments (Comment) import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind) import Language.PureScript.Constants.Prim qualified as C +import Data.Data (Data) -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] @@ -50,7 +51,7 @@ data TypeSearch -- ^ Record fields that are available on the first argument to the typed -- hole } - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) @@ -90,7 +91,7 @@ data ErrorMessageHint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) | RelatedPositions (NEL.NonEmpty SourceSpan) - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- | Categories of hints data HintCategory @@ -101,7 +102,7 @@ data HintCategory | SolverHint | DeclarationHint | OtherHint - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData, Data) -- | -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented @@ -112,7 +113,7 @@ data UnknownsHint = NoUnknowns | Unknowns | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]])) - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- | -- A module declaration, consisting of comments about the module, a module name, @@ -165,7 +166,7 @@ importPrim = . addDefaultImport (Qualified ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed - deriving (Show, Generic, NFData, Serialise) + deriving (Eq, Show, Generic, NFData, Data, Serialise) -- | -- An item in a list of explicit imports or exports @@ -204,7 +205,7 @@ data DeclarationRef -- elaboration in name desugaring. -- | ReExportRef SourceSpan ExportSource DeclarationRef - deriving (Show, Generic, NFData, Serialise) + deriving (Show, Generic, NFData, Serialise, Data) instance Eq DeclarationRef where (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' @@ -244,7 +245,7 @@ data ExportSource = { exportSourceImportedFrom :: Maybe ModuleName , exportSourceDefinedIn :: ModuleName } - deriving (Eq, Ord, Show, Generic, NFData, Serialise) + deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise) declRefSourceSpan :: DeclarationRef -> SourceSpan declRefSourceSpan (TypeRef ss _ _) = ss @@ -306,7 +307,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Eq, Show, Generic, Serialise, NFData) + deriving (Eq, Show, Generic, Serialise, NFData, Data) isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True @@ -323,7 +324,7 @@ data RoleDeclarationData = RoleDeclarationData { rdeclSourceAnn :: !SourceAnn , rdeclIdent :: !(ProperName 'TypeName) , rdeclRoles :: ![Role] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Data, Serialise) -- | A type declaration assigns a type to an identifier, eg: -- @@ -334,7 +335,7 @@ data TypeDeclarationData = TypeDeclarationData { tydeclSourceAnn :: !SourceAnn , tydeclIdent :: !Ident , tydeclType :: !SourceType - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Data, Serialise) getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d @@ -356,7 +357,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, Data) getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d @@ -370,7 +371,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration { dataCtorAnn :: !SourceAnn , dataCtorName :: !(ProperName 'ConstructorName) , dataCtorFields :: ![(Ident, SourceType)] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Data, Serialise) mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. } @@ -445,13 +446,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, Data, Serialise) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise) data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Data, 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 +463,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T data InstanceDerivationStrategy = KnownClassStrategy | NewtypeStrategy - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- | The members of a type class instance declaration data TypeInstanceBody @@ -472,7 +473,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, Data, Serialise) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -488,7 +489,7 @@ data KindSignatureFor | NewtypeSig | TypeSynonymSig | ClassSig - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise) declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa @@ -625,13 +626,13 @@ flattenDecls = concatMap flattenOne -- data Guard = ConditionGuard Expr | PatternGuard Binder Expr - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, 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, Data, Serialise) pattern MkUnguarded :: Expr -> GuardedExpr pattern MkUnguarded e = GuardedExpr [] e @@ -762,7 +763,7 @@ data Expr -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- | -- Metadata that tells where a let binding originated @@ -776,7 +777,7 @@ data WhereProvenance -- The let binding was always a let binding -- | FromLet - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- | -- An alternative in a case statement @@ -790,7 +791,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: [GuardedExpr] - } deriving (Show, Generic, NFData) + } deriving (Show, Generic, NFData, Data, Serialise) -- | -- A statement in a do-notation block @@ -812,7 +813,7 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) -- For a record update such as: @@ -839,15 +840,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, Data) + 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, Data, 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, Data) + 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..c591efe319 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.AST.Declarations.ChainId - ( ChainId + ( ChainId(..) , mkChainId ) where @@ -7,6 +8,7 @@ import Prelude import Language.PureScript.AST.SourcePos qualified as Pos import Control.DeepSeq (NFData) import Codec.Serialise (Serialise) +import Data.Data (Data) -- | -- For a given instance chain, stores the chain's file name and @@ -14,7 +16,7 @@ import Codec.Serialise (Serialise) -- This data is used to determine which instances are part of -- the same instance chain. newtype ChainId = ChainId (String, Pos.SourcePos) - deriving (Eq, Ord, Show, NFData, Serialise) + deriving (Eq, Ord, Show, NFData, Serialise, Data) mkChainId :: String -> Pos.SourcePos -> ChainId mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos) diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index 05e06ab8f9..a92d88d7e2 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} -- | -- The core functional representation for literal values. -- 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) +import Data.Data (Data) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and @@ -38,4 +40,4 @@ data Literal a -- An object literal -- | ObjectLiteral [(PSString, a)] - deriving (Eq, Ord, Show, Functor, Generic, NFData) + deriving (Eq, Ord, Show, Functor, Generic, NFData, Data, Serialise) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index eb217a2444..cce8260f7b 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- | -- Operators fixity and associativity -- @@ -12,6 +13,7 @@ import Data.Aeson ((.=)) import Data.Aeson qualified as A import Language.PureScript.Crash (internalError) +import Data.Data (Data) -- | -- A precedence level for an infix operator @@ -22,7 +24,7 @@ type Precedence = Integer -- Associativity for infix operators -- data Associativity = Infixl | Infixr | Infix - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Associativity instance Serialise Associativity @@ -48,7 +50,7 @@ instance A.FromJSON Associativity where -- Fixity data for infix operators -- data Fixity = Fixity Associativity Precedence - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Fixity instance Serialise Fixity diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 262d44b6a1..491defd9a5 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} -- | -- Source position information -- @@ -15,6 +15,7 @@ import Language.PureScript.Comments (Comment) import Data.Aeson qualified as A import Data.Text qualified as T import System.FilePath (makeRelative) +import Data.Data (Data) -- | Source annotation - position information and comments. type SourceAnn = (SourceSpan, [Comment]) @@ -25,7 +26,7 @@ data SourcePos = SourcePos -- ^ Line number , sourcePosColumn :: Int -- ^ Column number - } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + } deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) displaySourcePos :: SourcePos -> Text displaySourcePos sp = @@ -53,7 +54,7 @@ data SourceSpan = SourceSpan -- ^ Start of the span , spanEnd :: SourcePos -- ^ End of the span - } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + } deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = @@ -116,3 +117,6 @@ widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) = widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, []) + +modifySpanName :: (String -> String) -> SourceSpan -> SourceSpan +modifySpanName onName (SourceSpan spn sps spe) = SourceSpan (onName spn) sps spe diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index f40cc44e9f..37bed52787 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -4,7 +4,7 @@ -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final JavaScript bundle. -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} module Language.PureScript.Bundle ( ModuleIdentifier(..) , ModuleType(..) @@ -19,11 +19,13 @@ module Language.PureScript.Bundle import Prelude +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson ((.=)) import Data.Char (chr, digitToInt) +import Data.Data (Data) import Data.Foldable (fold) import Data.Maybe (mapMaybe, maybeToList) import Data.Aeson qualified as A @@ -46,14 +48,14 @@ data ErrorMessage | ErrorInModule ModuleIdentifier ErrorMessage | MissingEntryPoint String | MissingMainModule String - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, 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, Data, Serialise) showModuleType :: ModuleType -> String showModuleType Regular = "Regular" @@ -61,7 +63,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, Data, Serialise) instance A.ToJSON ModuleIdentifier where toJSON (ModuleIdentifier name mt) = diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 59b68adf1d..db1a5ff5ff 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -445,7 +445,7 @@ convertBinder fileName = go convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of - DeclData _ (DataHead _ a vars) bd -> do + DeclData _ (DataHead _ a vars) bd deriveClauses -> do let ctrs :: SourceToken -> DataCtor b -> [(SourceToken, DataCtor b)] -> [AST.DataConstructorDeclaration] ctrs st (DataCtor _ name fields) tl @@ -454,15 +454,17 @@ convertDeclaration fileName decl = case decl of [] -> [] (st', ctor) : tl' -> ctrs st' ctor tl' ) - pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) + AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) + : convertDeriveClauses fileName (nameValue a) deriveClauses DeclType _ (DataHead _ a vars) _ bd -> pure $ AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd) - DeclNewtype _ (DataHead _ a vars) st x ys -> do + DeclNewtype _ (DataHead _ a vars) st x ys deriveClauses -> do let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(headDef (internalError "No constructor name") ctrFields, convertType fileName ys)]] - pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs + AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs + : convertDeriveClauses fileName (nameValue a) deriveClauses DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let goTyVar (TypeVarKinded (Wrapped _ (Labeled (_, a) _ _) _)) = nameValue a @@ -553,25 +555,8 @@ convertDeclaration fileName decl = case decl of mkPartialInstanceName :: Maybe (Name Ident, SourceToken) -> QualifiedName (N.ProperName 'N.ClassName) -> [Type a] -> Either Text.Text N.Ident mkPartialInstanceName nameSep cls args = - maybe (Left genName) (Right . ident . nameValue . fst) nameSep + maybe (Left (genInstanceName cls (foldMap argName args))) (Right . ident . nameValue . fst) nameSep where - -- truncate to 25 chars to reduce verbosity - -- of name and still keep it readable - -- name will be used to create a GenIdent - -- in desugaring process - genName :: Text.Text - genName = Text.take 25 (className <> typeArgs) - - className :: Text.Text - className - = foldMap (uncurry Text.cons . first toLower) - . Text.uncons - . N.runProperName - $ qualName cls - - typeArgs :: Text.Text - typeArgs = foldMap argName args - argName :: Type a -> Text.Text argName = \case -- These are only useful to disambiguate between overlapping instances @@ -619,6 +604,36 @@ convertDeclaration fileName decl = case decl of else (fst $ qualRange cls, snd $ typeRange $ last args) +convertDeriveClauses + :: String + -> N.ProperName 'N.TypeName + -> [DeriveClause] + -> [AST.Declaration] +convertDeriveClauses fileName tyName = concatMap go + where + go (DeriveClause _ (Wrapped _ classes _)) = map convertClass (toList classes) + convertClass (DeriveClass cls) = + AST.TypeInstanceDeclaration clsAnn clsAnn chainId 0 (Left genName) + [] + (qualified cls) + [tyCon] + AST.DerivedInstance + where + clsAnn = uncurry (sourceAnnCommented fileName) (qualRange cls) + chainId = mkChainId fileName (Pos.spanStart (fst clsAnn)) + tyCon = T.TypeConstructor clsAnn (N.Qualified N.ByNullSourcePos tyName) + genName = genInstanceName cls (N.runProperName tyName) + +genInstanceName :: QualifiedName (N.ProperName 'N.ClassName) -> Text.Text -> Text.Text +genInstanceName cls typeArgs = Text.take 25 (className <> typeArgs) + where + className :: Text.Text + className + = foldMap (uncurry Text.cons . first toLower) + . Text.uncons + . N.runProperName + $ qualName cls + convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration convertSignature fileName (Labeled a _ b) = do let diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 3682f2f0a5..f115dec2e7 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} module Language.PureScript.CST.Errors ( ParserErrorInfo(..) , ParserErrorType(..) @@ -12,14 +12,16 @@ 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) import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..)) import Text.Printf (printf) +import Data.Data (Data) data ParserErrorType = ErrWildcardInType @@ -59,7 +61,7 @@ data ParserErrorType | ErrConstraintInForeignImportSyntax | ErrEof | ErrCustom String - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) data ParserWarningType = WarnDeprecatedRowSyntax @@ -67,14 +69,14 @@ data ParserWarningType | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax | WarnDeprecatedCaseOfOffsideSyntax - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) data ParserErrorInfo a = ParserErrorInfo { errRange :: SourceRange , errToks :: [SourceToken] , errStack :: LayoutStack , errType :: a - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Generic, NFData, Data, Serialise) type ParserError = ParserErrorInfo ParserErrorType type ParserWarning = ParserErrorInfo ParserWarningType diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index 890614070d..3f2e4cda94 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -205,11 +205,12 @@ flattenRole = pure . roleTok flattenDeclaration :: Declaration a -> DList SourceToken flattenDeclaration = \case - DeclData _ a b -> + DeclData _ a b drvs -> flattenDataHead a <> - foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b - DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c - DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d + foldMap (\(t, ctrs) -> pure t <> flattenSeparated flattenDataCtor ctrs) b <> + foldMap flattenDeriveClause drvs + DeclType _ a b c -> flattenDataHead a <> pure b <> flattenType c + DeclNewtype _ a b c d drvs -> flattenDataHead a <> pure b <> flattenName c <> flattenType d <> foldMap flattenDeriveClause drvs DeclClass _ a b -> flattenClassHead a <> foldMap (\(c, d) -> pure c <> foldMap (flattenLabeled flattenName flattenType) d) b @@ -222,6 +223,16 @@ flattenDeclaration = \case DeclRole _ a b c d -> pure a <> pure b <> flattenName c <> foldMap flattenRole d DeclValue _ a -> flattenValueBindingFields a + where + flattenDeriveClass :: DeriveClass -> DList SourceToken + flattenDeriveClass (DeriveClass cls) = + flattenQualifiedName cls + + flattenDeriveClause :: DeriveClause -> DList SourceToken + flattenDeriveClause (DeriveClause kw classes) = + pure kw <> + flattenWrapped (flattenSeparated flattenDeriveClass) classes + flattenQualifiedName :: QualifiedName a -> DList SourceToken flattenQualifiedName = pure . qualTok diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 2f41df6b4f..d0d45094bf 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -166,11 +166,12 @@ -- "body of a case of expression" by pushing 'LytOf' onto the layout stack. -- Insert the @of@ token into the stream of tokens. -- -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} 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 @@ -178,6 +179,7 @@ import Data.Foldable (find) import Data.Function ((&)) import GHC.Generics (Generic) import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..)) +import Data.Data (Data) type LayoutStack = [(SourcePos, LayoutDelim)] @@ -204,7 +206,7 @@ data LayoutDelim | LytOf | LytDo | LytAdo - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) isIndented :: LayoutDelim -> Bool isIndented = \case diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 55aa95da79..9560619a4a 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -661,10 +661,10 @@ import :: { Import () } | 'class' properName { ImportClass () $1 (getProperName $2) } decl :: { Declaration () } - : dataHead { DeclData () $1 Nothing } - | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } + : dataHead manyOrEmpty(deriveClause) { DeclData () $1 Nothing $2 } + | dataHead '=' sep(dataCtor, '|') manyOrEmpty(deriveClause) { DeclData () $1 (Just ($2, $3)) $4 } | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } - | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) } + | newtypeHead '=' properName typeAtom manyOrEmpty(deriveClause) {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4 $5) } | classHead { either id (\h -> DeclClass () h Nothing) $1 } | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 } | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) } @@ -681,6 +681,12 @@ decl :: { Declaration () } | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } +deriveClause :: { DeriveClause } + : 'derive' '(' sep(deriveClass, ',') ')' { DeriveClause $1 (Wrapped $2 $3 $4) } + +deriveClass :: { DeriveClass } + : qualProperName { DeriveClass (getQualifiedProperName $1) } + dataHead :: { DataHead () } : 'data' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 } diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 20d5724271..63282e4bef 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -157,14 +157,21 @@ dataMembersRange = \case DataAll _ a -> (a, a) DataEnumerated _ (Wrapped a _ b) -> (a, b) +deriveClauseRange :: DeriveClause -> TokenRange +deriveClauseRange (DeriveClause kw classes) = (kw, wrpClose classes) + declRange :: Declaration a -> TokenRange declRange = \case - DeclData _ hd ctors + DeclData _ hd ctors drvs + | _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs) | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs) | otherwise -> start where start = dataHeadRange hd DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b) - DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b) + DeclNewtype _ a _ _ b drvs + | _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs) + | otherwise -> start + where start = (fst $ dataHeadRange a, snd $ typeRange b) DeclClass _ hd body | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts) | otherwise -> start diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..b48b0c0dd9 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} -- | This module contains data types for the entire PureScript surface language. Every -- token is represented in the tree, and every token is annotated with -- whitespace and comments (both leading and trailing). This means one can write @@ -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) @@ -18,34 +19,43 @@ import GHC.Generics (Generic) import Language.PureScript.Names qualified as N import Language.PureScript.Roles qualified as R import Language.PureScript.PSString (PSString) +import Data.Data (Data) data SourcePos = SourcePos { srcLine :: {-# UNPACK #-} !Int , srcColumn :: {-# UNPACK #-} !Int - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Data) data SourceRange = SourceRange { srcStart :: !SourcePos , srcEnd :: !SourcePos - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Data) + +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, Data, Serialise) data LineFeed = LF | CRLF - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data, Serialise) data TokenAnn = TokenAnn { tokRange :: !SourceRange , tokLeadingComments :: ![Comment LineFeed] , tokTrailingComments :: ![Comment Void] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Data) data SourceStyle = ASCII | Unicode - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data) data Token = TokLeftParen @@ -81,16 +91,16 @@ data Token | TokLayoutSep | TokLayoutEnd | TokEof - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Data) data SourceToken = SourceToken { tokAnn :: !TokenAnn , tokValue :: !Token - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Data) data Ident = Ident { getIdent :: Text - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, NFData, Data) data Name a = Name { nameTok :: SourceToken @@ -194,10 +204,19 @@ data DataMembers a | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName))) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +data DeriveClass = DeriveClass + { dcClass :: QualifiedName (N.ProperName 'N.ClassName) + } deriving (Show, Eq, Ord, Generic) + +data DeriveClause = DeriveClause + { dclKeyword :: SourceToken + , dclClasses :: Wrapped (Separated DeriveClass) + } deriving (Show, Eq, Ord, Generic) + data Declaration a - = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) + = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) [DeriveClause] | DeclType a (DataHead a) SourceToken (Type a) - | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) + | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) [DeriveClause] | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) | DeclInstanceChain a (Separated (Instance a)) | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a) diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index ee05cd9c31..4330be1424 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} -- | -- Defines the types of source code comments @@ -12,11 +12,12 @@ import Data.Text (Text) import GHC.Generics (Generic) import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON) +import Data.Data (Data) data Comment = LineComment Text | BlockComment Text - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Comment instance Serialise Comment diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index f0684d34d5..4b5faa10cd 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -70,7 +70,7 @@ traverseCoreFn f g h i = (f', g', h', i') g' (Abs ann name e) = Abs ann name <$> g e g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts - g' (Let ann ds e) = Let ann <$> traverse f ds <*> g' e + g' (Let ann ds e) = Let ann <$> traverse f ds <*> g e g' e = pure e h' (LiteralBinder a b) = LiteralBinder a <$> handleLiteral h b 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/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index ea13066556..3aa045fc8c 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types , module ReExports @@ -16,6 +17,7 @@ import Data.Aeson.BetterErrors keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser', fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey, asString) +import Data.Data (Data) import Data.Map qualified as Map import Data.Time.Clock (UTCTime) import Data.Time.Format qualified as TimeFormat @@ -147,7 +149,7 @@ data Declaration = Declaration , declInfo :: DeclarationInfo , declKind :: Maybe KindInfo } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Declaration @@ -194,7 +196,7 @@ data DeclarationInfo -- operator's fixity. -- | AliasDeclaration P.Fixity FixityAlias - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData DeclarationInfo @@ -205,7 +207,7 @@ data KindInfo = KindInfo { kiKeyword :: P.KindSignatureFor , kiKind :: Type' } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData KindInfo @@ -293,7 +295,7 @@ data ChildDeclaration = ChildDeclaration , cdeclSourceSpan :: Maybe P.SourceSpan , cdeclInfo :: ChildDeclarationInfo } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData ChildDeclaration @@ -314,7 +316,7 @@ data ChildDeclarationInfo -- example, `pure` from `Applicative` would be `forall a. a -> f a`. -- | ChildTypeClassMember Type' - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData ChildDeclarationInfo @@ -385,6 +387,8 @@ data InPackage a deriving (Show, Eq, Ord, Generic) instance NFData a => NFData (InPackage a) +--instance Data a => Data (InPackage a) + instance Functor InPackage where fmap f (Local x) = Local (f x) @@ -568,6 +572,9 @@ asModule = <*> key "declarations" (eachInArray asDeclaration) <*> key "reExports" (eachInArray asReExport) +instance A.FromJSON Module where + parseJSON = toAesonParser displayPackageError asModule + asDeclaration :: Parse PackageError Declaration asDeclaration = Declaration <$> key "title" asText diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..2efc00d424 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.Environment where import Prelude @@ -8,6 +9,7 @@ import Control.Monad (unless) import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import Data.Aeson qualified as A +import Data.Data (Data) import Data.Foldable (find, fold) import Data.Functor ((<&>)) import Data.IntMap qualified as IM @@ -45,9 +47,10 @@ data Environment = Environment -- scope (ie dictionaries brought in by a constrained type). , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes - } deriving (Show, Generic) + } deriving (Show, Generic, Data) instance NFData Environment +instance Serialise Environment -- | Information about a type class data TypeClassData = TypeClassData @@ -71,9 +74,10 @@ data TypeClassData = TypeClassData -- ^ A sets of arguments that can be used to infer all other arguments. , typeClassIsEmpty :: Bool -- ^ Whether or not dictionaries for this type class are necessarily empty. - } deriving (Show, Generic) + } deriving (Show, Generic, Data) instance NFData TypeClassData +instance Serialise TypeClassData -- | A functional dependency indicates a relationship between two sets of -- type arguments in a class declaration. @@ -82,7 +86,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, Data) instance NFData FunctionalDependency instance Serialise FunctionalDependency @@ -137,7 +141,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) @@ -233,7 +237,7 @@ data NameVisibility -- ^ The name is defined in the current binding group, but is not visible | Defined -- ^ The name is defined in the another binding group, or has been made visible by a function binder - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Data) instance NFData NameVisibility instance Serialise NameVisibility @@ -248,7 +252,7 @@ data NameKind -- ^ A public value for a module member or foreign import declaration | External -- ^ A name for member introduced by foreign import - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Data) instance NFData NameKind instance Serialise NameKind @@ -265,7 +269,7 @@ data TypeKind -- ^ A local type variable | ScopedTypeVar -- ^ A scoped type variable - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Data) instance NFData TypeKind instance Serialise TypeKind @@ -276,7 +280,7 @@ data DataDeclType -- ^ A standard data constructor | Newtype -- ^ A newtype constructor - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData DataDeclType instance Serialise DataDeclType diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..d0cf4cfb84 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-} module Language.PureScript.Errors ( module Language.PureScript.AST , module Language.PureScript.Errors @@ -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) @@ -19,6 +20,7 @@ import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrdOn) +import Data.Data (Data) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Function (on) @@ -199,12 +201,12 @@ data SimpleErrorMessage | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool | CannotSkipTypeApplication SourceType | CannotApplyExpressionOfTypeOnType SourceType SourceType - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Data, Serialise) newtype ErrorSuggestion = ErrorSuggestion Text @@ -373,8 +375,9 @@ errorCode em = case unwrapErrorMessage em of newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] } - deriving stock (Show) - deriving newtype (Semigroup, Monoid, NFData) + deriving stock (Show, Data) + 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..bb0c229892 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,4 +1,4 @@ -{-# Language DeriveAnyClass #-} +{-# Language DeriveAnyClass, DeriveDataTypeable #-} -- | -- This module generates code for \"externs\" files, i.e. files containing only -- foreign import declarations. @@ -22,6 +22,7 @@ import Control.DeepSeq (NFData) import Control.Monad (join) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) +import Data.Data (Data) import Data.Foldable (fold) import Data.Text (Text) import Data.Text qualified as T @@ -61,7 +62,7 @@ data ExternsFile = ExternsFile -- ^ List of type and value declaration , efSourceSpan :: SourceSpan -- ^ Source span for error reporting - } deriving (Show, Generic, NFData) + } deriving (Show, Generic, NFData, Data) instance Serialise ExternsFile @@ -74,7 +75,7 @@ data ExternsImport = ExternsImport , eiImportType :: ImportDeclarationType -- | The imported-as name, for qualified imports , eiImportedAs :: Maybe ModuleName - } deriving (Show, Generic, NFData) + } deriving (Show, Generic, NFData, Data) instance Serialise ExternsImport @@ -89,7 +90,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, Data) instance Serialise ExternsFixity @@ -104,7 +105,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, Data) instance Serialise ExternsTypeFixity @@ -157,7 +158,7 @@ data ExternsDeclaration = , edInstanceNameSource :: NameSource , edInstanceSourceSpan :: SourceSpan } - deriving (Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData, Data) 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/Label.hs b/src/Language/PureScript/Label.hs index a5d080a76c..cfb669d998 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.Label (Label(..)) where import Prelude @@ -7,6 +8,7 @@ import Control.DeepSeq (NFData) import Data.Monoid () import Data.String (IsString(..)) import Data.Aeson qualified as A +import Data.Data (Data) import Language.PureScript.PSString (PSString) @@ -15,7 +17,7 @@ import Language.PureScript.PSString (PSString) -- because records are indexable by PureScript strings at runtime. -- newtype Label = Label { runLabel :: PSString } - deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) + deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic, Data) instance NFData Label instance Serialise Label diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5228dc86e6..850b705fe1 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' + , MakeOptions(..) + , defaultMakeOptions + , rebuildModule + -- Exported for external use (trypurescript) #4095 , rebuildModule' - , make , inferForeignModules , module Monad , module Actions @@ -13,56 +15,57 @@ import Prelude import Control.Concurrent.Lifted as C import Control.DeepSeq (force) -import Control.Exception.Lifted (onException, bracket_, evaluate) +import Control.Exception.Lifted (bracket_, evaluate, onException) 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.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, isJust) 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.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.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.Make.Actions as Actions +import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..)) +import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.Cache (replaceModules) +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 +77,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 +114,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 +124,57 @@ 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 + { moCollectAll :: Bool + -- ^ If to collect externs and preserved warnings for modules that are not + -- involved in the build. + , moDiffCheck :: Bool + } + +defaultMakeOptions :: MakeOptions +defaultMakeOptions = + MakeOptions {moCollectAll = True, moDiffCheck = True} + +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file +-- and an @externs.cbor@ file. -- --- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without --- having to typecheck those modules again. +-- 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' defaultMakeOptions + +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 {optPreloadAll = moCollectAll} + (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 +185,54 @@ 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 br warns exts _ -> + -- If not collecting all, take only compiled results. + if moCollectAll || isJust br then Right (exts, warns) else Left mempty BuildJobFailed errs -> Left errs BuildJobSkipped -> Left mempty in - M.mapEither splitResults <$> BuildPlan.collectResults buildPlan + M.mapEither splitResults <$> BuildPlan.collectResults buildPlan moCollectAll + + let successes = fmap fst successes' + let warnings = foldMap snd successes' - -- Write the updated build cache database to disk - writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb + -- Tell prebuilt warnings. + when moCollectAll $ tell warnings + + -- Write the updated build cache database to disk. We keep failed modules info from + -- previous run to avoid rebuild if then it's fixed with no changes. + writeCacheDb $ replaceModules (M.keysSet failures) cacheDb 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 +240,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 moCollectAll then + map lookupResult sortedModuleNames + else + mapMaybe (flip M.lookup successes) sortedModuleNames where checkModuleNames :: m () @@ -239,46 +281,101 @@ 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 + let + getModuleIndex = C.modifyMVar (bpIndex buildPlan) $ \idx -> pure (idx + 1, (idx, cnt)) + catchFailure moduleIndex = flip catchError $ \errs -> do + progress $ ModuleFailed moduleName moduleIndex errs + pure $ BuildJobFailed errs + + result <- 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 (BuildPlan.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 = + if moDiffCheck then filter (isDirect . ED.edModuleName) <$> sequenceA mbDiffs + else Nothing + + moduleIndex <- getModuleIndex + + catchFailure moduleIndex $ 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 + let extFp = spanName $ efSourceSpan exts + let wasMoved = fp /= extFp + (exts', warnings') <- + if wasMoved then + patchOutputModulePath moduleName (extFp, fp) (exts, warnings) + else + (exts, warnings) <$ updateOutputTimestamp moduleName Nothing + + progress $ SkippingModule moduleName moduleIndex + -- Prebuilt result warnings already contain parser warnings. + pure $ BuildJobSucceeded 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 $ BuildJobSucceeded (Just br) mempty 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..3d68603f30 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,14 +17,14 @@ 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) import Control.Monad.Supply (SupplyT) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (Value(String), (.=), object) +import Data.Aeson (Value(String), (.=), object, ToJSON, FromJSON) import Data.Bifunctor (bimap, first) import Data.Either (partitionEithers) import Data.Foldable (for_) @@ -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,12 @@ 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, 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) +import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVersion, fromCacheDbVersioned, normaliseForCache, toCacheDbVersioned) +import Language.PureScript.Make.Patch (patchCoreFnJSON, patchDocsModule, patchExterns, patchSourceMapJSON, patchWarnings) +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 +64,11 @@ 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 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,29 +76,102 @@ data RebuildPolicy = RebuildNever -- | Always rebuild this module | RebuildAlways + deriving (Show, Ord, Eq) + +-- | Specifies reason for module compilation while incremental build. +data RebuildReason + -- | Compiled because of RebuildAlways policy + = RebuildAlwaysPolicy + -- | Compiled because of no previously built result available + | NoCached + -- | Compiled because of no previously built result for one of dependencies is available. + | NoCachedDependency + -- | Compiled because the module has changed since its previous compilation. + | CacheOutdated + -- | Compiled because has later dependency (that previously has been built after the module). + | LaterDependency ModuleName + -- | Compiled because of (the first found) changed reference in a dependency. + | UpstreamRef ED.DiffRef deriving (Show, Eq, Ord) -- | Progress messages from the make process data ProgressMessage - = CompilingModule ModuleName (Maybe (Int, Int)) + = CompilingModule ModuleName (Int, Int) RebuildReason -- ^ Compilation started for the specified module - deriving (Show, Eq, Ord) + | SkippingModule ModuleName (Int, Int) + | ModuleCompiled ModuleName (Int, Int) NominalDiffTime (Maybe ED.ExternsDiff) MultipleErrors + | ModuleFailed ModuleName (Int, Int) MultipleErrors + deriving (Show) + +renderProgressIndex :: (Int, Int) -> T.Text +renderProgressIndex (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 -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) -> - 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' <> "] " +-- 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. -- @@ -109,10 +193,20 @@ 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. + , patchOutputModulePath :: ModuleName -> (FilePath, FilePath) -> (ExternsFile, MultipleErrors) -> m (ExternsFile, MultipleErrors) + -- ^ Patches source file path value of supplied externs and warnings, saves + -- them and also updates in place other build artifacts. , 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 -> 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 +230,20 @@ data MakeActions m = MakeActions cacheDbFile :: FilePath -> FilePath cacheDbFile = ( "cache-db.json") +warningsFileName :: FilePath +warningsFileName = "warnings.cbor" + 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 +252,7 @@ writeCacheDb' -> CacheDb -- ^ The CacheDb to be written -> m () -writeCacheDb' = writeJSONFile . cacheDbFile +writeCacheDb' = (. toCacheDbVersioned) . writeJSONFile . cacheDbFile writePackageJson' :: (MonadIO m, MonadError MultipleErrors m) @@ -162,6 +263,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 +309,20 @@ 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 + patchOutputModulePath + readExterns + readWarnings + codegen + ffiCodegen + progress + readCacheDb + writeCacheDb + writePackageJson + outputPrimDocs where getInputTimestampsAndHashes @@ -195,9 +343,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 @@ -210,45 +356,98 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp mn = do codegenTargets <- asks optionsCodegenTargets mExternsTimestamp <- getTimestampMaybe (outputFilename mn externsFileName) - case mExternsTimestamp of - Nothing -> - -- If there is no externs file, we will need to compile the module in + mWarningsTimestamp <- getTimestampMaybe (outputFilename mn warningsFileName) + case (mExternsTimestamp, mWarningsTimestamp) of + (Just externsTimestamp, Just warningsTimestamp) + | warningsTimestamp < externsTimestamp -> pure Nothing + | otherwise -> + case NEL.nonEmpty (fmap (targetFilename mn) (S.toList codegenTargets)) of + Nothing -> + -- If the externs file exists and no other codegen targets have + -- been requested, then we can consider the module up-to-date + pure (Just externsTimestamp) + Just outputPaths -> do + -- If any of the other output paths are nonexistent or older than + -- the externs file, then they should be considered outdated, and + -- so the module will need rebuilding. + mmodTimes <- traverse getTimestampMaybe outputPaths + pure $ case sequence mmodTimes of + Nothing -> + Nothing + Just modTimes -> + if externsTimestamp <= minimum modTimes + then Just externsTimestamp + else Nothing + (_, _) -> + -- If there is no externs or warnings file, we will need to compile the module in -- order to produce one. pure Nothing - Just externsTimestamp -> - case NEL.nonEmpty (fmap (targetFilename mn) (S.toList codegenTargets)) of - Nothing -> - -- If the externs file exists and no other codegen targets have - -- been requested, then we can consider the module up-to-date - pure (Just externsTimestamp) - Just outputPaths -> do - -- If any of the other output paths are nonexistent or older than - -- the externs file, then they should be considered outdated, and - -- so the module will need rebuilding. - mmodTimes <- traverse getTimestampMaybe outputPaths - pure $ case sequence mmodTimes of - Nothing -> - Nothing - Just modTimes -> - if externsTimestamp <= minimum modTimes - 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) + + patchJSONFile :: forall a. ToJSON a => FromJSON a => FilePath -> (a -> a) -> Make () + patchJSONFile filePath patchFn = do + mbVal <- readJSONFile filePath + let throw = makeIO ("patch JSON file: " <> T.pack filePath) $ error "could not read or parse file" + maybe throw (writeJSONFile filePath . patchFn) mbVal + + patchOutputModulePath :: ModuleName -> (FilePath, FilePath) -> (ExternsFile, MultipleErrors) -> Make (ExternsFile, MultipleErrors) + patchOutputModulePath mn (oldFp, newFp) (exts, warns) = do + let + mkPatchFn transform fp = if fp == transform oldFp then transform newFp else fp + patchFn = mkPatchFn id + exts' = patchExterns patchFn exts + warns' = patchWarnings patchFn warns + + writeCborFile (outputFilename mn externsFileName) exts' + writeCborFile (outputFilename mn warningsFileName) warns' + + codegenTargets <- asks optionsCodegenTargets + when (S.member CoreFn codegenTargets) $ + patchJSONFile (targetFilename mn CoreFn) (patchCoreFnJSON patchFn) + + when (S.member Docs codegenTargets) $ + patchJSONFile (targetFilename mn Docs) (patchDocsModule patchFn) + + when (S.member JSSourceMap codegenTargets) $ do + dir <- makeIO "get the current directory" getCurrentDirectory + let patchSourceMapFn = mkPatchFn (makeSourceFilePath dir) + patchJSONFile (targetFilename mn JSSourceMap) (patchSourceMapJSON patchSourceMapFn) + + pure (exts', warns') readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do let path = outputDir T.unpack (runModuleName mn) externsFileName (path, ) <$> readExternsFile path + readWarnings :: ModuleName -> Make (FilePath, Maybe MultipleErrors) + readWarnings mn = do + let path = outputDir T.unpack (runModuleName mn) warningsFileName + (path, ) <$> 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 + writeJSONFile (targetFilename modName Docs) 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 + lift $ writeCborFile (outputFilename mn warningsFileName) warnings + codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn @@ -276,19 +475,25 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings when (S.member Docs codegenTargets) $ do - lift $ writeJSONFile (outputFilename mn "docs.json") docs + lift $ writeJSONFile (targetFilename mn Docs) docs ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do codegenTargets <- asks optionsCodegenTargets ffiCodegen' foreigns codegenTargets (Just outputFilename) m + makeSourceFilePath :: FilePath -> FilePath -> FilePath + makeSourceFilePath dir file = pathToDir Posix. normalizeSMPath (makeRelative dir file) + where + pathToDir = iterate (".." Posix.) ".." !! length (splitPath $ normalise outputDir) + normalizeSMPath :: FilePath -> FilePath + normalizeSMPath = Posix.joinPath . splitDirectories + genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do - let pathToDir = iterate (".." Posix.) ".." !! length (splitPath $ normalise outputDir) - sourceFile = case mappings of - (SMap file _ _ : _) -> Just $ pathToDir Posix. normalizeSMPath (makeRelative dir (T.unpack file)) - _ -> Nothing + let sourceFile = case mappings of + (SMap file _ _ : _) -> Just $ makeSourceFilePath dir (T.unpack file) + _ -> Nothing let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { mapOriginal = Just $ convertPos $ add 0 (-1) orig @@ -307,14 +512,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = Pos { posLine = fromIntegral l, posColumn = fromIntegral c } - normalizeSMPath :: FilePath -> FilePath - normalizeSMPath = Posix.joinPath . splitDirectories - requiresForeign :: CF.Module a -> Bool 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..9812b8a0ee 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,97 @@ module Language.PureScript.Make.BuildPlan import Prelude -import Control.Concurrent.Async.Lifted as A -import Control.Concurrent.Lifted as C +import Control.Applicative ((<|>)) +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.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.Cache (CacheDb, CacheInfo, checkChanged) +import Language.PureScript.Make.Actions (MakeActions (..), RebuildPolicy (..), RebuildReason (..)) +import Language.PureScript.Make.Cache (CacheDb, CacheInfo, UpToDate(..), 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 Protolude.Exceptions (hush) import System.Directory (getCurrentDirectory) +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 must be (build + -- reason is known in advance) or may need to be (after diff check) re-compiled. + , 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 + , rsNewCacheInfo :: Either RebuildPolicy CacheInfo -- ^ New cache info for this module which should be stored for subsequent - -- incremental builds. A value of Nothing indicates that cache info for + -- incremental builds. A value of Left 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 :: UpToDate + -- ^ 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 +114,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 +128,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 +144,46 @@ 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) + +-- | Gets the reason for rebuild or results of previous compilation that should be +-- used. +getBuildReason :: BuildPlan -> Module -> Maybe [ExternsDiff] -> Either (ExternsFile, MultipleErrors) RebuildReason +getBuildReason (BuildPlan {..}) m depsDiffs + | Nothing <- depsDiffs = Right NoCachedDependency + | Just (Just reason, _) <- prevResult = Right reason + | Just diffs <- depsDiffs, Just (Nothing, exts) <- prevResult = + case checkDiffs m diffs of + (Just diffRef) -> Right (UpstreamRef diffRef) + Nothing -> Left (pbExterns exts, pbWarnings exts) + | otherwise = Right $ fromMaybe (barrierError "getBuildReason") (M.lookup mn bpNoPrevious) + + where + prevResult = M.lookup mn bpPrevious + mn = getModuleName m + +data Options = Options + { optPreloadAll :: 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 +191,101 @@ 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 optPreloadAll + 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 (rebuildReason, mbTs) -> do + -- We load previous build results for modules that may not need to + -- be rebuilt, and also for modules that require rebuild and are + -- needed dependencies. We don't need to load those modules that + -- are not build dependencies. + ts <- mbTs + guard (isNothing rebuildReason || inBuildDeps mn) + pure (rebuildReason, ts) + ) + rebuildMap + + -- Store known build reasons for modules that do not have actual prebuilt. + let noPrebuilt = M.mapMaybe 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 + { bpPrebuilt = prebuilt + , bpPrevious = previous + , bpNoPrevious = noPrebuilt + , bpBuildJobs = buildJobs + , bpEnv = env + , bpIndex = idx + } , let update = flip $ \s -> - M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + M.alter (const (hush $ rsNewCacheInfo s)) (rsModuleName s) in foldl' update cacheDb rebuildStatuses ) where + getMName = getModuleName . CST.resPartial + + -- 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 + -- No need to preload warnings if we not preloading all externs. + warnings <- if optPreloadAll + then snd <$> readWarnings mn + else pure $ Just (MultipleErrors []) + case (externs, warnings) of + (Just exts, Just warns) -> + pure $ Just (Prebuilt exts warns) + _ -> + pure Nothing + makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) @@ -160,57 +295,81 @@ 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 + , rsPrevious = timestamp + , rsNewCacheInfo = Left RebuildNever + , rsUpToDate = UpToDate }) Left RebuildAlways -> do pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = Nothing - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsPrevious = Nothing + , rsNewCacheInfo = Left RebuildAlways + , rsUpToDate = ContentsChanged }) 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 + , rsPrevious = timestamp + , rsNewCacheInfo = Right 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) + 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) - collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt - collectPrebuiltModules prev (moduleName, rebuildNever, pb) - | rebuildNever = M.insert moduleName pb prev + collectByStatus (build, prebuilt) (RebuildStatus mn cacheInfo Nothing _upToDate) + | reason <- if cacheInfo == Left RebuildAlways then RebuildAlwaysPolicy else NoCached = + (M.insert mn (Just reason, Nothing) build, prebuilt) + + collectByStatus (build, prebuilt) (RebuildStatus mn cacheInfo (Just pb) upToDate) + | wasChanged = toRebuild (Just CacheOutdated, pb) + | wasMoved = toRebuild (Nothing, pb) + -- Treat as prebuilt because of RebuildNever policy. + | cacheInfo == Left RebuildNever = toPrebuilt pb + -- In other case analyze compilation times of dependencies. | 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 + -- 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 + wasChanged = upToDate == ContentsChanged + wasMoved = upToDate == FilePathChanged + toRebuild (claim, t) = (M.insert mn (claim, 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..577685a62c 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -3,9 +3,13 @@ module Language.PureScript.Make.Cache , hash , CacheDb , CacheInfo(..) + , UpToDate(..) , checkChanged - , removeModules + , replaceModules , normaliseForCache + , cacheDbIsCurrentVersion + , toCacheDbVersioned + , fromCacheDbVersioned ) where import Prelude @@ -23,14 +27,19 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Monoid (All(..)) import Data.Set (Set) -import Data.Text (Text) +import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) import System.FilePath qualified as FilePath +import Paths_purescript as Paths + import Language.PureScript.Names (ModuleName) +import Data.Version (showVersion) +import Data.Aeson ((.=)) +import Data.Aeson.Types ((.:)) digestToHex :: Digest a -> Text digestToHex = decodeUtf8 . convertToBase Base16 @@ -63,6 +72,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 +107,22 @@ 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 + +data UpToDate = ContentsChanged | FilePathChanged | UpToDate + deriving (Show, Eq) + -- | 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 @@ -95,10 +148,18 @@ checkChanged -> ModuleName -> FilePath -> Map FilePath (UTCTime, m ContentHash) - -> m (CacheInfo, Bool) + -> m (CacheInfo, UpToDate) 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 currentDbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) + dbInfo = mapFilePaths currentInfo currentDbInfo + + wasMoved = Map.keys currentDbInfo /= Map.keys currentInfo + toResult True = if wasMoved then FilePathChanged else UpToDate + toResult False = ContentsChanged + (newInfo, isUpToDate) <- fmap mconcat $ for (Map.toList (align dbInfo currentInfo)) $ \(normaliseForCache basePath -> fp, aligned) -> do @@ -124,12 +185,12 @@ checkChanged cacheDb mn basePath currentInfo = do newHash <- getHash pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash)) - pure (CacheInfo newInfo, getAll isUpToDate) + pure (CacheInfo newInfo, toResult $ 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 +-- | Takes set of modules from source cacheDb and copies to dest, removing absent from dest. +replaceModules :: Set ModuleName -> CacheDb -> CacheDb -> CacheDb +replaceModules keys sourceDb destDb = + Map.union (Map.restrictKeys sourceDb keys) (Map.withoutKeys destDb keys) -- | 1. Any path that is beneath our current working directory will be -- stored as a normalised relative path diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs new file mode 100644 index 0000000000..828b8f98b8 --- /dev/null +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -0,0 +1,597 @@ +-- | +-- To avoid recompiling all downstream modules, we check what changes in +-- upstream modules are externally visible by diffing externs, and then +-- checking how that would affect each downstream module. The algorithm +-- operates on the references (@Ref@) that modules import and export: values, +-- types, operators, typeclasses, instances, and so on. +-- +-- In more detail, we start with the old extern file from disk and the new +-- externs just produced by compiling that module. (Externs are the only +-- interaction between modules, so this is complete.) Then @diffExterns@ +-- assembles a diff of the externs for that module, with the help of +-- @getChanged@. Between them they look not only at changed refs, but also +-- how refs depend on each other (e.g. one ref showing up in the type of +-- another) as well as re-exports. This is cached for each rebuilt module. +-- +-- Removed and updated refs are the most important for downstream diffs. +-- Added refs only matter for typeclassses (and shadowing?). +-- +-- Determining whether to rebuild a (downstream) module then uses the diffs +-- of the modules it imports, in several steps. First, @makeSearches@ looks at +-- the refs that the module imports, and if any were removed, then it knows +-- the module needs to be rebuilt. Otherwise it produces a set of updated refs. +-- Then @checkUsage@ searches in the source of the module, through every type, +-- expression, and binder, to find any mention of those refs, which would +-- then require a rebuild of that module. (Changes in unused imports are +-- ignored.) +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.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.Libs qualified as C +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. Refs that are newly +-- reexported are also included (as Added): they may conflict with names already +-- in scope in downstream modules. +getReExported :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> RefsWithStatus +getReExported newExts oldExts depsDiffsMap = + M.union (M.fromList $ mapMaybe checkRe $ S.toList oldExports) addedRefs + where + goRe (P.ReExportRef _ es ref) = S.mapMonotonic (P.exportSourceDefinedIn es,) (toRefs ref) + goRe _ = S.empty + + oldExports = foldMap goRe (P.efExports oldExts) + newReExports = foldMap goRe (P.efExports newExts) + + addedRefs = M.fromSet (const Added) $ S.map snd (S.difference newReExports oldExports) + + 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, Set 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 :: Tuple4 Set RefWithDeps -> Tuple4 Set RefWithDeps + applyInstances (a, r, c, u) = + let checkType t (TypeRef t') = t' == t + checkType _ _ = False + uRefs = mapFst 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. + if S.member clsRef uRefs then S.singleton clsRef else S.empty + 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). + S.empty + _ -> + -- Otherwise mark instance types as changed. + foldMap (\t -> S.filter (checkType t) uRefs) types + go _ = S.empty + + -- Check class instances in added, removed and changed. + affected = foldMap (go . fst) (a <> r <> c) + (uc, uu) = S.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) = mapFst (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 = M.fromSet (const status) $ mapFst refs + changedRefs = + 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 -> Set RefWithDeps -> Set Ref +getAffectedLocal modName diffsMap unchangedRefs = + affectedLocalRefs + where + hasChangedDeps (mn, ref) = + Just True == (S.member ref <$> M.lookup mn diffsMap) + (affectedByChanged, restLocalRefs) = + S.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 <$> S.toList restLocalRefs <> (map (const S.empty) <$> S.toList affectedByChanged) + (graph, fromVtx, toVtx) = G.graphFromEdges vtxs + + -- Graph is a list of refs with (refs) dependencies. + refsGraph :: [(Ref, [Ref])] + 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 S.member (mapFst 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 $ + -- For reexports via qualified and unqualified imports. + find (\(mn', qual, _) -> maybe (mn' == mn) (mn ==) qual) 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 + P.Do mbQual _ -> + foldMap (checkValue . mkQualified mbQual) [C.S_bind, C.S_discard] + P.Ado mbQual _ _ -> + foldMap (checkValue . mkQualified mbQual) [C.S_map, C.S_apply, C.S_pure] + P.UnaryMinus _ _ -> checkValue (mkQualified Nothing C.S_negate) + _ -> mempty + + goBinder _ binder = case binder of + P.ConstructorBinder _ n _ -> checkCtor n + P.OpBinder _ n -> checkValueOp n + _ -> mempty + mkQualified mbQual = P.Qualified (P.byMaybeModuleName mbQual) . P.Ident + + +-- | 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.keysSet . M.filterWithKey (const . getCtor n) + addCtors mn (P.TypeRef _ n Nothing) = foldMap (getCtors n) (M.lookup mn diffsMap) + addCtors _ _ = S.empty + 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 = + let + addIn updated = s <> + S.mapMonotonic (mn, qual,) (M.keysSet updated) + in case dt of + P.Explicit dRefs + | Just ref <- searchRef removed refs -> Left (mn, ref) + | otherwise -> + -- Search only refs encountered in the import. + Right $ addIn $ 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 $ addIn $ M.filterWithKey (const . not . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + -- Search all changed refs. + P.Implicit -> Right $ addIn diffs + go s _ = Right s + +toRefs :: P.DeclarationRef -> Set Ref +toRefs = \case + P.TypeClassRef _ n -> S.singleton (TypeClassRef n) + P.TypeOpRef _ n -> S.singleton (TypeOpRef n) + P.TypeRef _ n c -> S.singleton (TypeRef n) <> foldMap (S.fromList . fmap (ConstructorRef n)) c + P.ValueRef _ i -> S.singleton (ValueRef i) + P.ValueOpRef _ n -> S.singleton (ValueOpRef n) + _ -> S.empty + +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 Set r +splitRefs new old toRef = + M.foldrWithKey go (added, S.empty, S.empty, S.empty) oldMap + where + toMap = M.fromList . mapMaybe (((<$>) . flip (,)) <*> toRef) + newMap = toMap new + oldMap = toMap old + added = M.keysSet $ M.difference newMap oldMap + go ref decl (a, r, c, u) = case M.lookup ref newMap of + Nothing -> (a, S.insert ref r, c, u) + Just newDecl + | decl /= newDecl -> (a, r, S.insert ref c, u) + | otherwise -> (a, r, c, S.insert 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) + +-- @fst@ is monotonic, so it is safe to use @S.mapMonotonic@ +mapFst :: forall a b. Set (a, b) -> Set a +mapFst = S.mapMonotonic fst diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 8c86144e9a..69904dd296 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -5,12 +5,15 @@ module Language.PureScript.Make.Monad , makeIO , getTimestamp , getTimestampMaybe + , getCurrentTime + , setTimestamp , readTextFile , readJSONFile , readJSONFileIO , readCborFile , readCborFileIO , readExternsFile + , readWarningsFile , hashFile , writeTextFile , writeJSONFile @@ -35,14 +38,16 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson qualified as Aeson import Data.ByteString qualified as B +import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) +import Data.Time.Clock qualified as Time import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), singleError) import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options (Options) -import System.Directory (createDirectoryIfMissing, getModificationTime) +import System.Directory (createDirectoryIfMissing, getModificationTime, setModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) @@ -85,6 +90,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 +144,13 @@ 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 + hashFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ContentHash hashFile path = do makeIO ("hash file: " <> Text.pack path) diff --git a/src/Language/PureScript/Make/Patch.hs b/src/Language/PureScript/Make/Patch.hs new file mode 100644 index 0000000000..b01ff4eb4f --- /dev/null +++ b/src/Language/PureScript/Make/Patch.hs @@ -0,0 +1,71 @@ +-- | +-- Functions for updating source file path in the build artifacts. +module Language.PureScript.Make.Patch + ( patchExterns + , patchWarnings + , patchDocsModule + , patchCoreFnJSON + , patchSourceMapJSON + ) where + +import Prelude + +import Control.Lens.Extras (template) +import Control.Lens (over) +import Data.Aeson (Value(Object, String, Array)) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Key qualified as Key +import Data.Data (Data) +import Language.PureScript.Externs (ExternsFile) +import Language.PureScript.AST (modifySpanName) +import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) +import Language.PureScript.Errors (MultipleErrors) +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Functor.Identity (Identity(..)) +import Language.PureScript.Docs.Types qualified as Docs + +patchSpans :: forall a. Data a => (String -> String) -> a -> a +patchSpans = over template . modifySpanName + +patchChainIds :: (String -> String) -> ExternsFile -> ExternsFile +patchChainIds = over template . patchChainId :: (String -> String) -> ExternsFile -> ExternsFile + +patchChainId :: (String -> String) -> ChainId -> ChainId +patchChainId f (ChainId (fp, pos)) = ChainId (f fp, pos) + +-- Source file names appear in externs both in source spans and inside +-- instance chain ids, so both have to be patched. +patchExterns :: (String -> String) -> ExternsFile -> ExternsFile +patchExterns f = patchChainIds f . patchSpans f + +patchWarnings :: (String -> String) -> MultipleErrors -> MultipleErrors +patchWarnings f = over template (modifySpanName f) :: MultipleErrors -> MultipleErrors + +patchJSONKey :: String -> (String -> String) -> Value -> Value +patchJSONKey key modStr (Object km) = + Object $ runIdentity $ KeyMap.alterF modifyVal (Key.fromText (T.pack key)) km + where + modText = T.pack . modStr . T.unpack + modString (String t)= String $ modText t + modString other = other + modifyVal (Just (String t)) = Identity (Just (String (modText t))) + modifyVal (Just (Array arr)) = Identity (Just (Array $ V.map modString arr)) + modifyVal old = Identity old +patchJSONKey _ _ json = json + +patchCoreFnJSON :: (String -> String) -> Value -> Value +patchCoreFnJSON = patchJSONKey "modulePath" + +patchDocsModule :: (String -> String) -> Docs.Module -> Docs.Module +patchDocsModule modStr m = + m + { Docs.modDeclarations = map patchDeclaration $ Docs.modDeclarations m + , Docs.modReExports = map (fmap (map patchDeclaration)) $ Docs.modReExports m + } + where + patchDeclaration = patchSpans modStr + +patchSourceMapJSON :: (String -> String) -> Value -> Value +patchSourceMapJSON modStr = + patchJSONKey "sources" modStr \ No newline at end of file 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/Names.hs b/src/Language/PureScript/Names.hs index e5df3610bf..efbfe90728 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} -- | -- Data types for names @@ -11,6 +11,7 @@ import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) import Control.Monad.Supply.Class (MonadSupply(..)) import Control.DeepSeq (NFData) +import Data.Data (Data) import Data.Functor.Contravariant (contramap) import Data.Vector qualified as V @@ -31,7 +32,7 @@ data Name | DctorName (ProperName 'ConstructorName) | TyClassName (ProperName 'ClassName) | ModName ModuleName - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Data) instance NFData Name instance Serialise Name @@ -70,7 +71,7 @@ getClassName _ = Nothing data InternalIdentData -- Used by CoreFn.Laziness = RuntimeLazyFactory | Lazy !Text - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData InternalIdentData instance Serialise InternalIdentData @@ -95,7 +96,7 @@ data Ident -- A generated name used only for internal transformations -- | InternalIdent !InternalIdentData - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Ident instance Serialise Ident @@ -127,7 +128,7 @@ isPlainIdent _ = False -- Operator alias names. -- newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData (OpName a) instance Serialise (OpName a) @@ -156,7 +157,7 @@ coerceOpName = OpName . runOpName -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData (ProperName a) instance Serialise (ProperName a) @@ -188,7 +189,7 @@ coerceProperName = ProperName . runProperName -- Module names -- newtype ModuleName = ModuleName Text - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) deriving newtype Serialise instance NFData ModuleName @@ -205,7 +206,7 @@ isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn data QualifiedBy = BySourcePos SourcePos | ByModuleName ModuleName - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) pattern ByNullSourcePos :: QualifiedBy pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) @@ -229,7 +230,7 @@ toMaybeModuleName (BySourcePos _) = Nothing -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified QualifiedBy a - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data) instance NFData a => NFData (Qualified a) instance Serialise a => Serialise (Qualified a) diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 2ceb481181..bedbe43dd5 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.PSString ( PSString , toUTF16CodeUnits @@ -33,6 +34,7 @@ import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A +import Data.Data (Data) -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not @@ -49,7 +51,7 @@ import Data.Aeson.Types qualified as A -- and arrays of UTF-16 code units (integers) otherwise. -- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } - deriving (Eq, Ord, Semigroup, Monoid, Generic) + deriving (Eq, Ord, Semigroup, Monoid, Generic, Data) instance NFData PSString instance Serialise PSString diff --git a/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs index 7a73062993..27794d22cc 100644 --- a/src/Language/PureScript/Roles.hs +++ b/src/Language/PureScript/Roles.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} -- | -- Data types for roles. @@ -16,6 +16,7 @@ import Data.Aeson qualified as A import Data.Aeson.TH qualified as A import Data.Text (Text) import GHC.Generics (Generic) +import Data.Data (Data) -- | -- The role of a type constructor's parameter. @@ -29,7 +30,7 @@ data Role | Phantom -- ^ This parameter has no effect on the representation of the type it is -- parameterising. - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData Role instance Serialise Role diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 3b4c019521..ddbc9097a0 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -15,7 +15,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent) import Language.PureScript.PSString (mkString) -import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString) +import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString, srcTypeVar) import Language.PureScript.TypeChecker (checkNewtype) -- | Elaborates deriving instance declarations by code generation. @@ -46,16 +46,32 @@ deriveInstance deriveInstance mn ds decl = case decl of TypeInstanceDeclaration sa@(ss, _) na ch idx nm deps className tys DerivedInstance -> let + -- Attached `derive (Generic)` / `derive (Newtype)` produces `[T]`. + -- These two classes need the fully-applied type plus a trailing + -- wildcard, so pad the args before falling into the standard handler. + paddedTys = case tys of + [bareTy] + | className == Libs.Generic || className == Libs.Newtype + , Just utc <- unwrapTypeConstructor bareTy + , mn == utcModuleName utc + , null (utcArgs utc) + , Just (DataDeclaration _ _ _ tyVars _) <- find (matchesTyName (utcTyCon utc)) ds -> + let applied = foldl srcTypeApp bareTy (map (srcTypeVar . fst) tyVars) + in [applied, TypeWildcard sa UnnamedWildcard] + _ -> tys + matchesTyName n (DataDeclaration _ _ n' _ _) = n == n' + matchesTyName _ _ = False + binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration - binaryWildcardClass f = case tys of + binaryWildcardClass f = case paddedTys of [ty1, ty2] -> case unwrapTypeConstructor ty1 of Just UnwrappedTypeConstructor{..} | mn == utcModuleName -> do checkIsWildcard ss utcTyCon ty2 tyConDecl <- findTypeDecl ss utcTyCon ds (members, ty2') <- f tyConDecl utcArgs pure $ TypeInstanceDeclaration sa na ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) - _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1 - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 + _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className paddedTys ty1 + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className paddedTys 2 in case className of Libs.Generic -> binaryWildcardClass (deriveGenericRep ss mn) diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 593e8c1a8d..645844d5ee 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.TypeClassDictionaries where import Prelude import GHC.Generics (Generic) +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Text (Text, pack) import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify) import Language.PureScript.Types (SourceConstraint, SourceType) +import Data.Data (Data) -- -- Data representing a type class dictionary which is in scope @@ -37,9 +40,10 @@ data TypeClassDictionaryInScope v -- error messages , tcdDescription :: Maybe SourceType } - deriving (Show, Functor, Foldable, Traversable, Generic) + deriving (Show, Functor, Foldable, Traversable, Generic, Data) instance NFData v => NFData (TypeClassDictionaryInScope v) +instance Serialise v => Serialise (TypeClassDictionaryInScope v) type NamedDict = TypeClassDictionaryInScope (Qualified Ident) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ef00e21a07..53248a5dce 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- | -- Data types for types -- @@ -28,6 +29,7 @@ import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) +import Data.Data (Data) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -36,7 +38,7 @@ type SourceConstraint = Constraint SourceAnn -- An identifier for the scope of a skolem variable -- newtype SkolemScope = SkolemScope { runSkolemScope :: Int } - deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic) + deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic, Data) instance NFData SkolemScope instance Serialise SkolemScope @@ -48,7 +50,7 @@ instance Serialise SkolemScope -- contained by a binding with a complete (wildcard-free) type signature. -- data WildcardData = HoleWildcard Text | UnnamedWildcard | IgnoredWildcard - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData WildcardData instance Serialise WildcardData @@ -56,7 +58,7 @@ instance Serialise WildcardData data TypeVarVisibility = TypeVarVisible | TypeVarInvisible - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData TypeVarVisibility instance Serialise TypeVarVisibility @@ -110,7 +112,7 @@ data Type a -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. | ParensInType a (Type a) - deriving (Show, Generic, Functor, Foldable, Traversable) + deriving (Show, Generic, Functor, Foldable, Traversable, Data) instance NFData a => NFData (Type a) instance Serialise a => Serialise (Type a) @@ -173,7 +175,7 @@ data ConstraintData -- not matched, and a flag indicating whether the list was truncated or not. -- Note: we use 'Text' here because using 'Binder' would introduce a cyclic -- dependency in the module graph. - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Data) instance NFData ConstraintData instance Serialise ConstraintData @@ -190,7 +192,7 @@ data Constraint a = Constraint -- ^ type arguments , constraintData :: Maybe ConstraintData -- ^ additional data relevant to this constraint - } deriving (Show, Generic, Functor, Foldable, Traversable) + } deriving (Show, Generic, Functor, Foldable, Traversable, Data) instance NFData a => NFData (Constraint a) instance Serialise a => Serialise (Constraint a) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 610e8465c8..7bd13cffde 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -1,176 +1,196 @@ -- 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.Clock (UTCTime (..)) +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"] + -- WARNINGS PRESERVATION - 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"] + it "preserves warnings between rebuilds when compilation skipped" $ do + writeModule "A" "module A (bar) where\nfoo=0\nbar=1" + ((_, warns), c1) <- compileAll + c1 `shouldBe` moduleNames ["A"] + length (P.runMultipleErrors warns) `shouldBe` 3 + -- + ((_, warns2), c2) <- compileAll + c2 `shouldBe` moduleNames [] + length (P.runMultipleErrors warns2) `shouldBe` 3 + + + it "may optionally omit collecting preserved externs and warnings" $ do + writeModule "A" "module A (bar) where\nfoo=0\nbar=1" + ((_, warns), c1) <- compileAll + c1 `shouldBe` moduleNames ["A"] + length (P.runMultipleErrors warns) `shouldBe` 3 + + let makeOpts = P.defaultMakeOptions {P.moCollectAll = False} + ((Right exts, warns2), c2) <- + compileAllWithOptions makeOpts P.defaultOptions + + c2 `shouldBe` moduleNames [] + length exts `shouldBe` 0 + length (P.runMultipleErrors warns2) `shouldBe` 0 + + -- CACHE DB + + it "recompiles all modules if compiler's version differs from cache-db version" $ 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"] + + -- COMMON 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 a module if file contents 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 [] 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" - moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" + writeModule "A" "module A where\nfoo :: Int\nfoo = \"not an int\"\n" + compileSome ["A"] >>= expectCompiledWithFailure ["A"] + compileSome ["A"] >>= expectCompiledWithFailure ["A"] + + it "recompiles a failed module after successful compilation" $ do + writeModule "A" "module A where foo = 1" + compileAll >>= expectCompiled ["A"] + + writeModule "A" "module A where foo = (1 :: String)" - writeFileWithTimestamp modulePath timestampA moduleContent - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + compileAll >>= expectCompiledWithFailure ["A"] + -- Check that failed module is compiled again on the nest run. + compileAll >>= expectCompiledWithFailure ["A"] + -- Check if that the module is fixed without changes it is skipped. + writeModule "A" "module A where foo = 1" + compileAll >>= expectCompiled [] + + 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]} + makeOpts = P.defaultMakeOptions + go opts = compileWithOptions makeOpts opts mempty [mPath] >>= assertSuccess + + writeModule "Module" mContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeModule "Module" mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -178,30 +198,742 @@ 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 P.defaultMakeOptions opts mempty [mPath] >>= assertSuccess + + writeModule "Module" mContent1 + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + writeModule "Module" 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"] + + -- If a module is rename/moved it is not recompiled but build artifacts + -- should be updated to contain new source module path. + it "does not recompile if the a module was renamed, but updates artifacts" $ do + let + content = "module Module where\nfoo = 0\n" + makeOpts = P.defaultMakeOptions + opts = P.defaultOptions {P.optionsCodegenTargets = Set.fromList [P.JS, P.JSSourceMap, P.CoreFn, P.Docs]} + orgName = "Module" + movedName = "Module2" + dupBackslash = T.replace "\\" "\\\\" -- on Windows paths are escaped + toSlashPath = T.replace "\\" "/" -- source maps always have unix-normalized source path + orgPath = sourcesDir T.unpack orgName <> ".purs" + movedPath = sourcesDir T.unpack movedName <> ".purs" + + checkText' transformFp text = do + text `shouldSatisfy` T.isInfixOf (dupBackslash $ transformFp $ T.pack movedPath) + text `shouldSatisfy` (not . T.isInfixOf (dupBackslash $ transformFp $ T.pack orgPath)) + checkFile' transformFp fileName = do + text <- readUTF8FileT (outputDir T.unpack orgName fileName) + checkText' transformFp text + checkText = checkText' id + checkFile = checkFile' id + + + writeModule orgName content + compileAllWithOptions makeOpts opts >>= expectCompiled ["Module"] + deleteModule orgName + + writeModule movedName content + + ((Right exts, warns), compiled) <- compileAllWithOptions makeOpts opts + compiled `shouldBe` moduleNames [] + + -- Check returned externs/warnings. + checkText (T.pack $ show exts) + checkText (T.pack $ show warns) + + checkFile "corefn.json" + checkFile "docs.json" + checkFile' toSlashPath "index.js.map" + + -- Check that updated externs/warnings where saved to the disk. + ((Right exts', warns'), _) <- compileAll + checkText (T.pack $ show exts') + checkText (T.pack $ show warns') + + -- DOWNSTREAM COMPILATION + + let + recompilesIf cause = "recompiles downstream if " <> cause + skipsRecompileIf cause = "does not recompile downstream if " <> cause + recompileAB (textA, textA', textB) expect = do + writeModule "A" textA + writeModule "B" textB + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" textA' + compileAll >>= expect + + it (recompilesIf "failed 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 (skipsRecompileIf "not affected after the dependency 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 (recompilesIf "affected after the dependency 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 :: Char\nfoo = '0'\n" + compileAll >>= expectCompiledWithFailure ["A", "B"] + + it (recompilesIf "renamed/moved and affected") $ do + writeModule "A" "module A where\nfoo = 0\n" + let contentB = "module B where\nimport A\nbar = 1\nbaz = foo\n" + writeModule "B" contentB + + compileAll >>= expectCompiled ["A", "B"] + + threadDelay oneSecond + + deleteModule "B" + writeModule "A" "module A where\nfoo = '1'\n" + writeModule "B2" contentB + + compileAll >>= expectCompiled ["A", "B"] + + it (skipsRecompileIf "renamed/moved and not affected") $ do + writeModule "A" "module A where\nfoo = 0\n" + let contentB = "module B where\nimport A\nbar = 1\nbaz = foo\n" + writeModule "B" contentB + + compileAll >>= expectCompiled ["A", "B"] + + threadDelay oneSecond + + deleteModule "B" + writeModule "A" "module A where\nfoo = 1\n" + writeModule "B2" contentB + + compileAll >>= expectCompiled ["A"] + + it (recompilesIf "later dependency found") $ 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"] + + -- DIFF CHECK: below tests for rebuilds of modules that are affected by changes. + + it "may optionally compile without diff check" $ 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" + let makeOpts = P.defaultMakeOptions {P.moDiffCheck = False} + + compileAllWithOptions makeOpts P.defaultOptions >>= expectCompiled ["A", "B"] + + -- Later dependency should only require compilation of direct downstream modules. + it (skipsRecompileIf "the later dependency is indirect") $ 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 (recompilesIf "transitive change in later dependency found") $ do + -- B depends on A. C depends on B. 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"] + + -- DIFF CHECK:: UpstreamRef + + it (recompilesIf "changed ref found") $ 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 (recompilesIf "transitive change found") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A (foo)\nbar = qux\nqux = foo\n" + writeModule "C" "module C where\nimport B (bar)\nbaz = bar\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nfoo = '1'\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + it (skipsRecompileIf "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 (skipsRecompileIf "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 (recompilesIf "added a ref which causes a 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 (recompilesIf "an 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"] + + -- DIFF CHECK: REEXPORTS + + it (recompilesIf "a reexported ref changed") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A (foo) as E\n" + writeModule "C" "module C where\nimport B as B\nbaz = B.foo\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nfoo = '1'\nbar = 1\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + it (skipsRecompileIf "a reexported ref changed but not used") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A as E\n" + -- Import but not use. + writeModule "C" "module C where\nimport B (foo)\nx = 1\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nfoo = '1'\nbar = 1\n" + compileAll >>= expectCompiled ["A", "B"] + + it (recompilesIf "a reexported ref removed") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A as E\n" + writeModule "C" "module C where\nimport B as B\nbaz = B.foo\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nbar = 1\n" + compileAll >>= expectCompiledWithFailure ["A", "B", "C"] + + it (recompilesIf "a ref removed from the reexporting module") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A (foo) as E\n" + writeModule "C" "module C where\nimport B as B\nbaz = B.foo\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + -- Stop reexporting. + writeModule "B" "module B where\nimport A (foo) as E\nx = 1\n" + compileAll >>= expectCompiledWithFailure ["B", "C"] + + it (recompilesIf "a reexported ref removed (imported but not used)") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A (foo) as E\n" + -- Import but not use. + writeModule "C" "module C where\nimport B (foo) as B\nx = 1\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "B" "module B where\nimport A (foo) as E\nx = 1\n" + compileAll >>= expectCompiledWithFailure ["B", "C"] + + it (recompilesIf "a reexported ref removed in original (imported but not used)") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module E) where\nimport A as E\n" + -- Import but not use. + writeModule "C" "module C where\nimport B (foo)\nx = 1\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nbar = 1\n" + compileAll >>= expectCompiledWithFailure ["A", "B", "C"] + + it (recompilesIf "a ref reexported via unqualified import changed") $ do + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\n" + writeModule "B" "module B (module A) where\nimport A\n" + writeModule "C" "module C where\nimport B (foo)\nbar :: Int\nbar = foo\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nfoo :: Boolean\nfoo = true\n" + compileAll >>= expectCompiledWithFailure ["A", "B", "C"] + + it (recompilesIf "a ref reexported via unqualified import removed") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module A) where\nimport A\n" + writeModule "C" "module C where\nimport B (foo)\nbar = foo\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nqux = 1\n" + compileAll >>= expectCompiledWithFailure ["A", "B", "C"] + + it (recompilesIf "an added reexport causes a conflict") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B (module A) where\nimport A\n" + writeModule "D" "module D where\nbar :: Int\nbar = 2\n" + writeModule "C" "module C where\nimport B\nimport D\nqux :: Int\nqux = bar\n" + compileAll >>= expectCompiled ["A", "B", "C", "D"] + + -- A new `bar` flows through B's module reexport into C's open imports, + -- making C's use of `bar` ambiguous. + writeModule "A" "module A where\nfoo = 0\nbar = 1\n" + compileAll >>= expectCompiledWithFailure ["A", "B", "C"] + + -- DIFF CHECK: IMPORT REFS + + it (recompilesIf "a removed ref is found in explicit imports") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A (foo)\nbar = 1\n" + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\nfoo2 = 1\n" + compileAll >>= expectCompiledWithFailure ["A", "B"] + + it (skipsRecompileIf "a removed ref is not used") $ do + writeModule "A" "module A where\nfoo = 0\n" + writeModule "B" "module B where\nimport A\nbar = 1\n" + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\nfoo2 = 1\n" + compileAll >>= expectCompiled ["A"] + + it (recompilesIf "a changed ref is used through a hiding import") $ do + writeModule "A" "module A where\nfoo :: Int\nfoo = 0\nbar = 0\n" + writeModule "B" "module B where\nimport A hiding (bar)\nz :: Int\nz = foo\n" + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\nfoo :: Char\nfoo = 'x'\nbar = 0\n" + compileAll >>= expectCompiledWithFailure ["A", "B"] + + -- DIFF CHECK: Type arguments changes. + + it (skipsRecompileIf "a type argument is renamed") $ do + let typ = "data Foo a = Foo\n" + let fn = "foo :: forall a. Int -> Foo a\nfoo _ = Foo\n" + + let typ2 = "data Foo x = Foo\n" + let fn2 = "foo :: forall y. Int -> Foo y\nfoo _ = Foo\n" + recompileAB + ( "module A where\n" <> typ <> fn + , "module A where\n" <> typ2 <> fn2 <> "x = 1\n" + , "module B where\nimport A as A\nbar = A.foo\n" + ) + (expectCompiled ["A"]) + + it (recompilesIf "the order of type arguments changed") $ do + let fn1 = "foo :: forall a b. a -> b -> Int\nfoo _ _ = 1\n" + let fn2 = "foo :: forall b a. a -> b -> Int\nfoo _ _ = 1\n" + recompileAB + ( "module A where\n" <> fn1 + , "module A where\n" <> fn2 + , "module B where\nimport A as A\nbar = A.foo\n" + ) + (expectCompiled ["A", "B"]) + + it (skipsRecompileIf "data type arguments renamed") $ do + let typ = "data Baz a b = Foo a | Bar b\n" + -- Rename a <-> b, this doesn't change types. + let typ2 = "data Baz b a = Foo b | Bar a\n" + recompileAB + ( "module A where\n" <> typ + , "module A where\n" <> typ2 + , "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + ) + (expectCompiled ["A"]) + + it (recompilesIf "order of data type arguments changed") $ do + let typ = "data Baz a b = Foo a | Bar b\n" + -- 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" + recompileAB + ( "module A where\n" <> typ + , "module A where\n" <> typ2 + , "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + -- Type-level is not affected by changing of args names or order. + it (skipsRecompileIf "data type arguments order changed (type-level dependency)") $ + recompileAB + ( "module A where\ndata T a b = T a b\n" + , "module A where\ndata T b a = T a b\n" + , "module B where\nimport A\nfn :: T Int String -> Int\nfn _ = 1\n" + ) + (expectCompiled ["A"]) + + it (recompilesIf "a kind used in a kind signature changed") $ + recompileAB + ( "module A where\ndata K\n" + , "module A where\ndata K x\n" + , "module B where\nimport A\ndata Q :: K -> Type\ndata Q a = Q\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + it (recompilesIf "a role annotation changed") $ + recompileAB + ( "module A where\ndata T a = T\ntype role T phantom\n" + , "module A where\ndata T a = T\ntype role T nominal\n" + , T.unlines + [ "module B where" + , "import Prim.Coerce (class Coercible)" + , "import A as A" + , "f :: Coercible (A.T Int) (A.T Boolean) => Int" + , "f = 1" + , "g :: Int" + , "g = f" + ] + ) + (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 (recompilesIf "type constructor added and (another) constructor is used") $ do + let typ = "data Baz a b = Foo a | Bar b\n" + let typ2 = "data Baz b a = Foo b | Bar a | Car\n" + recompileAB + ( "module A where\n" <> typ + , "module A where\n" <> typ2 + , "module B where\nimport A\nbar = (Foo 1 :: Baz Int String)\n" + ) + (expectCompiled ["A", "B"]) + + -- If dependency uses only a type without constructors, it should not care + -- about right side changes. + it (skipsRecompileIf "type constructor added and only the type is used") $ do + let typ = "data Baz a b = Foo a | Bar b\n" + let typ2 = "data Baz b a = Foo b | Bar a | Car\n" + recompileAB + ( "module A where\n" <> typ + , "module A where\n" <> typ2 + , "module B where\nimport A\nbar (x :: Baz String Int) = 1" + ) + (expectCompiled ["A"]) + + -- DIFF CHECK: Checking particular places + + -- Foreign import + it (recompilesIf "type synonym changed found in foreign import") $ do + writeModule "A" "module A where\ntype SynA = Int\n" + writeModule "B" "module B where\nimport A as A\nforeign import a :: A.SynA\n" + writeForeign "B" "export var a = 1;\n" + compileAll >>= expectCompiled ["A", "B"] + + writeModule "A" "module A where\ntype SynA = String\n" + compileAll >>= expectCompiled ["A", "B"] + + it (recompilesIf "found changed in inlined type") $ + recompileAB + ( "module A where\ntype T = Int\n" + , "module A where\ntype T = String\n" + , "module B where\nimport A\nx = (1 :: T)\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + it (recompilesIf "changed found in type alias") $ + recompileAB + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "changed found in type alias") $ + recompileAB + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "changed found in value annotation") $ + recompileAB + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nvalue = ([] :: Array A.SynA)\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "changed found in pattern annotation") $ + recompileAB + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nfn = \\(_ :: Array A.SynA) -> 0\n" + ) + (expectCompiled ["A", "B"]) + + -- Should move? + it (recompilesIf "type dependency changed") $ + recompileAB + ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" + , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "class member type changed (class used in signature)") $ + recompileAB + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , "module B where\nimport A as A\nfn :: forall a. A.Cls a => a -> Int\nfn _ = 1\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "class member type changed (member used)") $ + recompileAB + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , "module B where\nimport A as A\nfn x = A.m1 x\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "type class instance added") $ + recompileAB + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1\n" + , "module B where\nimport A as A\nfn :: forall a. A.Cls a => a -> Int\nfn _ = 1\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "type class instance removed") $ + recompileAB + ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1\n" + , "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module B where\nimport A (m1)\nx = m1 1\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + it (recompilesIf "instance added for a type") $ do + writeModule "A" "module A where\nclass Cls a where m1 :: a -> Int\n" + writeModule "B" "module B where\nimport A\nnewtype T = T Int\n" + writeModule "C" "module C where\nimport B\nt = T 1\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "B" "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1\n" + compileAll >>= expectCompiled ["B", "C"] + + -- If instances are changed, should recompile modules with the type as it may use class members. + it (recompilesIf "instance removed for a type (class depended)") $ do + writeModule "A" "module A where\nclass Cls a where m1 :: a -> Int\n" + writeModule "B" "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1\n" + writeModule "C" "module C where\nimport A\nimport B\ni :: Int\ni = m1 (T 1)\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "B" "module B where\nimport A\nnewtype T = T Int\n" + compileAll >>= expectCompiledWithFailure ["B", "C"] + + -- If type class is changed it will recompile member-dependent modules. + it (skipsRecompileIf "instance added for a type and class changed") $ do + writeModule "A" "module A where\nclass Cls a where m1 :: a -> Char\n" + writeModule "B" "module B where\nimport A\nnewtype T = T Int\n" + writeModule "C" "module C where\nimport B\ntype C2 = T\n" + compileAll >>= expectCompiled ["A", "B", "C"] + + writeModule "A" "module A where\nclass Cls a where m1 :: a -> Int\n" + writeModule "B" "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1\n" + compileAll >>= expectCompiled ["A", "B"] + + it (recompilesIf "instances in a chain are reordered") $ do + let inst1 = "instance Cls Int where m _ = 1" + let inst2 = "instance Cls a where m _ = 2" + recompileAB + ( "module A where\nclass Cls a where m :: a -> Int\n" <> inst1 <> "\nelse " <> inst2 <> "\n" + , "module A where\nclass Cls a where m :: a -> Int\n" <> inst2 <> "\nelse " <> inst1 <> "\n" + , "module B where\nimport A (m)\nb = m 1\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "value op fixity changed") $ + recompileAB + ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" + , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" + , "module B where\nimport A\nt = 1 :+: \"1\"\n" + ) + (expectCompiled ["A", "B"]) + + it (recompilesIf "type op fixity changed") $ + recompileAB + ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" + , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" + , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1\n" + ) + (expectCompiled ["A", "B"]) + + -- HIDDEN DESUGARING DEPENDENCIES: do/ado notation and unary minus + -- resolve to `bind`/`discard`/`map`/`apply`/`pure`/`negate` only during + -- desugaring, so the usage check must account for them explicitly. + + it (recompilesIf "qualified-do bind removed") $ + recompileAB + ( "module A where\ndata Box a = Box a\nbox = Box\nbind (Box a) f = f a\n" + , "module A where\ndata Box a = Box a\nbox = Box\n" + , "module B where\nimport A as A\nf = A.do\n x <- A.box 1\n A.box x\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + it (recompilesIf "qualified-ado bind removed") $ + recompileAB + ( "module A where\ndata Box a = Box a\nbox = Box\nmap f (Box a) = Box (f a)\n" + , "module A where\ndata Box a = Box a\nbox = Box\n" + , "module B where\nimport A as A\nf = A.ado\n x <- A.box 1\n in x\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + it (recompilesIf "unary minus removed") $ + recompileAB + ( "module A where\ndata N = N\nnegate n0 = n0\nn = N\n" + , "module A where\ndata N = N\nn = N\n" + , "module B where\nimport A\nm = -n\n" + ) + (expectCompiledWithFailure ["A", "B"]) + + 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 + + compileAllWithOptions makeOpts opts = do + sources <- listModulePaths + compileWithOptions makeOpts opts 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 + +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 +948,78 @@ 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.MakeOptions -> 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 makeOpts 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) + P.make' makeOpts 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) -compileWithResult = compileWithOptions P.defaultOptions + IO (CompileResult, Set P.ModuleName) +compileWithResult = compileWithOptions P.defaultMakeOptions 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 --- | Compile, returning the set of modules which were rebuilt, and failing if --- any errors occurred. -compile :: [FilePath] -> IO (Set P.ModuleName) -compile input = - compileWithResult input >>= assertSuccess - -compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) -compileAllowingFailures input = fmap snd (compileWithResult input) +assertFailure :: (CompileResult, Set P.ModuleName) -> IO (Set P.ModuleName) +assertFailure ((result, _), recompiled) = + case result of + Left _ -> + pure recompiled + Right _ -> + fail "should compile with errors" -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..b1fd29cdad 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -227,7 +227,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do unless hasExpectedModuleName $ error ("While testing a single PureScript file, the expected module name was '" <> expectedModuleName <> "' but got '" <> T.unpack (getPsModuleName singleModule) <> "'.") - compiledModulePath <$ P.rebuildModule actions supportExterns (snd singleModule) + compiledModulePath <$ P.rebuildModule actions supportExterns (mempty, snd singleModule) _ -> do unless hasExpectedModuleName $ error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." diff --git a/tests/purs/failing/DeriveClauseCannotDerive.out b/tests/purs/failing/DeriveClauseCannotDerive.out new file mode 100644 index 0000000000..a654d7db7e --- /dev/null +++ b/tests/purs/failing/DeriveClauseCannotDerive.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseCannotDerive.purs:7:11 - 7:18 (line 7, column 11 - line 7, column 18) + + Cannot derive a type class instance for +   +  Main.MyClass Foo +   + since instances of this type class are not derivable. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDerive.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseCannotDerive.purs b/tests/purs/failing/DeriveClauseCannotDerive.purs new file mode 100644 index 0000000000..7ca01a293e --- /dev/null +++ b/tests/purs/failing/DeriveClauseCannotDerive.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotDerive +module Main where + +class MyClass a + +data Foo a = Foo a + derive (MyClass) diff --git a/tests/purs/failing/DeriveClauseEither2.out b/tests/purs/failing/DeriveClauseEither2.out new file mode 100644 index 0000000000..9ed2a40315 --- /dev/null +++ b/tests/purs/failing/DeriveClauseEither2.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseEither2.purs:7:11 - 7:13 (line 7, column 11 - line 7, column 13) + + Could not match kind +   +  Type -> Type -> Type +   + with kind +   +  Type +   + +while checking that type Either2 + has kind Type +while inferring the kind of Eq Either2 +in type class instance +  + Data.Eq.Eq Either2 +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseEither2.purs b/tests/purs/failing/DeriveClauseEither2.purs new file mode 100644 index 0000000000..24a0c00053 --- /dev/null +++ b/tests/purs/failing/DeriveClauseEither2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +data Either2 a b = Left2 a | Right2 b + derive (Eq) diff --git a/tests/purs/failing/DeriveClauseKindMismatch.out b/tests/purs/failing/DeriveClauseKindMismatch.out new file mode 100644 index 0000000000..65799ec128 --- /dev/null +++ b/tests/purs/failing/DeriveClauseKindMismatch.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseKindMismatch.purs:7:11 - 7:13 (line 7, column 11 - line 7, column 13) + + Could not match kind +   +  Type -> Type +   + with kind +   +  Type +   + +while checking that type Box + has kind Type +while inferring the kind of Eq Box +in type class instance +  + Data.Eq.Eq Box +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseKindMismatch.purs b/tests/purs/failing/DeriveClauseKindMismatch.purs new file mode 100644 index 0000000000..5404a49dee --- /dev/null +++ b/tests/purs/failing/DeriveClauseKindMismatch.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +data Box a = Box a + derive (Eq) diff --git a/tests/purs/failing/DeriveClauseNewtypeOverlap.out b/tests/purs/failing/DeriveClauseNewtypeOverlap.out new file mode 100644 index 0000000000..fcbfbb733e --- /dev/null +++ b/tests/purs/failing/DeriveClauseNewtypeOverlap.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseNewtypeOverlap.purs:10:1 - 10:34 (line 10, column 1 - line 10, column 34) + + Overlapping type class instances found for +   +  Data.Newtype.Newtype Wrapper +  String  +   + The following instances were found: + + instance in module Main with type Newtype Wrapper String (line 8, column 11 - line 8, column 18) + instance in module Main with type Newtype Wrapper String (line 10, column 1 - line 10, column 34) + + +in type class instance +  + Data.Newtype.Newtype Wrapper + String  +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseNewtypeOverlap.purs b/tests/purs/failing/DeriveClauseNewtypeOverlap.purs new file mode 100644 index 0000000000..0ba9b83cfb --- /dev/null +++ b/tests/purs/failing/DeriveClauseNewtypeOverlap.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +import Prelude +import Data.Newtype (class Newtype, unwrap) + +newtype Wrapper = Wrapper String + derive (Newtype) + +derive instance Newtype Wrapper _ + +value :: String +value = unwrap (Wrapper "hi") diff --git a/tests/purs/passing/DerivingClause.purs b/tests/purs/passing/DerivingClause.purs new file mode 100644 index 0000000000..a7f5ed2adb --- /dev/null +++ b/tests/purs/passing/DerivingClause.purs @@ -0,0 +1,53 @@ +module Main where + +import Prelude + +import Data.Bifunctor (class Bifunctor, bimap) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Foldable (class Foldable, foldMap) +import Data.Traversable (class Traversable) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert + +data Color = Red | Green | Blue + derive (Eq, Ord) + +newtype Name = Name String + derive (Eq, Ord) + +data List a = Nil | Cons a (List a) + derive (Functor, Foldable, Traversable) + +data Either2 a b = Left2 a | Right2 b + derive (Bifunctor) + +derive instance Eq a => Eq (Either2 a a) + +data Direction = North | South | East | West + derive (Generic) + +newtype Wrapper = Wrapper String + derive (Newtype) + +data Pair a = Pair a a + derive (Functor) + +data Box a = Empty | Full a + derive (Functor) + +derive instance Eq a => Eq (Box a) + +main :: Effect Unit +main = do + assert $ Red == Red + assert $ Red < Green + assert $ Name "Alice" == Name "Alice" + assert $ foldMap show (Cons 1 (Cons 2 Nil)) == "12" + assert $ bimap (_ + 1) (_ * 2) (Left2 3) == Left2 4 + assert $ map (_ + 1) (Full 1) == Full 2 + assert $ case map (_ + 1) (Pair 1 2) of + Pair 2 3 -> true + _ -> false + log "Done"