From 6c481c890e0aa32a02b880b8621865debb8c00b6 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 6 Feb 2020 22:19:50 +0100 Subject: [PATCH 001/105] Add ES imports/exports to CoreImp AST --- src/Language/PureScript/CoreImp/AST.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index b6dcad1446..b036588652 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -92,6 +92,10 @@ data AST -- ^ instanceof check | Comment (Maybe SourceSpan) [Comment] AST -- ^ Commented JavaScript + | Import (Maybe SourceSpan) Text PSString + -- ^ Imported identifier and path to its module + | Export (Maybe SourceSpan) [Text] (Maybe PSString) + -- ^ Exported identifiers and optional path to their module (for re-exports) deriving (Show, Eq) withSourceSpan :: SourceSpan -> AST -> AST @@ -123,6 +127,8 @@ withSourceSpan withSpan = go where go (Throw _ js) = Throw ss js go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 go (Comment _ com j) = Comment ss com j + go (Import _ ident from) = Import ss ident from + go (Export _ idents from) = Export ss idents from getSourceSpan :: AST -> Maybe SourceSpan getSourceSpan = go where @@ -150,6 +156,8 @@ getSourceSpan = go where go (Throw ss _) = ss go (InstanceOf ss _ _) = ss go (Comment ss _ _) = ss + go (Import ss _ _) = ss + go (Export ss _ _) = ss everywhere :: (AST -> AST) -> AST -> AST everywhere f = go where From 52a692b67d66c092bab15619ab0900c8ee7805ed Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 6 Feb 2020 22:21:08 +0100 Subject: [PATCH 002/105] Print ES imports/exports --- src/Language/PureScript/CodeGen/JS/Printer.hs | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index b69270cdac..d602149c49 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -119,6 +119,27 @@ literals = mkPattern' match' , mconcat <$> forM com comment , prettyPrintJS' js ] + match (Import _ ident from) = return . emit $ + "import * as " <> ident <> " from " <> prettyPrintStringJS from + match (Export _ [] _) = return $ emit "" + match (Export _ idents from) = mconcat <$> sequence + [ return $ emit "export {\n" + , withIndent $ do + let exportsStrings = emit . exportedIdentToString from <$> idents + indentString <- currentIndent + return . intercalate (emit ",\n") $ (indentString <>) <$> exportsStrings + , return $ emit "\n" + , currentIndent + , return . emit $ "}" <> maybe "" ((" from " <>) . prettyPrintStringJS) from + ] + where + exportedIdentToString Nothing ident + | nameIsJsReserved ident || nameIsJsBuiltIn ident + = "$$" <> ident <> " as " <> ident + exportedIdentToString _ "$main" + = T.concatMap identCharToText "$main" <> " as $main" + exportedIdentToString _ ident + = T.concatMap identCharToText ident match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen From cd40596f35ebb53f5fdf6b3786bf45d2d91b2e0c Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 6 Feb 2020 22:27:07 +0100 Subject: [PATCH 003/105] Codegen ES imports for PureScript modules --- src/Language/PureScript/CodeGen/JS.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 2f8a9d3c06..4d6d44ddc6 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -107,9 +107,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = AST.App Nothing (AST.Var Nothing "require") - [AST.StringLiteral Nothing (fromString (".." T.unpack (runModuleName mn') "index.js"))] - withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) + withPos ss $ AST.Import Nothing (moduleNameToJs mnSafe) (fromString (".." T.unpack (runModuleName mn') "index.js")) -- | Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. From 607dd3dad33fb7611f36eed4df6f82c8c3323e24 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 6 Feb 2020 22:38:40 +0100 Subject: [PATCH 004/105] Codegen ES imports for foreign modules --- src/Language/PureScript/CodeGen/JS.hs | 8 ++++---- src/Language/PureScript/Make/Actions.hs | 3 +-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 4d6d44ddc6..7e05d688b6 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -19,7 +19,7 @@ import Data.List ((\\), intersect) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -48,9 +48,9 @@ moduleToJs :: forall m . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann - -> Maybe AST + -> Maybe PSString -> m [AST] -moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = +moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps @@ -66,7 +66,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = comments <- not <$> asks optionsNoComments let strict = AST.StringLiteral Nothing "use strict" let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict - let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] + let foreign' = maybe [] (pure . AST.Import Nothing "$foreign") $ if null foreigns then Nothing else foreignInclude let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 1fb4ed52ff..16385a4721 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -36,7 +36,6 @@ import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ -import qualified Language.PureScript.CoreImp.AST as Imp import Language.PureScript.Crash import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Docs.Prim as Docs.Prim @@ -207,7 +206,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = | not $ requiresForeign m -> do return Nothing | otherwise -> do - return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] + return $ Just "./foreign.js" Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude From 19878e38f39a9df4617e2eff51b4b5d2655802ed Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 6 Feb 2020 22:52:36 +0100 Subject: [PATCH 005/105] Codegen ES exports --- src/Language/PureScript/CodeGen/JS.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 7e05d688b6..73e2843638 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,6 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat import Protolude (ordNub) -import Control.Arrow ((&&&)) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) @@ -70,9 +69,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps - let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps - ++ map (mkString . runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps'] + return $ moduleBody ++ [ AST.Export Nothing (map runIdent foreignExps) foreignInclude + , AST.Export Nothing (map runIdent standardExps) Nothing + ] where From 48898619f5f067b4ab5dd002837495c65a17ff3f Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 8 Feb 2020 11:25:23 +0100 Subject: [PATCH 006/105] Extract both CJS and ES exports from foreign modules --- src/Language/PureScript/Bundle.hs | 48 ++++++++++++++++++++++--- src/Language/PureScript/Make/Actions.hs | 2 +- 2 files changed, 44 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 82bf1cb234..7ff6d9cbd9 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -31,7 +31,7 @@ import Data.Foldable (fold) import Data.Generics (GenericM, everything, everythingWithContext, everywhere, gmapMo, mkMp, mkQ, mkT) import Data.Graph import Data.List (stripPrefix, (\\)) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import Data.Version (showVersion) import qualified Data.Aeson as A import qualified Data.Map as M @@ -421,19 +421,22 @@ getExportedIdentifiers :: forall m. (MonadError ErrorMessage m) -> JSAST -> m [String] getExportedIdentifiers mname top - | JSAstProgram stmts _ <- top = concat <$> traverse go stmts + | JSAstModule jsModuleItems _ <- top = concat <$> traverse go jsModuleItems | otherwise = err InvalidTopLevel where err :: ErrorMessage -> m a err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) - go stmt - | Just props <- matchExportsAssignment stmt + go (JSModuleStatementListItem jsStatement) + | Just props <- matchExportsAssignment jsStatement = traverse toIdent (trailingCommaList props) - | Just (Public, name, _) <- matchMember stmt + | Just (Public, name, _) <- matchMember jsStatement = pure [name] | otherwise = pure [] + go (JSModuleExportDeclaration _ jsExportDeclaration) = + pure $ exportDeclarationIdentifiers jsExportDeclaration + go _ = pure [] toIdent (JSPropertyNameandValue name _ [_]) = extractLabel' name @@ -442,6 +445,41 @@ getExportedIdentifiers mname top extractLabel' = maybe (err UnsupportedExport) pure . extractLabel + exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) = + exportClauseIdentifiers jsExportClause + exportDeclarationIdentifiers (JSExportLocals jsExportClause _) = + exportClauseIdentifiers jsExportClause + exportDeclarationIdentifiers (JSExport jsStatement _) = + exportStatementIdentifiers jsStatement + + exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) = + mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers + + exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent + exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs + + exportStatementIdentifiers (JSVariable _ jsExpressions _) = + varNames jsExpressions + exportStatementIdentifiers (JSConstant _ jsExpressions _) = + varNames jsExpressions + exportStatementIdentifiers (JSLet _ jsExpressions _) = + varNames jsExpressions + exportStatementIdentifiers (JSClass _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent + exportStatementIdentifiers (JSFunction _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent + exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent + exportStatementIdentifiers _ = [] + + varNames = mapMaybe varName . commaList + + varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident + varName _ = Nothing + + identName (JSIdentName _ ident) = Just ident + identName _ = Nothing + -- Matches JS statements like this: -- var ModuleName = require("file"); matchRequire :: S.Set String diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 16385a4721..738644b8c9 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -281,7 +281,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = checkForeignDecls :: CF.Module ann -> FilePath -> Make () checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parseModule jsStr path foreignIdentsStrs <- either errorParsingModule pure $ getExps js From c03399f3691a137579bddd6d687cf78655494ed4 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 8 Feb 2020 19:56:21 +0100 Subject: [PATCH 007/105] Remove the redundant "use strict;" pragma from modules header ES modules are already parsed in strict mode. --- src/Language/PureScript/CodeGen/JS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 73e2843638..c90013ee17 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -14,7 +14,8 @@ import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Data.List ((\\), intersect) +import Data.Bifunctor (first) +import Data.List ((\\), intersect, uncons) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S @@ -63,10 +64,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = . (\\ (mn : C.primModules)) $ ordNub $ map snd imps F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments - let strict = AST.StringLiteral Nothing "use strict" - let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict + let header = if comments && not (null coms) then AST.Comment Nothing coms else id let foreign' = maybe [] (pure . AST.Import Nothing "$foreign") $ if null foreigns then Nothing else foreignInclude - let moduleBody = header : foreign' ++ jsImports ++ concat optimized + let moduleBody = maybe [] (uncurry (:)) . fmap (first header) . uncons $ foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps return $ moduleBody ++ [ AST.Export Nothing (map runIdent foreignExps) foreignInclude From 71c2de372d91e4bf9dcbf4327fe189afc912b4fa Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 8 Feb 2020 20:37:53 +0100 Subject: [PATCH 008/105] =?UTF-8?q?Don=E2=80=99t=20emit=20empty=20statemen?= =?UTF-8?q?ts=20for=20empty=20exports=20lists?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Language/PureScript/CodeGen/JS.hs | 14 ++++++++++---- src/Language/PureScript/CodeGen/JS/Printer.hs | 4 ++-- src/Language/PureScript/CoreImp/AST.hs | 3 ++- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c90013ee17..9995dd66f3 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -16,10 +16,11 @@ import Control.Monad.Supply.Class import Data.Bifunctor (first) import Data.List ((\\), intersect, uncons) +import qualified Data.List.NonEmpty as NEL (nonEmpty) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -69,9 +70,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = let moduleBody = maybe [] (uncurry (:)) . fmap (first header) . uncons $ foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps - return $ moduleBody ++ [ AST.Export Nothing (map runIdent foreignExps) foreignInclude - , AST.Export Nothing (map runIdent standardExps) Nothing - ] + return $ moduleBody + ++ (maybeToList . exportsToJs foreignInclude $ foreignExps) + ++ (maybeToList . exportsToJs Nothing $ standardExps) where @@ -108,6 +109,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup withPos ss $ AST.Import Nothing (moduleNameToJs mnSafe) (fromString (".." T.unpack (runModuleName mn') "index.js")) + -- | Generates JavaScript code for exporting at least one identifier, + -- eventually from another module. + exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST + exportsToJs from = fmap (flip (AST.Export Nothing) from) . NEL.nonEmpty . fmap runIdent + -- | Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann] diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index d602149c49..8eef0fd017 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -15,6 +15,7 @@ import qualified Control.Arrow as A import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.List.NonEmpty as NEL (toList) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.Common @@ -121,13 +122,12 @@ literals = mkPattern' match' ] match (Import _ ident from) = return . emit $ "import * as " <> ident <> " from " <> prettyPrintStringJS from - match (Export _ [] _) = return $ emit "" match (Export _ idents from) = mconcat <$> sequence [ return $ emit "export {\n" , withIndent $ do let exportsStrings = emit . exportedIdentToString from <$> idents indentString <- currentIndent - return . intercalate (emit ",\n") $ (indentString <>) <$> exportsStrings + return . intercalate (emit ",\n") . NEL.toList $ (indentString <>) <$> exportsStrings , return $ emit "\n" , currentIndent , return . emit $ "}" <> maybe "" ((" from " <>) . prettyPrintStringJS) from diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index b036588652..4753daeee1 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -6,6 +6,7 @@ import Prelude.Compat import Control.Monad ((>=>)) import Control.Monad.Identity (Identity(..), runIdentity) import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL (NonEmpty) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments @@ -94,7 +95,7 @@ data AST -- ^ Commented JavaScript | Import (Maybe SourceSpan) Text PSString -- ^ Imported identifier and path to its module - | Export (Maybe SourceSpan) [Text] (Maybe PSString) + | Export (Maybe SourceSpan) (NEL.NonEmpty Text) (Maybe PSString) -- ^ Exported identifiers and optional path to their module (for re-exports) deriving (Show, Eq) From 7d4ef3df3b1d777b30ad67066cff58bdf1bbe645 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sun, 9 Feb 2020 22:07:42 +0100 Subject: [PATCH 009/105] Bundle ES modules --- src/Language/PureScript/Bundle.hs | 253 +++++++++++++++++++----------- 1 file changed, 160 insertions(+), 93 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 7ff6d9cbd9..eb635b76c9 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -54,6 +54,7 @@ data ErrorMessage = UnsupportedModulePath String | InvalidTopLevel | UnableToParseModule String + | UnsupportedImport | UnsupportedExport | ErrorInModule ModuleIdentifier ErrorMessage | MissingEntryPoint String @@ -111,7 +112,7 @@ data ExportType -- | There are four types of module element we are interested in: -- --- 1) Require statements +-- 1) Import declarations and require statements -- 2) Member declarations -- 3) Export lists -- 4) Everything else @@ -119,22 +120,22 @@ data ExportType -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement - = Require JSStatement String (Either String ModuleIdentifier) + = Import JSModuleItem String (Either String ModuleIdentifier) | Member JSStatement Visibility String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement - | Skip JSStatement + | Skip JSModuleItem deriving (Show) instance A.ToJSON ModuleElement where toJSON = \case - (Require _ name (Right target)) -> - A.object [ "type" .= A.String "Require" + (Import _ name (Right target)) -> + A.object [ "type" .= A.String "Import" , "name" .= name , "target" .= target ] - (Require _ name (Left targetPath)) -> - A.object [ "type" .= A.String "Require" + (Import _ name (Left targetPath)) -> + A.object [ "type" .= A.String "Import" , "name" .= name , "targetPath" .= targetPath ] @@ -150,11 +151,11 @@ instance A.ToJSON ModuleElement where ] (Other stmt) -> A.object [ "type" .= A.String "Other" - , "js" .= getFragment stmt + , "js" .= getFragment (JSAstStatement stmt JSNoAnnot) ] - (Skip stmt) -> + (Skip item) -> A.object [ "type" .= A.String "Skip" - , "js" .= getFragment stmt + , "js" .= getFragment (JSAstModule [item] JSNoAnnot) ] where @@ -177,7 +178,7 @@ instance A.ToJSON ModuleElement where , "dependsOn" .= map keyToJSON dependsOn ] - getFragment = ellipsize . renderToText . minifyJS . flip JSAstStatement JSNoAnnot + getFragment = ellipsize . renderToText . minifyJS where ellipsize text = if T.compareLength text 20 == GT then T.take 19 text `T.snoc` ellipsis else text ellipsis = '\x2026' @@ -195,7 +196,7 @@ instance A.ToJSON Module where -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = - [ "A CommonJS module has an unsupported name (" ++ show s ++ ")." + [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")." , "The following file names are supported:" , " 1) index.js (PureScript native modules)" , " 2) foreign.js (PureScript foreign modules)" @@ -206,10 +207,24 @@ printErrorMessage (UnableToParseModule err) = [ "The module could not be parsed:" , err ] +printErrorMessage UnsupportedImport = + [ "An import was unsupported." + , "Modules can be imported with ES namespace imports declarations:" + , " import * as module from \"Module.Name\"" + , "Alternatively, they can be also be imported with the CommonJS require function:" + , " var module = require(\"Module.Name\")" + ] printErrorMessage UnsupportedExport = - [ "An export was unsupported. Exports can be defined in one of two ways: " - , " 1) exports.name = ..." - , " 2) exports = { ... }" + [ "An export was unsupported." + , "Declarations can be exported as ES named exports:" + , " export decl" + , "Existing identifiers can be exported as well:" + , " export { name }" + , "They can also be renamed on export:" + , " export { name as alias }" + , "Alternatively, CommonJS exports can be defined in one of two ways:" + , " 1) exports.name = value" + , " 2) exports = { name: value }" ] printErrorMessage (ErrorInModule mid e) = ("Error in module " ++ displayIdentifier mid ++ ":") @@ -219,13 +234,13 @@ printErrorMessage (ErrorInModule mid e) = displayIdentifier (ModuleIdentifier name ty) = name ++ " (" ++ showModuleType ty ++ ")" printErrorMessage (MissingEntryPoint mName) = - [ "Couldn't find a CommonJS module for the specified entry point: " ++ mName + [ "Couldn't find neither an ES nor CommonJS module for the specified entry point: " ++ mName ] printErrorMessage (MissingMainModule mName) = - [ "Couldn't find a CommonJS module for the specified main module: " ++ mName + [ "Couldn't find neither an ES nor CommonJS module for the specified main module: " ++ mName ] --- | Calculate the ModuleIdentifier which a require(...) statement imports. +-- | Calculate the ModuleIdentifier imported by an import declaration or a require(...) statement. checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath "./foreign.js" m _ = Right (ModuleIdentifier (moduleName m) Foreign) @@ -247,10 +262,14 @@ stripSuffix suffix xs = -- -- 1) module.name or member["name"] -- --- where module was imported using +-- where module was imported using require -- -- var module = require("Module.Name"); -- +-- or an import declaration +-- +-- import * as module from "Module.Name"; +-- -- 2) name -- -- where name is the name of a member defined in the current module. @@ -262,7 +281,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) imports = mapMaybe toImport es where toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) - toImport (Require _ nm (Right mid)) = Just (nm, mid) + toImport (Import _ nm (Right mid)) = Just (nm, mid) toImport _ = Nothing -- | Collects all member names in scope, so that we can identify dependencies of the second type. @@ -369,48 +388,125 @@ trailingCommaList :: JSCommaTrailingList a -> [a] trailingCommaList (JSCTLComma l _) = commaList l trailingCommaList (JSCTLNone l) = commaList l +identName :: JSIdent -> Maybe String +identName (JSIdentName _ ident) = Just ident +identName _ = Nothing + +exportStatementIdentifiers :: JSStatement -> [String] +exportStatementIdentifiers (JSVariable _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSConstant _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSLet _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSClass _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers (JSFunction _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers _ = [] + +varNames :: JSCommaList JSExpression -> [String] +varNames = mapMaybe varName . commaList + where + varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident + varName _ = Nothing + +sp :: JSAnnot +sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] + +stringLiteral :: String -> JSExpression +stringLiteral s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" + -- | Attempt to create a Module from a JavaScript AST. -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module toModule mids mid filename top - | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts + | JSAstModule jsModuleItems _ <- top = Module mid filename . mconcat <$> traverse toModuleElements jsModuleItems | otherwise = err InvalidTopLevel where err :: ErrorMessage -> m a err = throwError . ErrorInModule mid - toModuleElement :: JSStatement -> m ModuleElement - toModuleElement stmt - | Just (importName, importPath) <- matchRequire mids mid stmt - = pure (Require stmt importName importPath) - toModuleElement stmt - | Just (visibility, name, decl) <- matchMember stmt - = pure (Member stmt visibility name decl []) - toModuleElement stmt - | Just props <- matchExportsAssignment stmt - = ExportsList <$> traverse toExport (trailingCommaList props) + toModuleElements :: JSModuleItem -> m [ModuleElement] + toModuleElements item@(JSModuleImportDeclaration _ jsImportDeclaration) + | JSImportDeclaration jsImportClause jsFromClause _ <- jsImportDeclaration + , JSImportClauseNameSpace jsImportNameSpace <- jsImportClause + , JSImportNameSpace _ _ jsIdent <- jsImportNameSpace + , JSFromClause _ _ importPath <- jsFromClause + , importPath' <- checkImportPath (strValue importPath) mid mids + = fromMaybe (err UnsupportedImport) (pure <$> identName jsIdent) >>= \name -> + pure [Import item name importPath'] + toModuleElements (JSModuleImportDeclaration _ _) + = err UnsupportedImport + + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExportFrom jsExportClause jsFromClause _ <- jsExportDeclaration + , JSFromClause _ _ from <- jsFromClause + , JSExportClause _ jsExportSpecifiers _ <- jsExportClause + = pure . ExportsList <$> exportSpecifiersList (Just (strValue from)) jsExportSpecifiers + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExportLocals jsExportClause _ <- jsExportDeclaration + , JSExportClause _ jsExportSpecifiers _ <- jsExportClause + = pure . ExportsList <$> exportSpecifiersList Nothing jsExportSpecifiers + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExport jsStatement _ <- jsExportDeclaration + = traverse (toExport' Nothing) (exportStatementIdentifiers jsStatement) >>= \exports -> + pure [ Other jsStatement + , ExportsList exports + ] + + toModuleElements item@(JSModuleStatementListItem jsStatement) + | Just (importName, importPath) <- matchRequire mids mid jsStatement + = pure [Import item importName importPath] + toModuleElements (JSModuleStatementListItem jsStatement) + | Just (visibility, name, decl) <- matchMember jsStatement + = pure [Member jsStatement visibility name decl []] + toModuleElements (JSModuleStatementListItem jsStatement) + | Just props <- matchExportsAssignment jsStatement + = pure . ExportsList <$> traverse objectPropertyToExport (trailingCommaList props) where - toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) - toExport (JSPropertyNameandValue name _ [val]) = - (,,val,[]) <$> exportType val + objectPropertyToExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) + objectPropertyToExport (JSPropertyNameandValue name _ [val]) = + (,,val,[]) <$> expressionExportType val <*> extractLabel' name - toExport _ = err UnsupportedExport + objectPropertyToExport _ = err UnsupportedExport - exportType :: JSExpression -> m ExportType - exportType (JSMemberDot f _ _) + expressionExportType :: JSExpression -> m ExportType + expressionExportType (JSMemberDot f _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport - exportType (JSMemberSquare f _ _ _) + expressionExportType (JSMemberSquare f _ _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport - exportType (JSIdentifier _ s) = pure (RegularExport s) - exportType _ = err UnsupportedExport + expressionExportType (JSIdentifier _ s) = pure (RegularExport s) + expressionExportType _ = err UnsupportedExport extractLabel' = maybe (err UnsupportedExport) pure . extractLabel - toModuleElement other = pure (Other other) + toModuleElements (JSModuleStatementListItem other) = pure [Other other] + + exportSpecifiersList from = + fmap catMaybes . traverse (exportSpecifier from) . commaList + + exportSpecifier from (JSExportSpecifier jsIdent) + = traverse (toExport' from) $ identName jsIdent + exportSpecifier from (JSExportSpecifierAs jsIdent _ jsIdentAs) + = sequence $ toExport from <$> identName jsIdent <*> identName jsIdentAs + + toExport :: Maybe String -> String -> String -> m (ExportType, String, JSExpression, [Key]) + toExport (Just "./foreign.js") name as = + pure . (ForeignReexport, as,, []) $ + (JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot + (stringLiteral name) JSNoAnnot) + toExport (Just _) _ _ = err UnsupportedExport + toExport Nothing name as = + pure (RegularExport name, as, JSIdentifier sp name, []) + + toExport' from name = toExport from name name -- Get a list of all the exported identifiers from a foreign module. -- @@ -458,28 +554,6 @@ getExportedIdentifiers mname top exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs - exportStatementIdentifiers (JSVariable _ jsExpressions _) = - varNames jsExpressions - exportStatementIdentifiers (JSConstant _ jsExpressions _) = - varNames jsExpressions - exportStatementIdentifiers (JSLet _ jsExpressions _) = - varNames jsExpressions - exportStatementIdentifiers (JSClass _ jsIdent _ _ _ _ _) = - maybeToList . identName $ jsIdent - exportStatementIdentifiers (JSFunction _ jsIdent _ _ _ _ _) = - maybeToList . identName $ jsIdent - exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = - maybeToList . identName $ jsIdent - exportStatementIdentifiers _ = [] - - varNames = mapMaybe varName . commaList - - varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident - varName _ = Nothing - - identName (JSIdentName _ ident) = Just ident - identName _ = Nothing - -- Matches JS statements like this: -- var ModuleName = require("file"); matchRequire :: S.Set String @@ -560,8 +634,8 @@ compile modules entryPoints = filteredModules where -- | Create a set of vertices for a module element. -- - -- Require statements don't contribute towards dependencies, since they effectively get - -- inlined wherever they are used inside other module elements. + -- Imports declarations and require statements don't contribute towards dependencies, + -- since they effectively get inlined wherever they are used inside other module elements. toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)] toVertices p m@(ExportsList exps) = map toVertex exps @@ -601,11 +675,11 @@ compile modules entryPoints = filteredModules | otherwise = d : go rest skipDecl :: ModuleElement -> ModuleElement - skipDecl (Require s _ _) = Skip s - skipDecl (Member s _ _ _ _) = Skip s - skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot) - skipDecl (Other s) = Skip s - skipDecl (Skip s) = Skip s + skipDecl (Import item _ _) = Skip item + skipDecl (Member stmt _ _ _ _) = Skip $ JSModuleStatementListItem stmt + skipDecl (ExportsList _) = Skip . JSModuleStatementListItem $ JSEmptyStatement JSNoAnnot + skipDecl (Other stmt) = Skip $ JSModuleStatementListItem stmt + skipDecl (Skip item) = Skip item -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement @@ -614,7 +688,7 @@ compile modules entryPoints = filteredModules isDeclUsed :: ModuleElement -> Bool isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility) - isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced + isDeclUsed (Import _ _ (Right midRef)) = midRef `S.member` modulesReferenced isDeclUsed _ = True isKeyUsed :: Key -> Bool @@ -635,7 +709,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top return (m, mid, mapMaybe getKey els) getKey :: ModuleElement -> Maybe ModuleIdentifier - getKey (Require _ _ (Right mi)) = Just mi + getKey (Import _ _ (Right mi)) = Just mi getKey _ = Nothing -- | A module is empty if it contains no exported members (in other words, @@ -648,7 +722,7 @@ isModuleEmpty (Module _ _ els) = all isElementEmpty els where isElementEmpty :: ModuleElement -> Bool isElementEmpty (ExportsList exps) = null exps - isElementEmpty Require{} = True + isElementEmpty Import{} = True isElementEmpty (Other _) = True isElementEmpty (Skip _) = True isElementEmpty _ = False @@ -689,7 +763,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o }) (offsets (0,0) (Right 1 : positions))) moduleFns - (scanl (+) (3 + moduleLength [prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top + (scanl (+) (3 + moduleLength [JSModuleStatementListItem prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top (map snd modulesJS) } where @@ -699,7 +773,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest offsets _ _ = [] - moduleLength :: [JSStatement] -> Int + moduleLength :: [JSModuleItem] -> Int moduleLength = everything (+) (mkQ 0 countw) where countw :: CommentAnnotation -> Int @@ -718,13 +792,13 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o (jsDecls, lengths) = unzip $ map declToJS ds withLength :: [JSStatement] -> ([JSStatement], Either Int Int) - withLength n = (n, Right $ moduleLength n) + withLength n = (n, Right . moduleLength $ JSModuleStatementListItem <$> n) declToJS :: ModuleElement -> ([JSStatement], Either Int Int) declToJS (Member n _ _ _ _) = withLength [n] declToJS (Other n) = withLength [n] declToJS (Skip n) = ([], Left $ moduleLength [n]) - declToJS (Require _ nm req) = withLength + declToJS (Import _ nm req) = withLength [ JSVariable lfsp (cList [ @@ -732,15 +806,15 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) ] - declToJS (ExportsList exps) = withLength $ map toExport exps + declToJS (ExportsList exps) = withLength $ map toCommonJSExport exps where - toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement - toExport (_, nm, val, _) = + toCommonJSExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement + toCommonJSExport (_, nm, val, _) = JSAssignStatement (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot - (str nm) JSNoAnnot) + (stringLiteral nm) JSNoAnnot) (JSAssign sp) val (JSSemi JSNoAnnot) @@ -778,22 +852,18 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o require :: String -> JSExpression require mn = - JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot + JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot + (cList [ stringLiteral mn ]) JSNoAnnot moduleReference :: JSAnnot -> String -> JSExpression moduleReference a mn = JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot - (str mn) JSNoAnnot + (stringLiteral mn) JSNoAnnot innerModuleReference :: JSAnnot -> String -> JSExpression innerModuleReference a mn = JSMemberSquare (JSIdentifier a "$PS") JSNoAnnot - (str mn) JSNoAnnot - - - str :: String -> JSExpression - str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" - + (stringLiteral mn) JSNoAnnot emptyObj :: JSAnnot -> JSExpression emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot @@ -861,9 +931,6 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o lfsp :: JSAnnot lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] - sp :: JSAnnot - sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] - -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final JavaScript bundle. @@ -882,7 +949,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename reportRawModules forM_ entryPoints $ \mIdent -> when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) input <- forM inputStrs $ \(ident, filename, js) -> do - ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) + ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parseModule js (moduleName ident) return (ident, filename, ast) let mids = S.fromList (map (moduleName . mid) input) From 7f0c07e98b616e4a931964d210c7059a65b1a6fd Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 15 Feb 2020 17:33:55 +0100 Subject: [PATCH 010/105] Load ES modules with `esm` in the Node.js REPL and tests --- app/Command/REPL.hs | 2 +- tests/TestCompiler.hs | 8 ++++++-- tests/TestPsci/TestEnv.hs | 7 +++++-- tests/support/package.json | 1 + 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index f44c1e8abe..c0b8a81f89 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -289,7 +289,7 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown eval _ _ = do writeFile indexFile "require('$PSCI')['$main']();" process <- maybe findNodeProcess (pure . pure) nodePath - result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process + result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ ["--require", "esm", indexFile]) "") process case result of Just (ExitSuccess, out, _) -> putStrLn out Just (ExitFailure _, _, err) -> putStrLn err diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 46502077da..fe252feecd 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -43,8 +43,9 @@ import qualified Data.ByteString.Lazy as BS import Control.Monad +import System.Directory (getCurrentDirectory) import System.Exit -import System.Process +import System.Process (readProcessWithExitCode) import System.FilePath import System.IO import System.IO.UTF8 (readUTF8File) @@ -167,7 +168,10 @@ assertCompiles supportModules supportExterns supportForeigns inputFiles outputFi process <- findNodeProcess let entryPoint = modulesDir "index.js" writeFile entryPoint "require('Main').main()" - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + result <- forM process $ \node -> do + cwd <- getCurrentDirectory + let esm = cwd "tests" "support" "node_modules" "esm" + readProcessWithExitCode node ["--require", esm, entryPoint] "" hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of Just (ExitSuccess, out, err) diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 31d5fdc591..4ba4d93b9e 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -6,7 +6,7 @@ import Prelude () import Prelude.Compat import Control.Exception.Lifted (bracket_) -import Control.Monad (void, when) +import Control.Monad (forM, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) import Data.Foldable (traverse_) @@ -59,7 +59,10 @@ jsEval :: TestPSCi String jsEval = liftIO $ do writeFile indexFile "require('$PSCI')['$main']();" process <- findNodeProcess - result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process + result <- forM process $ \node -> do + cwd <- getCurrentDirectory + let esm = cwd "tests" "support" "node_modules" "esm" + readProcessWithExitCode node ["--require", esm, indexFile] "" case result of Just (ExitSuccess, out, _) -> return out Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure diff --git a/tests/support/package.json b/tests/support/package.json index 0e54c5ed3a..7fc3144c4d 100644 --- a/tests/support/package.json +++ b/tests/support/package.json @@ -2,6 +2,7 @@ "private": true, "dependencies": { "bower": "^1.8.8", + "esm": "^3.2.25", "glob": "^5.0.14", "rimraf": "^2.5.2" } From e00695360d3eeeb64423962a104c166673fb3097 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 15 Feb 2020 17:45:51 +0100 Subject: [PATCH 011/105] Escape primes in modules accessors --- src/Language/PureScript/CodeGen/JS.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 9995dd66f3..294cef113c 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -178,10 +178,13 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an -- indexer is returned. - accessor :: Ident -> AST -> AST - accessor (Ident prop) = accessorString $ mkString prop - accessor (GenIdent _ _) = internalError "GenIdent in accessor" - accessor UnusedIdent = internalError "UnusedIdent in accessor" + moduleAccessor :: Ident -> AST -> AST + moduleAccessor (Ident prop) = moduleAccessorString prop + moduleAccessor (GenIdent _ _) = internalError "GenIdent in moduleAccessor" + moduleAccessor UnusedIdent = internalError "UnusedIdent in moduleAccessor" + + moduleAccessorString :: Text -> AST -> AST + moduleAccessorString = accessorString . mkString . T.replace "'" "$prime" accessorString :: PSString -> AST -> AST accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) @@ -311,7 +314,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreignInclude = -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn')) + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = moduleAccessor (f a) (AST.Var Nothing (moduleNameToJs mn')) qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST From 243ec5ef16e8f08f4f20516f2cd20574303bf2ec Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 15 Feb 2020 17:46:56 +0100 Subject: [PATCH 012/105] Forbid unescaped primes in foreign modules exports --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 8 ++--- .../DeprecatedFFIPrime.js | 0 .../DeprecatedFFIPrime.out | 32 +++++++++---------- tests/purs/failing/DeprecatedFFIPrime.purs | 10 ++++++ tests/purs/warning/DeprecatedFFIPrime.purs | 10 ------ 6 files changed, 31 insertions(+), 31 deletions(-) rename tests/purs/{warning => failing}/DeprecatedFFIPrime.js (100%) rename tests/purs/{warning => failing}/DeprecatedFFIPrime.out (51%) create mode 100644 tests/purs/failing/DeprecatedFFIPrime.purs delete mode 100644 tests/purs/warning/DeprecatedFFIPrime.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 90dfc43fdd..afe7f31dcd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -675,7 +675,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" , indent . paras $ [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")." - , line $ "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." + , line $ "Primes are not allowed in identifiers exported from FFI modules." ] ] renderSimpleErrorMessage InvalidDoBind = diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 738644b8c9..6be4bdebc7 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -287,7 +287,7 @@ checkForeignDecls m path = do let deprecatedFFI = filter (any (== '\'')) foreignIdentsStrs unless (null deprecatedFFI) $ - warningDeprecatedForeignPrimes deprecatedFFI + errorDeprecatedForeignPrimes deprecatedFFI foreignIdents <- either errorInvalidForeignIdentifiers @@ -319,9 +319,9 @@ checkForeignDecls m path = do errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) - warningDeprecatedForeignPrimes :: [String] -> Make () - warningDeprecatedForeignPrimes = - tell . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) + errorDeprecatedForeignPrimes :: [String] -> Make a + errorDeprecatedForeignPrimes = + throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = diff --git a/tests/purs/warning/DeprecatedFFIPrime.js b/tests/purs/failing/DeprecatedFFIPrime.js similarity index 100% rename from tests/purs/warning/DeprecatedFFIPrime.js rename to tests/purs/failing/DeprecatedFFIPrime.js diff --git a/tests/purs/warning/DeprecatedFFIPrime.out b/tests/purs/failing/DeprecatedFFIPrime.out similarity index 51% rename from tests/purs/warning/DeprecatedFFIPrime.out rename to tests/purs/failing/DeprecatedFFIPrime.out index 94e1912e92..fd22d4708b 100644 --- a/tests/purs/warning/DeprecatedFFIPrime.out +++ b/tests/purs/failing/DeprecatedFFIPrime.out @@ -1,56 +1,56 @@ -Warning 1 of 4: +Error 1 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier a' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 2 of 4: +Error 2 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier b' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 3 of 4: +Error 3 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier c' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 4 of 4: +Error 4 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier d' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. diff --git a/tests/purs/failing/DeprecatedFFIPrime.purs b/tests/purs/failing/DeprecatedFFIPrime.purs new file mode 100644 index 0000000000..0100e1fad8 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFIPrime.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +module Main where + +foreign import a' :: Number +foreign import b' :: Number +foreign import c' :: Number +foreign import d' :: Number diff --git a/tests/purs/warning/DeprecatedFFIPrime.purs b/tests/purs/warning/DeprecatedFFIPrime.purs deleted file mode 100644 index 3c57a19d92..0000000000 --- a/tests/purs/warning/DeprecatedFFIPrime.purs +++ /dev/null @@ -1,10 +0,0 @@ --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime -module Main where - -foreign import a' :: Number -foreign import b' :: Number -foreign import c' :: Number -foreign import d' :: Number From ddbb2ad5fe81d77ade6ae74d79faf0b03bec707c Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 15 Feb 2020 17:47:20 +0100 Subject: [PATCH 013/105] Run tests against patched dependencies --- tests/support/bower.json | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/tests/support/bower.json b/tests/support/bower.json index 850a61c429..8bacfbbf66 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,8 +1,8 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "5.0.0", - "purescript-assert": "4.0.0", + "purescript-arrays": "#55cb9e6d6766c74c275924324f520b368931c5e6", + "purescript-assert": "https://github.com/kl0tl/purescript-assert.git#no-foreign-primes", "purescript-bifunctors": "4.0.0", "purescript-console": "4.1.0", "purescript-control": "4.0.0", @@ -27,10 +27,10 @@ "purescript-prelude": "#c932361d008379958f14ca8cc2fe32e06cc2647d", "purescript-proxy": "3.0.0", "purescript-psci-support": "4.0.0", - "purescript-refs": "4.1.0", + "purescript-refs": "#0fc21a8476f74139cf220084166d1e1822ed0d3a", "purescript-safe-coerce": "0.0.2", - "purescript-st": "4.0.0", - "purescript-strings": "4.0.0", + "purescript-st": "https://github.com/kl0tl/purescript-st.git#no-foreign-primes", + "purescript-strings": "#eefc8b04c16bce4669ffe88f9d5eeb6333bb2382", "purescript-tailrec": "4.0.0", "purescript-tuples": "5.0.0", "purescript-type-equality": "3.0.0", @@ -40,6 +40,9 @@ }, "resolutions": { "purescript-prelude": "c932361d008379958f14ca8cc2fe32e06cc2647d", - "purescript-typelevel-prelude": "52ac4bcf9a38941606b3d928127089bd363ee946" + "purescript-typelevel-prelude": "52ac4bcf9a38941606b3d928127089bd363ee946", + "purescript-st": "no-foreign-primes", + "purescript-refs": "0fc21a8476f74139cf220084166d1e1822ed0d3a", + "purescript-arrays": "55cb9e6d6766c74c275924324f520b368931c5e6" } } From e5b1798d3d3770bca57d79b0d78f1839332695bf Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Thu, 23 Apr 2020 18:27:59 +0200 Subject: [PATCH 014/105] Rewrite ES modules in the browser REPL client --- app/static/index.js | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/app/static/index.js b/app/static/index.js index 1d0714fd71..f496540c4c 100644 --- a/app/static/index.js +++ b/app/static/index.js @@ -16,13 +16,24 @@ var evaluate = function evaluate(js) { // which will be returned to PSCi. buffer.push(s); }; - // Replace any require(...) statements with lookups on the PSCI object. + // Replace any require and import statements with lookups on the PSCI object + // and export statements with assignments to module.exports. var replaced = js.replace(/require\("[^"]*"\)/g, function(s) { return "PSCI['" + s.split('/')[1] + "']"; + }).replace(/import \* as ([^\s]+) from "([^"]*)"/g, function (_, as, from) { + return "var " + as + " = PSCI['" + from.split('/')[1] + "']"; + }).replace(/export \{([^}]+)\} from "\.\/foreign\.js";?/g, function (_, exports) { + return exports.replace(/^\s*([^,\s]+),?\s*$/gm, function (_, exported) { + return "module.exports." + exported + " = $foreign." + exported + ";"; + }); + }).replace(/export \{([^}]+)\};?/g, function (_, exports) { + return exports.replace(/^\s*([^,\s]+)(?: as ([^\s]+))?,?\s*$/gm, function (_, exported, as) { + return "module.exports." + (as || exported) + " = " + exported + ";"; + }); }); // Wrap the module and evaluate it. var wrapped = - [ 'var module = {};' + [ 'var module = { exports: {} };' , '(function(module) {' , replaced , '})(module);' From c5ffab6a27c0ae4c07a20bb36c0e4ef0d7008143 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 17:01:32 +0100 Subject: [PATCH 015/105] Revert "Load ES modules with `esm` in the Node.js REPL and tests" This reverts commit 7f0c07e98b616e4a931964d210c7059a65b1a6fd. --- app/Command/REPL.hs | 2 +- tests/TestCompiler.hs | 8 ++------ tests/TestPsci/TestEnv.hs | 7 ++----- tests/support/package.json | 1 - 4 files changed, 5 insertions(+), 13 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index c0b8a81f89..f44c1e8abe 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -289,7 +289,7 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown eval _ _ = do writeFile indexFile "require('$PSCI')['$main']();" process <- maybe findNodeProcess (pure . pure) nodePath - result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ ["--require", "esm", indexFile]) "") process + result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process case result of Just (ExitSuccess, out, _) -> putStrLn out Just (ExitFailure _, _, err) -> putStrLn err diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index fe252feecd..46502077da 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -43,9 +43,8 @@ import qualified Data.ByteString.Lazy as BS import Control.Monad -import System.Directory (getCurrentDirectory) import System.Exit -import System.Process (readProcessWithExitCode) +import System.Process import System.FilePath import System.IO import System.IO.UTF8 (readUTF8File) @@ -168,10 +167,7 @@ assertCompiles supportModules supportExterns supportForeigns inputFiles outputFi process <- findNodeProcess let entryPoint = modulesDir "index.js" writeFile entryPoint "require('Main').main()" - result <- forM process $ \node -> do - cwd <- getCurrentDirectory - let esm = cwd "tests" "support" "node_modules" "esm" - readProcessWithExitCode node ["--require", esm, entryPoint] "" + result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of Just (ExitSuccess, out, err) diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 4ba4d93b9e..31d5fdc591 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -6,7 +6,7 @@ import Prelude () import Prelude.Compat import Control.Exception.Lifted (bracket_) -import Control.Monad (forM, void, when) +import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) import Data.Foldable (traverse_) @@ -59,10 +59,7 @@ jsEval :: TestPSCi String jsEval = liftIO $ do writeFile indexFile "require('$PSCI')['$main']();" process <- findNodeProcess - result <- forM process $ \node -> do - cwd <- getCurrentDirectory - let esm = cwd "tests" "support" "node_modules" "esm" - readProcessWithExitCode node ["--require", esm, indexFile] "" + result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process case result of Just (ExitSuccess, out, _) -> return out Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure diff --git a/tests/support/package.json b/tests/support/package.json index 7fc3144c4d..0e54c5ed3a 100644 --- a/tests/support/package.json +++ b/tests/support/package.json @@ -2,7 +2,6 @@ "private": true, "dependencies": { "bower": "^1.8.8", - "esm": "^3.2.25", "glob": "^5.0.14", "rimraf": "^2.5.2" } From 4713b2a4efbd9f0be58f50d415bc0c74ddf21e93 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 17:06:16 +0100 Subject: [PATCH 016/105] Allow Node.js to load .js files in the output directory as ES modules Node.js loads JavaScript files with a .js extension as CommonJS modules unless they're within a directory with a `"type": "module"` package.json, in which case it loads them as ES modules. --- src/Language/PureScript/Make.hs | 2 ++ src/Language/PureScript/Make/Actions.hs | 18 +++++++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b481b11791..a2affb922b 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -161,6 +161,8 @@ make ma@MakeActions{..} ms = do -- Write the updated build cache database to disk writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb + writePackageJson + -- If generating docs, also generate them for the Prim modules outputPrimDocs diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f9865baefc..b679b655d3 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -18,6 +18,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson (Value(String), (.=), object) import Data.Bifunctor (bimap) import Data.Either (partitionEithers) import Data.Foldable (for_, minimum) @@ -105,6 +106,9 @@ data MakeActions m = MakeActions , writeCacheDb :: CacheDb -> m () -- ^ Write the given cache database to some external source (e.g. a file on -- disk). + , writePackageJson :: m () + -- ^ Write to the output directory the package.json file allowing Node.js to + -- load .js files as ES modules. , outputPrimDocs :: m () -- ^ If generating docs, output the documentation for the Prim modules } @@ -131,6 +135,15 @@ writeCacheDb' -> m () writeCacheDb' = writeJSONFile . cacheDbFile +writePackageJson' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> m () +writePackageJson' outputDir = writeJSONFile (outputDir "package.json") $ object + [ "type" .= String "module" + ] + -- | A set of make actions that read and write modules from the given directory. buildMakeActions :: FilePath @@ -143,7 +156,7 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb outputPrimDocs + MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs where getInputTimestampsAndHashes @@ -278,6 +291,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeCacheDb :: CacheDb -> Make () writeCacheDb = writeCacheDb' outputDir + writePackageJson :: Make () + writePackageJson = writePackageJson' outputDir + -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. checkForeignDecls :: CF.Module ann -> FilePath -> Make () From 7784dd1d326d7a1890429c009892f92e50919e8f Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 17:39:09 +0100 Subject: [PATCH 017/105] Import CommonJS foreign modules through an ES module wrapper --- app/Command/REPL.hs | 6 +- purescript.cabal | 2 + src/Language/JavaScript/AST/JSCommaList.hs | 19 ++++++ src/Language/PureScript/Bundle.hs | 75 +++++++++++----------- src/Language/PureScript/Make/Actions.hs | 52 +++++++++++---- tests/TestBundle.hs | 2 +- 6 files changed, 105 insertions(+), 51 deletions(-) create mode 100644 src/Language/JavaScript/AST/JSCommaList.hs diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index f44c1e8abe..2ae72b2cde 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -51,7 +51,7 @@ import System.IO.UTF8 (readUTF8File) import System.Exit import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) -import System.FilePath.Glob (glob) +import qualified System.FilePath.Glob as Glob import System.Process (readProcessWithExitCode) import qualified Data.ByteString.Lazy.UTF8 as U @@ -115,7 +115,7 @@ pasteMode = -- | Make a JavaScript bundle for the browser. bundle :: IO (Either Bundle.ErrorMessage String) bundle = runExceptT $ do - inputFiles <- liftIO (glob (".psci_modules" "node_modules" "*" "*.js")) + inputFiles <- liftIO $ concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir input <- for inputFiles $ \filename -> do js <- liftIO (readUTF8File filename) mid <- Bundle.guessModuleIdentifier filename @@ -310,7 +310,7 @@ command = loop <$> options where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do - inputFiles <- concat <$> traverse glob psciInputGlob + inputFiles <- concat <$> traverse Glob.glob psciInputGlob e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) when (null modules) . liftIO $ do diff --git a/purescript.cabal b/purescript.cabal index ded50103e1..6c8be98e3c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -121,6 +121,7 @@ common defaults array >=0.5.3.0 && <0.6, base >=4.12.0.0 && <4.13, base-compat >=0.10.5 && <0.11, + blaze-builder >=0.2 && <0.5, blaze-html >=0.9.1.1 && <0.10, bower-json >=1.0.0.1 && <1.1, boxes >=0.1.5 && <0.2, @@ -183,6 +184,7 @@ library hs-source-dirs: src exposed-modules: Control.Monad.Logger + Language.JavaScript.AST.JSCommaList Language.PureScript Language.PureScript.Bundle Language.PureScript.CodeGen diff --git a/src/Language/JavaScript/AST/JSCommaList.hs b/src/Language/JavaScript/AST/JSCommaList.hs new file mode 100644 index 0000000000..df7c982f14 --- /dev/null +++ b/src/Language/JavaScript/AST/JSCommaList.hs @@ -0,0 +1,19 @@ +module Language.JavaScript.AST.JSCommaList where + +import Prelude +import Language.JavaScript.Parser.AST (JSCommaList(JSLNil, JSLOne, JSLCons), JSAnnot(JSNoAnnot)) + +fromCommaList :: JSCommaList a -> [a] +fromCommaList JSLNil = [] +fromCommaList (JSLOne x) = [x] +fromCommaList (JSLCons l _ x) = fromCommaList l ++ [x] + +-- comma lists are reverse-consed +toCommaList :: [a] -> JSCommaList a +toCommaList [] = JSLNil +toCommaList [x] = JSLOne x +toCommaList l = go $ reverse l + where + go [x] = JSLOne x + go (h:t)= JSLCons (go t) JSNoAnnot h + go [] = error "Invalid case in comma-list" diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 44c21c9ebf..1b7d8b98cb 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -13,6 +13,7 @@ module Language.PureScript.Bundle , ModuleType(..) , ErrorMessage(..) , printErrorMessage + , ForeignModuleExports(..) , getExportedIdentifiers , Module ) where @@ -38,6 +39,7 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text.Lazy as T +import Language.JavaScript.AST.JSCommaList (fromCommaList, toCommaList) import Language.JavaScript.Parser import Language.JavaScript.Parser.AST import Language.JavaScript.Process.Minify @@ -90,6 +92,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f where guessModuleType "index.js" = pure Regular guessModuleType "foreign.js" = pure Foreign + guessModuleType "foreign.cjs" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name data Visibility @@ -199,7 +202,8 @@ printErrorMessage (UnsupportedModulePath s) = [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")." , "The following file names are supported:" , " 1) index.js (PureScript native modules)" - , " 2) foreign.js (PureScript foreign modules)" + , " 2) foreign.js (PureScript ES foreign modules)" + , " 3) foreign.cjs (PureScript CommonJS foreign modules)" ] printErrorMessage InvalidTopLevel = [ "Expected a list of source elements at the top level." ] @@ -332,7 +336,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) in (map (\name -> (m, name, Internal)) shorthandNames, bn) toReference (JSFunctionExpression _ _ _ params _ _) bn - = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) + = ([], bn \\ (mapMaybe unIdentifier $ fromCommaList params)) toReference e bn | Just nm <- exportsAccessor e -- exports.foo means there's a dependency on the public member "foo" of @@ -379,14 +383,9 @@ strValue str = go $ drop 1 str go (x : xs) = x : go xs go "" = "" -commaList :: JSCommaList a -> [a] -commaList JSLNil = [] -commaList (JSLOne x) = [x] -commaList (JSLCons l _ x) = commaList l ++ [x] - trailingCommaList :: JSCommaTrailingList a -> [a] -trailingCommaList (JSCTLComma l _) = commaList l -trailingCommaList (JSCTLNone l) = commaList l +trailingCommaList (JSCTLComma l _) = fromCommaList l +trailingCommaList (JSCTLNone l) = fromCommaList l identName :: JSIdent -> Maybe String identName (JSIdentName _ ident) = Just ident @@ -408,7 +407,7 @@ exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = exportStatementIdentifiers _ = [] varNames :: JSCommaList JSExpression -> [String] -varNames = mapMaybe varName . commaList +varNames = mapMaybe varName . fromCommaList where varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident varName _ = Nothing @@ -493,8 +492,9 @@ toModule mids mid filename top toModuleElements (JSModuleStatementListItem other) = pure [Other other] + exportSpecifiersList (Just "./foreign.cjs") = const $ pure [] exportSpecifiersList from = - fmap catMaybes . traverse (exportSpecifier from) . commaList + fmap catMaybes . traverse (exportSpecifier from) . fromCommaList exportSpecifier from (JSExportSpecifier jsIdent) = traverse (toExport' from) $ identName jsIdent @@ -512,6 +512,18 @@ toModule mids mid filename top toExport' from name = toExport from name name +data ForeignModuleExports = + ForeignModuleExports + { cjsExports :: [String] + , esExports :: [String] + } deriving (Show) + +instance Semigroup ForeignModuleExports where + (ForeignModuleExports cjsExports esExports) <> (ForeignModuleExports cjsExports' esExports') = + ForeignModuleExports (cjsExports <> cjsExports') (esExports <> esExports') +instance Monoid ForeignModuleExports where + mempty = ForeignModuleExports [] [] + -- Get a list of all the exported identifiers from a foreign module. -- -- TODO: what if we assign to exports.foo and then later assign to @@ -519,9 +531,9 @@ toModule mids mid filename top getExportedIdentifiers :: forall m. (MonadError ErrorMessage m) => String -> JSAST - -> m [String] + -> m ForeignModuleExports getExportedIdentifiers mname top - | JSAstModule jsModuleItems _ <- top = concat <$> traverse go jsModuleItems + | JSAstModule jsModuleItems _ <- top = fold <$> traverse go jsModuleItems | otherwise = err InvalidTopLevel where err :: ErrorMessage -> m a @@ -529,14 +541,15 @@ getExportedIdentifiers mname top go (JSModuleStatementListItem jsStatement) | Just props <- matchExportsAssignment jsStatement - = traverse toIdent (trailingCommaList props) + = do cjsExports <- traverse toIdent (trailingCommaList props) + pure ForeignModuleExports{ cjsExports, esExports = [] } | Just (Public, name, _) <- matchMember jsStatement - = pure [name] + = pure ForeignModuleExports{ cjsExports = [name], esExports = [] } | otherwise - = pure [] + = pure mempty go (JSModuleExportDeclaration _ jsExportDeclaration) = - pure $ exportDeclarationIdentifiers jsExportDeclaration - go _ = pure [] + pure ForeignModuleExports{ cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration } + go _ = pure mempty toIdent (JSPropertyNameandValue name _ [_]) = extractLabel' name @@ -553,7 +566,7 @@ getExportedIdentifiers mname top exportStatementIdentifiers jsStatement exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) = - mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers + mapMaybe exportSpecifierName $ fromCommaList jsExportsSpecifiers exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs @@ -566,12 +579,12 @@ matchRequire :: S.Set String -> Maybe (String, Either String ModuleIdentifier) matchRequire mids mid stmt | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- commaList jsInit + , [JSVarInitExpression var varInit] <- fromCommaList jsInit , JSIdentifier _ importName <- var , JSVarInit _ jsInitEx <- varInit , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req - , [ Just importPath ] <- map fromStringLiteral (commaList argsE) + , [ Just importPath ] <- map fromStringLiteral (fromCommaList argsE) , importPath' <- checkImportPath importPath mid mids = Just (importName, importPath') | otherwise @@ -582,7 +595,7 @@ matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- commaList jsInit + , [JSVarInitExpression var varInit] <- fromCommaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit = Just (Internal, name, decl) @@ -805,7 +818,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o declToJS (Import _ nm req) = withLength [ JSVariable lfsp - (cList [ + (toCommaList [ JSVarInitExpression (JSIdentifier sp nm) (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) @@ -823,16 +836,6 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o val (JSSemi JSNoAnnot) - -- comma lists are reverse-consed - cList :: [a] -> JSCommaList a - cList [] = JSLNil - cList [x] = JSLOne x - cList l = go $ reverse l - where - go [x] = JSLOne x - go (h:t)= JSLCons (go t) JSNoAnnot h - go [] = error "Invalid case in comma-list" - indent :: [JSStatement] -> [JSStatement] indent = everywhere (mkT squash) where @@ -849,7 +852,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o prelude :: JSStatement prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version , WhiteSpace tokenPosnEmpty "\n" ]) - (cList [ + (toCommaList [ JSVarInitExpression (JSIdentifier sp optionsNamespace) (JSVarInit sp (emptyObj sp)) ]) (JSSemi JSNoAnnot) @@ -857,7 +860,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o require :: String -> JSExpression require mn = JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot - (cList [ stringLiteral mn ]) JSNoAnnot + (toCommaList [ stringLiteral mn ]) JSNoAnnot moduleReference :: JSAnnot -> String -> JSExpression moduleReference a mn = @@ -926,7 +929,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o [JSMethodCall (JSMemberDot (moduleReference lf mn) JSNoAnnot (JSIdentifier JSNoAnnot "main")) - JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)] + JSNoAnnot (toCommaList []) JSNoAnnot (JSSemi JSNoAnnot)] lf :: JSAnnot lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index b679b655d3..ea1e15757a 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -11,6 +11,7 @@ module Language.PureScript.Make.Actions import Prelude +import Blaze.ByteString.Builder (toByteString) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -31,8 +32,11 @@ import qualified Data.Text.IO as TIO import qualified Data.Text.Encoding as TE import Data.Time.Clock (UTCTime) import Data.Version (showVersion) +import qualified Language.JavaScript.AST.JSCommaList as JSAST (toCommaList) import qualified Language.JavaScript.Parser as JS import Language.PureScript.AST +import qualified Language.JavaScript.Parser.AST as JSAST +import Language.JavaScript.Pretty.Printer (renderJS) import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer @@ -248,12 +252,29 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Just path | not $ requiresForeign m -> tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path - | otherwise -> - checkForeignDecls m path + | otherwise -> do + (foreignModuleType, foreignIdents) <- checkForeignDecls m path + case foreignModuleType of + ESModule -> copyFile path (outputFilename mn "foreign.js") + CJSModule -> do + copyFile path (outputFilename mn "foreign.cjs") + writeESForeignModuleWrapper mn foreignIdents + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return () - for_ (mn `M.lookup` foreigns) $ \path -> - copyFile path (outputFilename mn "foreign.js") + + writeESForeignModuleWrapper :: ModuleName -> S.Set Ident -> Make () + writeESForeignModuleWrapper mn idents = + writeTextFile (outputFilename mn "foreign.js") . toByteString . renderJS $ + JSAST.JSAstModule + [ JSAST.JSModuleExportDeclaration JSAST.JSNoAnnot + (JSAST.JSExportFrom + (JSAST.JSExportClause JSAST.JSAnnotSpace + (JSAST.toCommaList $ JSAST.JSExportSpecifier . JSAST.JSIdentName JSAST.JSAnnotSpace . T.unpack . runIdent <$> S.toList idents) + JSAST.JSAnnotSpace) + (JSAST.JSFromClause JSAST.JSAnnotSpace JSAST.JSAnnotSpace "\"./foreign.cjs\"") + (JSAST.JSSemi JSAST.JSNoAnnot)) + ] JSAST.JSNoAnnot genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -294,18 +315,26 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writePackageJson :: Make () writePackageJson = writePackageJson' outputDir +data ForeignModuleType = ESModule | CJSModule deriving (Show) + -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: CF.Module ann -> FilePath -> Make () +checkForeignDecls :: CF.Module ann -> FilePath -> Make (ForeignModuleType, S.Set Ident) checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parseModule jsStr path - foreignIdentsStrs <- either errorParsingModule pure $ getExps js + (foreignModuleType, foreignIdentsStrs) <- case getForeignModuleExports js of + Left reason -> errorParsingModule reason + Right (Bundle.ForeignModuleExports{..}) + | null esExports -> do + let deprecatedFFI = filter (elem '\'') cjsExports + unless (null deprecatedFFI) $ + errorDeprecatedForeignPrimes deprecatedFFI - let deprecatedFFI = filter (elem '\'') foreignIdentsStrs - unless (null deprecatedFFI) $ - errorDeprecatedForeignPrimes deprecatedFFI + pure (CJSModule, cjsExports) + | otherwise -> + pure (ESModule, esExports) foreignIdents <- either errorInvalidForeignIdentifiers @@ -323,6 +352,7 @@ checkForeignDecls m path = do throwError . errorMessage' modSS . MissingFFIImplementations mname $ S.toList missingFFI + pure (foreignModuleType, foreignIdents) where mname = CF.moduleName m modSS = CF.moduleSourceSpan m @@ -330,8 +360,8 @@ checkForeignDecls m path = do errorParsingModule :: Bundle.ErrorMessage -> Make a errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just - getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] - getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) + getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleExports + getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) errorInvalidForeignIdentifiers :: [String] -> Make a errorInvalidForeignIdentifiers = diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index ab209d5989..55ab1b3744 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -66,7 +66,7 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do process <- findNodeProcess - jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir + jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir let entryPoint = modulesDir "index.js" let entryModule = map (`ModuleIdentifier` Regular) ["Main"] bundled <- runExceptT $ do From 158774938a8748414836e25a8e7c41d553c66edf Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 17:52:57 +0100 Subject: [PATCH 018/105] Don't let tests nor the REPL compile into a node_modules directory Node.js ignores the package.json file of the output directory otherwise and loads .js files as CommonJS modules. --- app/Command/REPL.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 2 +- tests/TestCompiler.hs | 2 +- tests/TestPsci/TestEnv.hs | 2 +- tests/TestUtils.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 2ae72b2cde..9597a9538e 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -287,7 +287,7 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown eval :: () -> String -> IO () eval _ _ = do - writeFile indexFile "require('$PSCI')['$main']();" + writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" process <- maybe findNodeProcess (pure . pure) nodePath result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process case result of diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 1ceeedf446..28ac295477 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -98,7 +98,7 @@ indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" modulesDir :: FilePath -modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" +modulesDir = ".psci_modules" internalSpan :: P.SourceSpan internalSpan = P.internalModuleSourceSpan "" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 46502077da..5a0a09ae5a 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -166,7 +166,7 @@ assertCompiles supportModules supportExterns supportForeigns inputFiles outputFi Right _ -> do process <- findNodeProcess let entryPoint = modulesDir "index.js" - writeFile entryPoint "require('Main').main()" + writeFile entryPoint "import('./Main/index.js').then(({ main }) => main());" result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 31d5fdc591..7a9c0c6d12 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -57,7 +57,7 @@ execTestPSCi i = do -- command evaluation. jsEval :: TestPSCi String jsEval = liftIO $ do - writeFile indexFile "require('$PSCI')['$main']();" + writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" process <- findNodeProcess result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process case result of diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index dfacc8a107..6b086fcacd 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -236,7 +236,7 @@ trim :: String -> String trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse modulesDir :: FilePath -modulesDir = ".test_modules" "node_modules" +modulesDir = ".test_modules" logpath :: FilePath logpath = "purescript-output" From ba9f084dc5081bf4794c9563a9554a37102328e7 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 18:07:05 +0100 Subject: [PATCH 019/105] Bundle re-exports --- src/Language/PureScript/Bundle.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 1b7d8b98cb..a1e2321b81 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -37,12 +37,15 @@ import Data.Version (showVersion) import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.Text.Lazy as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import Language.JavaScript.AST.JSCommaList (fromCommaList, toCommaList) import Language.JavaScript.Parser import Language.JavaScript.Parser.AST import Language.JavaScript.Process.Minify +import Language.PureScript.Names (ModuleName(..)) +import Language.PureScript.CodeGen.JS.Common (moduleNameToJs) import qualified Paths_purescript as Paths @@ -183,7 +186,7 @@ instance A.ToJSON ModuleElement where getFragment = ellipsize . renderToText . minifyJS where - ellipsize text = if T.compareLength text 20 == GT then T.take 19 text `T.snoc` ellipsis else text + ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text ellipsis = '\x2026' -- | A module is just a list of elements of the types listed above. @@ -502,11 +505,16 @@ toModule mids mid filename top = sequence $ toExport from <$> identName jsIdent <*> identName jsIdentAs toExport :: Maybe String -> String -> String -> m (ExportType, String, JSExpression, [Key]) - toExport (Just "./foreign.js") name as = - pure . (ForeignReexport, as,, []) $ - (JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot - (stringLiteral name) JSNoAnnot) - toExport (Just _) _ _ = err UnsupportedExport + toExport (Just from) name as + | from == "./foreign.js" = + pure . (ForeignReexport, as,, []) $ + (JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot + (stringLiteral name) JSNoAnnot) + | Just from' <- stripSuffix "/index.js" =<< stripPrefix "../" from = + pure . (RegularExport name, as,, []) $ + (JSMemberSquare (JSIdentifier sp (T.unpack . moduleNameToJs . ModuleName $ T.pack from')) JSNoAnnot + (stringLiteral name) JSNoAnnot) + | otherwise = err UnsupportedExport toExport Nothing name as = pure (RegularExport name, as, JSIdentifier sp name, []) From 65dab5dc8c2cced5fa4ca2fb487b8a3fcdcc5fb8 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 18:10:38 +0100 Subject: [PATCH 020/105] Load bundles as CommonJS modules in tests --- tests/TestBundle.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index 55ab1b3744..31b8452aee 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -67,7 +67,7 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil Right _ -> do process <- findNodeProcess jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir - let entryPoint = modulesDir "index.js" + let entryPoint = modulesDir "index.cjs" let entryModule = map (`ModuleIdentifier` Regular) ["Main"] bundled <- runExceptT $ do input <- forM jsFiles $ \filename -> do From 830bbe27dbbf3829588e49832123a5b740212dd1 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 18:12:36 +0100 Subject: [PATCH 021/105] Update Node.js version on CI --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7f0bbfb825..bc82733e74 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ language: node_js node_js: - - "10" + - "14" branches: # Only build master and tagged versions, i.e. not feature branches; feature # branches already get built after opening a pull request. From 4976eee1599300511236b9a491b09ecb332cf852 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 18:19:45 +0100 Subject: [PATCH 022/105] Disallow CommonJS exports named `default` Node.js allows ES modules to import CommonJS modules by providing the module.exports object as their default export and named exports for statically discoverable properties of the module.exports object. This has an unpleasant consequence for foreign imports: CommonJS exports named `default` are only available as the default property of their default export so a `default :: String` identifier imported from a CommonJS foreign module would actually have type `{ default :: String }`! --- src/Language/PureScript/Errors.hs | 8 ++++++++ src/Language/PureScript/Make/Actions.hs | 7 +++++++ .../failing/DeprecatedFFIDefaultCommonJSExport.js | 1 + .../failing/DeprecatedFFIDefaultCommonJSExport.out | 12 ++++++++++++ .../failing/DeprecatedFFIDefaultCommonJSExport.purs | 4 ++++ tests/purs/passing/FFIDefaultESExport.js | 3 +++ tests/purs/passing/FFIDefaultESExport.purs | 7 +++++++ 7 files changed, 42 insertions(+) create mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js create mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out create mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs create mode 100644 tests/purs/passing/FFIDefaultESExport.js create mode 100644 tests/purs/passing/FFIDefaultESExport.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7bc52a59fe..6a82a3d3ac 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -65,6 +65,7 @@ data SimpleErrorMessage | UnusedFFIImplementations ModuleName [Ident] | InvalidFFIIdentifier ModuleName Text | DeprecatedFFIPrime ModuleName Text + | DeprecatedFFIDefaultCommonJSExport ModuleName | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceType @@ -235,6 +236,7 @@ errorCode em = case unwrapErrorMessage em of UnusedFFIImplementations{} -> "UnusedFFIImplementations" InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" + DeprecatedFFIDefaultCommonJSExport {} -> "DeprecatedFFIDefaultCommonJSExport" FileIOError{} -> "FileIOError" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" @@ -699,6 +701,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line $ "Primes are not allowed in identifiers exported from FFI modules." ] ] + renderSimpleErrorMessage (DeprecatedFFIDefaultCommonJSExport mn) = + paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" + , indent . paras $ + [ line $ "CommonJS exports named " <> markCode "default" <> " are not allowed." + ] + ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index ea1e15757a..7a3b539196 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -332,6 +332,9 @@ checkForeignDecls m path = do unless (null deprecatedFFI) $ errorDeprecatedForeignPrimes deprecatedFFI + when (elem "default" cjsExports) $ + errorDeprecatedFFIDefaultCJSExport + pure (CJSModule, cjsExports) | otherwise -> pure (ESModule, esExports) @@ -371,6 +374,10 @@ checkForeignDecls m path = do errorDeprecatedForeignPrimes = throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) + errorDeprecatedFFIDefaultCJSExport :: Make a + errorDeprecatedFFIDefaultCJSExport = + throwError . errorMessage' modSS $ DeprecatedFFIDefaultCommonJSExport mname + parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = case partitionEithers (map parseIdent strs) of diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js new file mode 100644 index 0000000000..8f35a10f24 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js @@ -0,0 +1 @@ +exports.default = undefined; diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out new file mode 100644 index 0000000000..943c7dc313 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs:2:1 - 4:38 (line 2, column 1 - line 4, column 38) + + In the FFI module for Main: + + CommonJS exports named default are not allowed. + + + +See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIDefaultCommonJSExport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs new file mode 100644 index 0000000000..ef70f75ac8 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith DeprecatedFFIDefaultCommonJSExport +module Main where + +foreign import default :: forall a. a diff --git a/tests/purs/passing/FFIDefaultESExport.js b/tests/purs/passing/FFIDefaultESExport.js new file mode 100644 index 0000000000..ab294f31ea --- /dev/null +++ b/tests/purs/passing/FFIDefaultESExport.js @@ -0,0 +1,3 @@ +var message = "Done"; + +export { message as default }; diff --git a/tests/purs/passing/FFIDefaultESExport.purs b/tests/purs/passing/FFIDefaultESExport.purs new file mode 100644 index 0000000000..1d084b6d8d --- /dev/null +++ b/tests/purs/passing/FFIDefaultESExport.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +foreign import default :: String + +main = log default From f73c2bf461b0703a90fdeab335037b47e0b4b208 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 19:00:15 +0100 Subject: [PATCH 023/105] Disallow CommonJS exports and imports in ES foreign modules The require function and the exports object are not available in ES modules on Node.js. --- src/Language/PureScript/Bundle.hs | 50 +++++++++++++++---- src/Language/PureScript/Errors.hs | 12 +++++ src/Language/PureScript/Make/Actions.hs | 48 ++++++++++++------ .../failing/UnsupportedFFICommonJSExports1.js | 2 + .../UnsupportedFFICommonJSExports1.out | 12 +++++ .../UnsupportedFFICommonJSExports1.purs | 5 ++ .../failing/UnsupportedFFICommonJSExports2.js | 4 ++ .../UnsupportedFFICommonJSExports2.out | 13 +++++ .../UnsupportedFFICommonJSExports2.purs | 5 ++ .../failing/UnsupportedFFICommonJSImports1.js | 4 ++ .../UnsupportedFFICommonJSImports1.out | 12 +++++ .../UnsupportedFFICommonJSImports1.purs | 5 ++ .../failing/UnsupportedFFICommonJSImports2.js | 5 ++ .../UnsupportedFFICommonJSImports2.out | 12 +++++ .../UnsupportedFFICommonJSImports2.purs | 5 ++ 15 files changed, 171 insertions(+), 23 deletions(-) create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.purs diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index a1e2321b81..996464542d 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -15,6 +15,8 @@ module Language.PureScript.Bundle , printErrorMessage , ForeignModuleExports(..) , getExportedIdentifiers + , ForeignModuleImports(..) + , getImportedModules , Module ) where @@ -462,8 +464,8 @@ toModule mids mid filename top ] toModuleElements item@(JSModuleStatementListItem jsStatement) - | Just (importName, importPath) <- matchRequire mids mid jsStatement - = pure [Import item importName importPath] + | Just (importName, importPath) <- matchRequire jsStatement + = pure [Import item importName $ checkImportPath importPath mid mids] toModuleElements (JSModuleStatementListItem jsStatement) | Just (visibility, name, decl) <- matchMember jsStatement = pure [Member jsStatement visibility name decl []] @@ -579,13 +581,44 @@ getExportedIdentifiers mname top exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs +data ForeignModuleImports = + ForeignModuleImports + { cjsImports :: [String] + , esImports :: [String] + } deriving (Show) + +instance Semigroup ForeignModuleImports where + (ForeignModuleImports cjsImports esImports) <> (ForeignModuleImports cjsImports' esImports') = + ForeignModuleImports (cjsImports <> cjsImports') (esImports <> esImports') +instance Monoid ForeignModuleImports where + mempty = ForeignModuleImports [] [] + +-- Get a list of all the imported module identifiers from a foreign module. +getImportedModules :: forall m. (MonadError ErrorMessage m) + => String + -> JSAST + -> m ForeignModuleImports +getImportedModules mname top + | JSAstModule jsModuleItems _ <- top = pure $ foldMap go jsModuleItems + | otherwise = err InvalidTopLevel + where + err :: ErrorMessage -> m a + err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) + + go (JSModuleStatementListItem jsStatement) + | Just (_, mid) <- matchRequire jsStatement + = ForeignModuleImports{ cjsImports = [mid], esImports = [] } + go (JSModuleImportDeclaration _ jsImportDeclaration) = + ForeignModuleImports{ cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration] } + go _ = mempty + + importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid + importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid + -- Matches JS statements like this: -- var ModuleName = require("file"); -matchRequire :: S.Set String - -> ModuleIdentifier - -> JSStatement - -> Maybe (String, Either String ModuleIdentifier) -matchRequire mids mid stmt +matchRequire :: JSStatement -> Maybe (String, String) +matchRequire stmt | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- fromCommaList jsInit , JSIdentifier _ importName <- var @@ -593,8 +626,7 @@ matchRequire mids mid stmt , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req , [ Just importPath ] <- map fromStringLiteral (fromCommaList argsE) - , importPath' <- checkImportPath importPath mid mids - = Just (importName, importPath') + = Just (importName, importPath) | otherwise = Nothing diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a82a3d3ac..0749ae43dd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -66,6 +66,8 @@ data SimpleErrorMessage | InvalidFFIIdentifier ModuleName Text | DeprecatedFFIPrime ModuleName Text | DeprecatedFFIDefaultCommonJSExport ModuleName + | UnsupportedFFICommonJSExports ModuleName [Text] + | UnsupportedFFICommonJSImports ModuleName [Text] | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceType @@ -237,6 +239,8 @@ errorCode em = case unwrapErrorMessage em of InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" DeprecatedFFIDefaultCommonJSExport {} -> "DeprecatedFFIDefaultCommonJSExport" + UnsupportedFFICommonJSExports {} -> "UnsupportedFFICommonJSExports" + UnsupportedFFICommonJSImports {} -> "UnsupportedFFICommonJSImports" FileIOError{} -> "FileIOError" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" @@ -707,6 +711,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [ line $ "CommonJS exports named " <> markCode "default" <> " are not allowed." ] ] + renderSimpleErrorMessage (UnsupportedFFICommonJSExports mn idents) = + paras [ line $ "The following CommonJS exports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " + , indent . paras $ map line idents + ] + renderSimpleErrorMessage (UnsupportedFFICommonJSImports mn mids) = + paras [ line $ "The following CommonJS imports are no supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " + , indent . paras $ map line mids + ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 7a3b539196..5a08b1e4cc 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -324,20 +324,29 @@ checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parseModule jsStr path - (foreignModuleType, foreignIdentsStrs) <- case getForeignModuleExports js of - Left reason -> errorParsingModule reason - Right (Bundle.ForeignModuleExports{..}) - | null esExports -> do - let deprecatedFFI = filter (elem '\'') cjsExports - unless (null deprecatedFFI) $ - errorDeprecatedForeignPrimes deprecatedFFI - - when (elem "default" cjsExports) $ - errorDeprecatedFFIDefaultCJSExport - - pure (CJSModule, cjsExports) - | otherwise -> - pure (ESModule, esExports) + (foreignModuleType, foreignIdentsStrs) <- + case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of + Left reason -> errorParsingModule reason + Right (Bundle.ForeignModuleExports{..}, Bundle.ForeignModuleImports{..}) + | not (null cjsExports && null cjsImports) + , null esExports + , null esImports -> do + let deprecatedFFI = filter (elem '\'') cjsExports + unless (null deprecatedFFI) $ + errorDeprecatedForeignPrimes deprecatedFFI + + when (elem "default" cjsExports) $ + errorDeprecatedFFIDefaultCJSExport + + pure (CJSModule, cjsExports) + | otherwise -> do + unless (null cjsImports) $ + errorUnsupportedFFICommonJSImports cjsImports + + unless (null cjsExports) $ + errorUnsupportedFFICommonJSExports cjsExports + + pure (ESModule, esExports) foreignIdents <- either errorInvalidForeignIdentifiers @@ -366,6 +375,9 @@ checkForeignDecls m path = do getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleExports getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) + getForeignModuleImports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleImports + getForeignModuleImports = Bundle.getImportedModules (T.unpack (runModuleName mname)) + errorInvalidForeignIdentifiers :: [String] -> Make a errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) @@ -378,6 +390,14 @@ checkForeignDecls m path = do errorDeprecatedFFIDefaultCJSExport = throwError . errorMessage' modSS $ DeprecatedFFIDefaultCommonJSExport mname + errorUnsupportedFFICommonJSExports :: [String] -> Make a + errorUnsupportedFFICommonJSExports = + throwError . errorMessage' modSS . UnsupportedFFICommonJSExports mname . map T.pack + + errorUnsupportedFFICommonJSImports :: [String] -> Make a + errorUnsupportedFFICommonJSImports = + throwError . errorMessage' modSS . UnsupportedFFICommonJSImports mname . map T.pack + parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = case partitionEithers (map parseIdent strs) of diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.js b/tests/purs/failing/UnsupportedFFICommonJSExports1.js new file mode 100644 index 0000000000..a74e1904db --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.js @@ -0,0 +1,2 @@ +export var yes = true; +exports.no = false; diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.out b/tests/purs/failing/UnsupportedFFICommonJSExports1.out new file mode 100644 index 0000000000..d39cd8ad0b --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSExports1.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS exports are not supported in the ES foreign module for module Main: + + no + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSExports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.purs b/tests/purs/failing/UnsupportedFFICommonJSExports1.purs new file mode 100644 index 0000000000..fc64c41988 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSExports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.js b/tests/purs/failing/UnsupportedFFICommonJSExports2.js new file mode 100644 index 0000000000..10854c8a3b --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.js @@ -0,0 +1,4 @@ +import { yes, no } from "some ES module"; + +exports.yes = yes; +exports.no = no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.out b/tests/purs/failing/UnsupportedFFICommonJSExports2.out new file mode 100644 index 0000000000..d06dad5f4d --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSExports2.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS exports are not supported in the ES foreign module for module Main: + + yes + no + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSExports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.purs b/tests/purs/failing/UnsupportedFFICommonJSExports2.purs new file mode 100644 index 0000000000..fc64c41988 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSExports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.js b/tests/purs/failing/UnsupportedFFICommonJSImports1.js new file mode 100644 index 0000000000..c34d89c38c --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.js @@ -0,0 +1,4 @@ +var cjsImports = require("some CJS module"); + +export var yes = cjsImports.yes; +export var no = cjsImports.no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.out b/tests/purs/failing/UnsupportedFFICommonJSImports1.out new file mode 100644 index 0000000000..8cc5f980a4 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSImports1.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS imports are no supported in the ES foreign module for module Main: + + some CJS module + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSImports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.purs b/tests/purs/failing/UnsupportedFFICommonJSImports1.purs new file mode 100644 index 0000000000..85e64dc9f3 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSImports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.js b/tests/purs/failing/UnsupportedFFICommonJSImports2.js new file mode 100644 index 0000000000..7d4b8973b5 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.js @@ -0,0 +1,5 @@ +import { yes } from "some ES module"; +var cjsImports = require("some CJS module"); + +exports.yes = yes; +exports.no = cjsImports.no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.out b/tests/purs/failing/UnsupportedFFICommonJSImports2.out new file mode 100644 index 0000000000..9be6007f69 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSImports2.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS imports are no supported in the ES foreign module for module Main: + + some CJS module + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSImports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.purs b/tests/purs/failing/UnsupportedFFICommonJSImports2.purs new file mode 100644 index 0000000000..85e64dc9f3 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSImports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean From c56d3f5b7a72f07b20263505b02fc4b30accfd67 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 18:41:37 +0100 Subject: [PATCH 024/105] Deprecate CommonJS foreign modules --- src/Language/PureScript/Errors.hs | 7 +++++++ src/Language/PureScript/Make/Actions.hs | 1 + tests/purs/warning/DeprecatedFFICommonJSModule.js | 4 ++++ tests/purs/warning/DeprecatedFFICommonJSModule.out | 13 +++++++++++++ tests/purs/warning/DeprecatedFFICommonJSModule.purs | 5 +++++ 5 files changed, 30 insertions(+) create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.js create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.out create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 0749ae43dd..5bc35e635a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -65,6 +65,7 @@ data SimpleErrorMessage | UnusedFFIImplementations ModuleName [Ident] | InvalidFFIIdentifier ModuleName Text | DeprecatedFFIPrime ModuleName Text + | DeprecatedFFICommonJSModule ModuleName FilePath | DeprecatedFFIDefaultCommonJSExport ModuleName | UnsupportedFFICommonJSExports ModuleName [Text] | UnsupportedFFICommonJSImports ModuleName [Text] @@ -238,6 +239,7 @@ errorCode em = case unwrapErrorMessage em of UnusedFFIImplementations{} -> "UnusedFFIImplementations" InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" + DeprecatedFFICommonJSModule {} -> "DeprecatedFFICommonJSModule" DeprecatedFFIDefaultCommonJSExport {} -> "DeprecatedFFIDefaultCommonJSExport" UnsupportedFFICommonJSExports {} -> "UnsupportedFFICommonJSExports" UnsupportedFFICommonJSImports {} -> "UnsupportedFFICommonJSImports" @@ -705,6 +707,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line $ "Primes are not allowed in identifiers exported from FFI modules." ] ] + renderSimpleErrorMessage (DeprecatedFFICommonJSModule mn path) = + paras [ line $ "A CommonJS foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " + , indent . lineS $ path + , line $ "CommonJS foreign modules are deprecated and won't be supported in the future." + ] renderSimpleErrorMessage (DeprecatedFFIDefaultCommonJSExport mn) = paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" , indent . paras $ diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 5a08b1e4cc..a236f29dd1 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -257,6 +257,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = case foreignModuleType of ESModule -> copyFile path (outputFilename mn "foreign.js") CJSModule -> do + tell $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path copyFile path (outputFilename mn "foreign.cjs") writeESForeignModuleWrapper mn foreignIdents diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.js b/tests/purs/warning/DeprecatedFFICommonJSModule.js new file mode 100644 index 0000000000..45e5121ffc --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.js @@ -0,0 +1,4 @@ +"use strict"; + +exports.yes = true; +exports.no = true; diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.out b/tests/purs/warning/DeprecatedFFICommonJSModule.out new file mode 100644 index 0000000000..38fb74714a --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.out @@ -0,0 +1,13 @@ +Warning found: +at tests/purs/warning/DeprecatedFFICommonJSModule.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + A CommonJS foreign module implementation was provided for module Main: + + tests/purs/warning/DeprecatedFFICommonJSModule.js + + CommonJS foreign modules are deprecated and won't be supported in the future. + + +See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFICommonJSModule.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.purs b/tests/purs/warning/DeprecatedFFICommonJSModule.purs new file mode 100644 index 0000000000..b91bed426b --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith DeprecatedFFICommonJSModule +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean From 94af221cd9e05392d5ba3be502cbbf948f51bdac Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 20 Mar 2021 19:35:58 +0100 Subject: [PATCH 025/105] Convert CommonJS foreign modules in tests to ES modules --- tests/TestMake.hs | 4 ++-- tests/purs/bundle/3551/ModuleWithDeadCode.js | 6 ++---- tests/purs/bundle/3727.js | 6 ++---- tests/purs/bundle/ObjectShorthand.js | 10 ++++------ tests/purs/failing/MissingFFIImplementations.js | 2 +- tests/purs/passing/EffFn.js | 2 +- tests/purs/passing/FunWithFunDeps.js | 10 +++++----- tests/purs/passing/PolyLabels.js | 6 ++---- tests/purs/passing/ReExportsExported.js | 4 +--- tests/purs/passing/RowUnion.js | 4 +--- .../warning/DeprecatedConstraintInForeignImport.js | 2 +- tests/purs/warning/UnnecessaryFFIModule.js | 2 +- tests/purs/warning/UnusedFFIImplementations.js | 4 ++-- tests/support/pscide/src/RebuildSpecWithForeign.js | 2 +- 14 files changed, 26 insertions(+), 38 deletions(-) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index dadee27fd7..e73e95a35e 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -91,7 +91,7 @@ spec = do writeFileWithTimestamp modulePath timestampA moduleContent compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" compile [modulePath] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was removed" $ do @@ -101,7 +101,7 @@ spec = do moduleContent = "module Module where\nfoo = 0\n" writeFileWithTimestamp modulePath timestampA moduleContent - writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" compile [modulePath] `shouldReturn` moduleNames ["Module"] removeFile moduleFFIPath diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.js b/tests/purs/bundle/3551/ModuleWithDeadCode.js index ab7965286f..faa66d6178 100644 --- a/tests/purs/bundle/3551/ModuleWithDeadCode.js +++ b/tests/purs/bundle/3551/ModuleWithDeadCode.js @@ -1,10 +1,8 @@ -"use strict"; - -var fs = require('fs'); +import * as fs from 'fs'; var source = fs.readFileSync(__filename, 'utf-8'); -exports.results = { +export var results = { fooIsNotEliminated: /^ *var foo =/m.test(source), barIsExported: /^ *exports\["bar"\] =/m.test(source), barIsNotEliminated: /^ *var bar =/m.test(source), diff --git a/tests/purs/bundle/3727.js b/tests/purs/bundle/3727.js index 02e18d2982..d2148a0750 100644 --- a/tests/purs/bundle/3727.js +++ b/tests/purs/bundle/3727.js @@ -1,4 +1,2 @@ -'use strict'; - -exports.foo = 1; -exports.bar = exports.foo; +export var foo = 1; +export { foo as bar }; diff --git a/tests/purs/bundle/ObjectShorthand.js b/tests/purs/bundle/ObjectShorthand.js index 156ff0c9da..225e8bf063 100644 --- a/tests/purs/bundle/ObjectShorthand.js +++ b/tests/purs/bundle/ObjectShorthand.js @@ -1,15 +1,13 @@ -"use strict"; - var foo = 1; -exports.bar = { foo }; +export var bar = { foo }; var baz = 2; -exports.quux = function(baz) { +export var quux = function(baz) { return { baz }; }; -var fs = require('fs'); +import * as fs from 'fs'; var source = fs.readFileSync(__filename, 'utf-8'); -exports.bazIsEliminated = !/^ *var baz =/m.test(source); +export var bazIsEliminated = !/^ *var baz =/m.test(source); diff --git a/tests/purs/failing/MissingFFIImplementations.js b/tests/purs/failing/MissingFFIImplementations.js index d29ee4cff9..ccb7243f7e 100644 --- a/tests/purs/failing/MissingFFIImplementations.js +++ b/tests/purs/failing/MissingFFIImplementations.js @@ -1 +1 @@ -exports.yes = true; +export var yes = true; diff --git a/tests/purs/passing/EffFn.js b/tests/purs/passing/EffFn.js index b645b0527e..8360cbe7cd 100644 --- a/tests/purs/passing/EffFn.js +++ b/tests/purs/passing/EffFn.js @@ -1 +1 @@ -exports.add3 = function (a,b,c) { return a + b + c; }; \ No newline at end of file +export var add3 = function (a,b,c) { return a + b + c; }; diff --git a/tests/purs/passing/FunWithFunDeps.js b/tests/purs/passing/FunWithFunDeps.js index dea73d18fe..171f389176 100644 --- a/tests/purs/passing/FunWithFunDeps.js +++ b/tests/purs/passing/FunWithFunDeps.js @@ -1,15 +1,15 @@ //: forall e. FVect Z e -exports.fnil = []; +export var fnil = []; //: forall n e. e -> FVect n e -> FVect (S n) e -exports.fcons = function (hd) { +export var fcons = function (hd) { return function (tl) { return [hd].concat(tl); }; }; -exports.fappend = function (dict) { +export var fappend = function (dict) { return function (left) { return function (right) { return left.concat(right); @@ -17,7 +17,7 @@ exports.fappend = function (dict) { }; }; -exports.fflatten = function (dict) { +export var fflatten = function (dict) { return function (v) { var accRef = []; for (var indexRef = 0; indexRef < v.length; indexRef += 1) { @@ -27,6 +27,6 @@ exports.fflatten = function (dict) { }; }; -exports.ftoArray = function (vect) { +export var ftoArray = function (vect) { return vect; }; diff --git a/tests/purs/passing/PolyLabels.js b/tests/purs/passing/PolyLabels.js index b9900e4d3b..115375cd48 100644 --- a/tests/purs/passing/PolyLabels.js +++ b/tests/purs/passing/PolyLabels.js @@ -1,12 +1,10 @@ -"use strict"; - -exports.unsafeGet = function (s) { +export var unsafeGet = function (s) { return function (o) { return o[s]; }; }; -exports.unsafeSet = function(s) { +export var unsafeSet = function (s) { return function(a) { return function (o) { var o1 = {}; diff --git a/tests/purs/passing/ReExportsExported.js b/tests/purs/passing/ReExportsExported.js index b73154be1e..5ca086e78a 100644 --- a/tests/purs/passing/ReExportsExported.js +++ b/tests/purs/passing/ReExportsExported.js @@ -1,4 +1,2 @@ -"use strict"; - // Import `A.a` which was re-exported from `B` and then again from `C` -exports.a = require('../C').a; +export { a } from '../C/index.js'; diff --git a/tests/purs/passing/RowUnion.js b/tests/purs/passing/RowUnion.js index c002b18f57..4f037587a2 100644 --- a/tests/purs/passing/RowUnion.js +++ b/tests/purs/passing/RowUnion.js @@ -1,6 +1,4 @@ -"use strict"; - -exports.merge = function (dict) { +export var merge = function (dict) { return function (l) { return function (r) { var o = {}; diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.js b/tests/purs/warning/DeprecatedConstraintInForeignImport.js index 3be8843e1f..8e629a2a03 100644 --- a/tests/purs/warning/DeprecatedConstraintInForeignImport.js +++ b/tests/purs/warning/DeprecatedConstraintInForeignImport.js @@ -1,4 +1,4 @@ -exports.show = function (showDict) { +export var show = function (showDict) { return function (a) { return showDict.show(a); }; diff --git a/tests/purs/warning/UnnecessaryFFIModule.js b/tests/purs/warning/UnnecessaryFFIModule.js index 346c8e9012..bd1835d69d 100644 --- a/tests/purs/warning/UnnecessaryFFIModule.js +++ b/tests/purs/warning/UnnecessaryFFIModule.js @@ -1 +1 @@ -exports.out = null; +export var out = null; diff --git a/tests/purs/warning/UnusedFFIImplementations.js b/tests/purs/warning/UnusedFFIImplementations.js index d50f2e60a8..78ab638547 100644 --- a/tests/purs/warning/UnusedFFIImplementations.js +++ b/tests/purs/warning/UnusedFFIImplementations.js @@ -1,2 +1,2 @@ -exports.yes = true; -exports.no = false; +export var yes = true; +export var no = false; diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.js b/tests/support/pscide/src/RebuildSpecWithForeign.js index 8ea453ff71..577e8a5d5d 100644 --- a/tests/support/pscide/src/RebuildSpecWithForeign.js +++ b/tests/support/pscide/src/RebuildSpecWithForeign.js @@ -1 +1 @@ -exports.f = 5; +export var f = 5; From 15ebf0ddb1c2a856ed33372b101357a0b34dff09 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sun, 21 Mar 2021 14:22:36 +0100 Subject: [PATCH 026/105] Don't optimize away dependencies of named ES exports of declarations --- src/Language/PureScript/Bundle.hs | 36 +++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 996464542d..ca074c645a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -226,7 +226,7 @@ printErrorMessage UnsupportedImport = printErrorMessage UnsupportedExport = [ "An export was unsupported." , "Declarations can be exported as ES named exports:" - , " export decl" + , " export var decl" , "Existing identifiers can be exported as well:" , " export { name }" , "They can also be renamed on export:" @@ -458,10 +458,12 @@ toModule mids mid filename top = pure . ExportsList <$> exportSpecifiersList Nothing jsExportSpecifiers toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) | JSExport jsStatement _ <- jsExportDeclaration - = traverse (toExport' Nothing) (exportStatementIdentifiers jsStatement) >>= \exports -> - pure [ Other jsStatement - , ExportsList exports - ] + , Just (visibility, name, decl) <- matchInternalMember jsStatement + = pure [ Member jsStatement visibility name decl [] + , ExportsList [toRegularExport' name] + ] + toModuleElements (JSModuleExportDeclaration _ JSExport{}) + = err UnsupportedExport toModuleElements item@(JSModuleStatementListItem jsStatement) | Just (importName, importPath) <- matchRequire jsStatement @@ -518,10 +520,15 @@ toModule mids mid filename top (stringLiteral name) JSNoAnnot) | otherwise = err UnsupportedExport toExport Nothing name as = - pure (RegularExport name, as, JSIdentifier sp name, []) + pure $ toRegularExport name as toExport' from name = toExport from name name + toRegularExport name as = + (RegularExport name, as, JSIdentifier sp name, []) + + toRegularExport' name = toRegularExport name name + data ForeignModuleExports = ForeignModuleExports { cjsExports :: [String] @@ -633,16 +640,23 @@ matchRequire stmt -- Matches JS member declarations. matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt + | Just (visibility, name, decl) <- matchInternalMember stmt + = pure (visibility, name, decl) + -- exports.foo = expr; exports["foo"] = expr; + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , Just name <- exportsAccessor e + = Just (Public, name, decl) + | otherwise + = Nothing + +matchInternalMember :: JSStatement -> Maybe (Visibility, String, JSExpression) +matchInternalMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- fromCommaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit - = Just (Internal, name, decl) - -- exports.foo = expr; exports["foo"] = expr; - | JSAssignStatement e (JSAssign _) decl _ <- stmt - , Just name <- exportsAccessor e - = Just (Public, name, decl) + = pure (Internal, name, decl) | otherwise = Nothing From 8f19b7e8dfa745b1b19b8ebd1c583c051ddfbfd4 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 3 Apr 2021 16:38:01 +0200 Subject: [PATCH 027/105] fixup! Import CommonJS foreign modules through an ES module wrapper --- purescript.cabal | 2 - src/Language/JavaScript/AST/JSCommaList.hs | 19 --------- src/Language/PureScript/Bundle.hs | 49 +++++++++++++++------- src/Language/PureScript/Make/Actions.hs | 29 ++++++------- 4 files changed, 49 insertions(+), 50 deletions(-) delete mode 100644 src/Language/JavaScript/AST/JSCommaList.hs diff --git a/purescript.cabal b/purescript.cabal index 6c8be98e3c..ded50103e1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -121,7 +121,6 @@ common defaults array >=0.5.3.0 && <0.6, base >=4.12.0.0 && <4.13, base-compat >=0.10.5 && <0.11, - blaze-builder >=0.2 && <0.5, blaze-html >=0.9.1.1 && <0.10, bower-json >=1.0.0.1 && <1.1, boxes >=0.1.5 && <0.2, @@ -184,7 +183,6 @@ library hs-source-dirs: src exposed-modules: Control.Monad.Logger - Language.JavaScript.AST.JSCommaList Language.PureScript Language.PureScript.Bundle Language.PureScript.CodeGen diff --git a/src/Language/JavaScript/AST/JSCommaList.hs b/src/Language/JavaScript/AST/JSCommaList.hs deleted file mode 100644 index df7c982f14..0000000000 --- a/src/Language/JavaScript/AST/JSCommaList.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Language.JavaScript.AST.JSCommaList where - -import Prelude -import Language.JavaScript.Parser.AST (JSCommaList(JSLNil, JSLOne, JSLCons), JSAnnot(JSNoAnnot)) - -fromCommaList :: JSCommaList a -> [a] -fromCommaList JSLNil = [] -fromCommaList (JSLOne x) = [x] -fromCommaList (JSLCons l _ x) = fromCommaList l ++ [x] - --- comma lists are reverse-consed -toCommaList :: [a] -> JSCommaList a -toCommaList [] = JSLNil -toCommaList [x] = JSLOne x -toCommaList l = go $ reverse l - where - go [x] = JSLOne x - go (h:t)= JSLCons (go t) JSNoAnnot h - go [] = error "Invalid case in comma-list" diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index ca074c645a..0fdcbb436b 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -42,7 +42,6 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Language.JavaScript.AST.JSCommaList (fromCommaList, toCommaList) import Language.JavaScript.Parser import Language.JavaScript.Parser.AST import Language.JavaScript.Process.Minify @@ -341,7 +340,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) in (map (\name -> (m, name, Internal)) shorthandNames, bn) toReference (JSFunctionExpression _ _ _ params _ _) bn - = ([], bn \\ (mapMaybe unIdentifier $ fromCommaList params)) + = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) toReference e bn | Just nm <- exportsAccessor e -- exports.foo means there's a dependency on the public member "foo" of @@ -388,9 +387,14 @@ strValue str = go $ drop 1 str go (x : xs) = x : go xs go "" = "" +commaList :: JSCommaList a -> [a] +commaList JSLNil = [] +commaList (JSLOne x) = [x] +commaList (JSLCons l _ x) = commaList l ++ [x] + trailingCommaList :: JSCommaTrailingList a -> [a] -trailingCommaList (JSCTLComma l _) = fromCommaList l -trailingCommaList (JSCTLNone l) = fromCommaList l +trailingCommaList (JSCTLComma l _) = commaList l +trailingCommaList (JSCTLNone l) = commaList l identName :: JSIdent -> Maybe String identName (JSIdentName _ ident) = Just ident @@ -412,7 +416,7 @@ exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = exportStatementIdentifiers _ = [] varNames :: JSCommaList JSExpression -> [String] -varNames = mapMaybe varName . fromCommaList +varNames = mapMaybe varName . commaList where varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident varName _ = Nothing @@ -429,6 +433,12 @@ stringLiteral s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" -- Other constructor. toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module toModule mids mid filename top + | JSAstModule jsModuleItems _ <- top + , JSModuleImportDeclaration _ jsImportDeclaration : _ <- jsModuleItems + , JSImportDeclaration JSImportClauseDefault{} jsFromClause _ <- jsImportDeclaration + , JSFromClause _ _ importPath <- jsFromClause + , "./foreign.cjs" <- strValue importPath + = pure $ Module mid filename [] | JSAstModule jsModuleItems _ <- top = Module mid filename . mconcat <$> traverse toModuleElements jsModuleItems | otherwise = err InvalidTopLevel where @@ -499,9 +509,8 @@ toModule mids mid filename top toModuleElements (JSModuleStatementListItem other) = pure [Other other] - exportSpecifiersList (Just "./foreign.cjs") = const $ pure [] exportSpecifiersList from = - fmap catMaybes . traverse (exportSpecifier from) . fromCommaList + fmap catMaybes . traverse (exportSpecifier from) . commaList exportSpecifier from (JSExportSpecifier jsIdent) = traverse (toExport' from) $ identName jsIdent @@ -583,7 +592,7 @@ getExportedIdentifiers mname top exportStatementIdentifiers jsStatement exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) = - mapMaybe exportSpecifierName $ fromCommaList jsExportsSpecifiers + mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs @@ -627,12 +636,12 @@ getImportedModules mname top matchRequire :: JSStatement -> Maybe (String, String) matchRequire stmt | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- fromCommaList jsInit + , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ importName <- var , JSVarInit _ jsInitEx <- varInit , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req - , [ Just importPath ] <- map fromStringLiteral (fromCommaList argsE) + , [ Just importPath ] <- map fromStringLiteral (commaList argsE) = Just (importName, importPath) | otherwise = Nothing @@ -653,7 +662,7 @@ matchInternalMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchInternalMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- fromCommaList jsInit + , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit = pure (Internal, name, decl) @@ -872,7 +881,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o declToJS (Import _ nm req) = withLength [ JSVariable lfsp - (toCommaList [ + (cList [ JSVarInitExpression (JSIdentifier sp nm) (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) @@ -890,6 +899,16 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o val (JSSemi JSNoAnnot) + -- comma lists are reverse-consed + cList :: [a] -> JSCommaList a + cList [] = JSLNil + cList [x] = JSLOne x + cList l = go $ reverse l + where + go [x] = JSLOne x + go (h:t)= JSLCons (go t) JSNoAnnot h + go [] = error "Invalid case in comma-list" + indent :: [JSStatement] -> [JSStatement] indent = everywhere (mkT squash) where @@ -906,7 +925,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o prelude :: JSStatement prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version , WhiteSpace tokenPosnEmpty "\n" ]) - (toCommaList [ + (cList [ JSVarInitExpression (JSIdentifier sp optionsNamespace) (JSVarInit sp (emptyObj sp)) ]) (JSSemi JSNoAnnot) @@ -914,7 +933,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o require :: String -> JSExpression require mn = JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot - (toCommaList [ stringLiteral mn ]) JSNoAnnot + (cList [ stringLiteral mn ]) JSNoAnnot moduleReference :: JSAnnot -> String -> JSExpression moduleReference a mn = @@ -983,7 +1002,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o [JSMethodCall (JSMemberDot (moduleReference lf mn) JSNoAnnot (JSIdentifier JSNoAnnot "main")) - JSNoAnnot (toCommaList []) JSNoAnnot (JSSemi JSNoAnnot)] + JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)] lf :: JSAnnot lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index a236f29dd1..0205c4b3a1 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -11,7 +11,7 @@ module Language.PureScript.Make.Actions import Prelude -import Blaze.ByteString.Builder (toByteString) +import Control.Arrow ((&&&)) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -32,11 +32,8 @@ import qualified Data.Text.IO as TIO import qualified Data.Text.Encoding as TE import Data.Time.Clock (UTCTime) import Data.Version (showVersion) -import qualified Language.JavaScript.AST.JSCommaList as JSAST (toCommaList) import qualified Language.JavaScript.Parser as JS import Language.PureScript.AST -import qualified Language.JavaScript.Parser.AST as JSAST -import Language.JavaScript.Pretty.Printer (renderJS) import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer @@ -266,16 +263,20 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeESForeignModuleWrapper :: ModuleName -> S.Set Ident -> Make () writeESForeignModuleWrapper mn idents = - writeTextFile (outputFilename mn "foreign.js") . toByteString . renderJS $ - JSAST.JSAstModule - [ JSAST.JSModuleExportDeclaration JSAST.JSNoAnnot - (JSAST.JSExportFrom - (JSAST.JSExportClause JSAST.JSAnnotSpace - (JSAST.toCommaList $ JSAST.JSExportSpecifier . JSAST.JSIdentName JSAST.JSAnnotSpace . T.unpack . runIdent <$> S.toList idents) - JSAST.JSAnnotSpace) - (JSAST.JSFromClause JSAST.JSAnnotSpace JSAST.JSAnnotSpace "\"./foreign.cjs\"") - (JSAST.JSSemi JSAST.JSNoAnnot)) - ] JSAST.JSNoAnnot + writeTextFile (outputFilename mn "foreign.js") wrapper + where + xs = (J.identToJs &&& runIdent) <$> S.toList idents + wrapper = TE.encodeUtf8 . T.intercalate "\n" $ + "import $foreign from \"./foreign.cjs\";" : + fmap (uncurry toLocalDeclaration) xs ++ + [ "export { " <> T.intercalate ", " (uncurry toNamedExport <$> xs) <> " };" + , "" + ] + toLocalDeclaration local exported = + "var " <> local <> " = $foreign." <> exported <> ";" + toNamedExport local exported + | local == exported = local + | otherwise = local <> " as " <> exported genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do From 7727c986e29820954be0fb8d3d139186dd9993d8 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 3 Apr 2021 16:39:50 +0200 Subject: [PATCH 028/105] fixup! Don't optimize away dependencies of named ES exports of declarations --- src/Language/PureScript/Bundle.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 0fdcbb436b..aceb289d88 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -468,8 +468,8 @@ toModule mids mid filename top = pure . ExportsList <$> exportSpecifiersList Nothing jsExportSpecifiers toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) | JSExport jsStatement _ <- jsExportDeclaration - , Just (visibility, name, decl) <- matchInternalMember jsStatement - = pure [ Member jsStatement visibility name decl [] + , Just (name, decl) <- matchInternalMember jsStatement + = pure [ Member jsStatement Internal name decl [] , ExportsList [toRegularExport' name] ] toModuleElements (JSModuleExportDeclaration _ JSExport{}) @@ -649,8 +649,8 @@ matchRequire stmt -- Matches JS member declarations. matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt - | Just (visibility, name, decl) <- matchInternalMember stmt - = pure (visibility, name, decl) + | Just (name, decl) <- matchInternalMember stmt + = pure (Internal, name, decl) -- exports.foo = expr; exports["foo"] = expr; | JSAssignStatement e (JSAssign _) decl _ <- stmt , Just name <- exportsAccessor e @@ -658,14 +658,14 @@ matchMember stmt | otherwise = Nothing -matchInternalMember :: JSStatement -> Maybe (Visibility, String, JSExpression) +matchInternalMember :: JSStatement -> Maybe (String, JSExpression) matchInternalMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit - = pure (Internal, name, decl) + = pure (name, decl) | otherwise = Nothing From bd456029e95fcd6027d6942611c7d4dac15214d5 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Mon, 21 Jun 2021 20:25:28 +0200 Subject: [PATCH 029/105] Revert "Disallow CommonJS exports named `default`" This reverts commit 4976eee1599300511236b9a491b09ecb332cf852. --- src/Language/PureScript/Errors.hs | 8 -------- src/Language/PureScript/Make/Actions.hs | 7 ------- .../failing/DeprecatedFFIDefaultCommonJSExport.js | 1 - .../failing/DeprecatedFFIDefaultCommonJSExport.out | 12 ------------ .../failing/DeprecatedFFIDefaultCommonJSExport.purs | 4 ---- 5 files changed, 32 deletions(-) delete mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js delete mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out delete mode 100644 tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5bc35e635a..35e3558289 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -66,7 +66,6 @@ data SimpleErrorMessage | InvalidFFIIdentifier ModuleName Text | DeprecatedFFIPrime ModuleName Text | DeprecatedFFICommonJSModule ModuleName FilePath - | DeprecatedFFIDefaultCommonJSExport ModuleName | UnsupportedFFICommonJSExports ModuleName [Text] | UnsupportedFFICommonJSImports ModuleName [Text] | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred @@ -240,7 +239,6 @@ errorCode em = case unwrapErrorMessage em of InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" DeprecatedFFICommonJSModule {} -> "DeprecatedFFICommonJSModule" - DeprecatedFFIDefaultCommonJSExport {} -> "DeprecatedFFIDefaultCommonJSExport" UnsupportedFFICommonJSExports {} -> "UnsupportedFFICommonJSExports" UnsupportedFFICommonJSImports {} -> "UnsupportedFFICommonJSImports" FileIOError{} -> "FileIOError" @@ -712,12 +710,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent . lineS $ path , line $ "CommonJS foreign modules are deprecated and won't be supported in the future." ] - renderSimpleErrorMessage (DeprecatedFFIDefaultCommonJSExport mn) = - paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" - , indent . paras $ - [ line $ "CommonJS exports named " <> markCode "default" <> " are not allowed." - ] - ] renderSimpleErrorMessage (UnsupportedFFICommonJSExports mn idents) = paras [ line $ "The following CommonJS exports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " , indent . paras $ map line idents diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 0205c4b3a1..f7d826c017 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -337,9 +337,6 @@ checkForeignDecls m path = do unless (null deprecatedFFI) $ errorDeprecatedForeignPrimes deprecatedFFI - when (elem "default" cjsExports) $ - errorDeprecatedFFIDefaultCJSExport - pure (CJSModule, cjsExports) | otherwise -> do unless (null cjsImports) $ @@ -388,10 +385,6 @@ checkForeignDecls m path = do errorDeprecatedForeignPrimes = throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) - errorDeprecatedFFIDefaultCJSExport :: Make a - errorDeprecatedFFIDefaultCJSExport = - throwError . errorMessage' modSS $ DeprecatedFFIDefaultCommonJSExport mname - errorUnsupportedFFICommonJSExports :: [String] -> Make a errorUnsupportedFFICommonJSExports = throwError . errorMessage' modSS . UnsupportedFFICommonJSExports mname . map T.pack diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js deleted file mode 100644 index 8f35a10f24..0000000000 --- a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.js +++ /dev/null @@ -1 +0,0 @@ -exports.default = undefined; diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out deleted file mode 100644 index 943c7dc313..0000000000 --- a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.out +++ /dev/null @@ -1,12 +0,0 @@ -Error found: -at tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs:2:1 - 4:38 (line 2, column 1 - line 4, column 38) - - In the FFI module for Main: - - CommonJS exports named default are not allowed. - - - -See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIDefaultCommonJSExport.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs b/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs deleted file mode 100644 index ef70f75ac8..0000000000 --- a/tests/purs/failing/DeprecatedFFIDefaultCommonJSExport.purs +++ /dev/null @@ -1,4 +0,0 @@ --- @shouldFailWith DeprecatedFFIDefaultCommonJSExport -module Main where - -foreign import default :: forall a. a From ca94c4bb8b9aa36f246c6b2835dec252ddeef178 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Mon, 21 Jun 2021 21:17:14 +0200 Subject: [PATCH 030/105] Add tests for foreign CommonJS exports named default --- tests/purs/passing/FFIDefaultCJSExport.js | 1 + tests/purs/passing/FFIDefaultCJSExport.purs | 7 +++++++ 2 files changed, 8 insertions(+) create mode 100644 tests/purs/passing/FFIDefaultCJSExport.js create mode 100644 tests/purs/passing/FFIDefaultCJSExport.purs diff --git a/tests/purs/passing/FFIDefaultCJSExport.js b/tests/purs/passing/FFIDefaultCJSExport.js new file mode 100644 index 0000000000..873a59a12b --- /dev/null +++ b/tests/purs/passing/FFIDefaultCJSExport.js @@ -0,0 +1 @@ +exports.default = "Done"; diff --git a/tests/purs/passing/FFIDefaultCJSExport.purs b/tests/purs/passing/FFIDefaultCJSExport.purs new file mode 100644 index 0000000000..1d084b6d8d --- /dev/null +++ b/tests/purs/passing/FFIDefaultCJSExport.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +foreign import default :: String + +main = log default From ec4dce59153a8d48ea7100d4550fed1576cbf10a Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Fri, 2 Jul 2021 19:15:47 +0200 Subject: [PATCH 031/105] Extend support to Node.js v12.0.0 with --experimental-modules --- .travis.yml | 2 +- app/Command/REPL.hs | 10 ++--- src/Language/PureScript/Interactive/IO.hs | 45 ++++++++++++++++++++--- tests/TestBundle.hs | 13 +++---- tests/TestCompiler.hs | 11 +++--- tests/TestPsci/TestEnv.hs | 10 ++--- tests/TestUtils.hs | 16 +++----- 7 files changed, 65 insertions(+), 42 deletions(-) diff --git a/.travis.yml b/.travis.yml index bc82733e74..66e0280110 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ language: node_js node_js: - - "14" + - "12" branches: # Only build master and tagged versions, i.e. not feature branches; feature # branches already get built after opening a pull request. diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 9597a9538e..8a37df57c8 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -52,7 +52,6 @@ import System.Exit import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) import qualified System.FilePath.Glob as Glob -import System.Process (readProcessWithExitCode) import qualified Data.ByteString.Lazy.UTF8 as U -- | Command line options @@ -288,12 +287,11 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown eval :: () -> String -> IO () eval _ _ = do writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" - process <- maybe findNodeProcess (pure . pure) nodePath - result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process + result <- readNodeProcessWithExitCode nodePath (nodeArgs ++ [indexFile]) "" case result of - Just (ExitSuccess, out, _) -> putStrLn out - Just (ExitFailure _, _, err) -> putStrLn err - Nothing -> putStrLn "Could not find node.js. Do you have node.js installed and available in your PATH?" + Right (ExitSuccess, out, _) -> putStrLn out + Right (ExitFailure _, _, err) -> putStrLn err + Left err -> putStrLn err reload :: () -> IO () reload _ = return () diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index 92a2e8dc64..3eab68f020 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -1,13 +1,23 @@ -module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where +{-# LANGUAGE TypeApplications #-} + +module Language.PureScript.Interactive.IO (findNodeProcess, readNodeProcessWithExitCode, getHistoryFilename) where import Prelude.Compat -import Control.Monad (msum) +import Control.Monad (msum, void) +import Control.Monad.Error.Class (throwError) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Functor ((<&>)) import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getAppUserDataDirectory, getXdgDirectory, findExecutable, doesFileExist) +import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import System.FilePath (takeDirectory, ()) +import System.Process (readProcessWithExitCode) +import Text.Parsec ((), many1, parse, sepBy) +import Text.Parsec.Char (char, digit) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -21,9 +31,34 @@ onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVar -- Locates the node executable. -- Checks for either @nodejs@ or @node@. -- -findNodeProcess :: IO (Maybe String) -findNodeProcess = onFirstFileMatching findExecutable names - where names = ["nodejs", "node"] +findNodeProcess :: IO (Either String String) +findNodeProcess = onFirstFileMatching findExecutable ["nodejs", "node"] <&> + maybe (throwError "Could not find node.js. Do you have node.js installed and available in your PATH?") pure + +findNodeVersion :: String -> IO (Maybe String) +findNodeVersion node = do + result <- readProcessWithExitCode node ["--version"] "" + return $ case result of + (ExitSuccess, version, _) -> Just version + (ExitFailure _, _, _) -> Nothing + +readNodeProcessWithExitCode :: Maybe FilePath -> [String] -> String -> IO (Either String (ExitCode, String, String)) +readNodeProcessWithExitCode nodePath nodeArgs stdin = runExceptT $ do + process <- maybe (ExceptT findNodeProcess) pure nodePath + (_, minor, _) <- lift (findNodeVersion process) >>= \case + Nothing -> throwError "Could not find node.js version." + Just version -> do + let semver = do + void $ char 'v' + major : minor : patch : _ <- fmap (read @Int) (many1 digit) `sepBy` void (char '.') + pure (major, minor, patch) + case parse (semver "Could not parse node.js version.") "" version of + Left err -> throwError $ show err + Right (major, minor, patch) + | major < 12 -> throwError "Unsupported node.js version." + | otherwise -> pure (major, minor, patch) + let nodeArgs' = if minor < 7 then "--experimental-modules" : nodeArgs else nodeArgs + lift $ readProcessWithExitCode process nodeArgs' stdin -- | -- Grabs the filename where the history is stored. diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index 31b8452aee..736cb3d008 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -10,7 +10,8 @@ import Prelude () import Prelude.Compat import qualified Language.PureScript as P -import Language.PureScript.Bundle +import Language.PureScript.Bundle +import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) import Data.Function (on) import Data.List (minimumBy) @@ -22,7 +23,6 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import System.Exit -import System.Process import System.FilePath import System.IO import System.IO.UTF8 @@ -65,7 +65,6 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do - process <- findNodeProcess jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir let entryPoint = modulesDir "index.cjs" let entryModule = map (`ModuleIdentifier` Regular) ["Main"] @@ -78,17 +77,17 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil case bundled of Right (_, js) -> do writeUTF8File entryPoint js - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + result <- readNodeProcessWithExitCode Nothing [entryPoint] "" hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of - Just (ExitSuccess, out, err) + Right (ExitSuccess, out, err) | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err | not (null out) && trim (last (lines out)) == "Done" -> do hPutStr outputFile out return Nothing | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> return $ Just err - Nothing -> return $ Just "Couldn't find node.js executable" + Right (ExitFailure _, _, err) -> return $ Just err + Left err -> return $ Just err Left err -> return . Just $ "Coud not bundle: " ++ show err logfile :: FilePath diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 5a0a09ae5a..18f43d12a1 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -29,6 +29,7 @@ import Prelude () import Prelude.Compat import qualified Language.PureScript as P +import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) import Control.Arrow ((>>>)) import Data.Function (on) @@ -44,7 +45,6 @@ import qualified Data.ByteString.Lazy as BS import Control.Monad import System.Exit -import System.Process import System.FilePath import System.IO import System.IO.UTF8 (readUTF8File) @@ -164,20 +164,19 @@ assertCompiles supportModules supportExterns supportForeigns inputFiles outputFi case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do - process <- findNodeProcess let entryPoint = modulesDir "index.js" writeFile entryPoint "import('./Main/index.js').then(({ main }) => main());" - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + result <- readNodeProcessWithExitCode Nothing [entryPoint] "" hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of - Just (ExitSuccess, out, err) + Right (ExitSuccess, out, err) | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err | not (null out) && trim (last (lines out)) == "Done" -> do hPutStr outputFile out return Nothing | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> return $ Just err - Nothing -> return $ Just "Couldn't find node.js executable" + Right (ExitFailure _, _, err) -> return $ Just err + Left err -> return $ Just err assertCompilesWithWarnings :: [P.Module] diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 7a9c0c6d12..c8f1de431b 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -19,7 +19,6 @@ import System.Directory (getCurrentDirectory, doesPathExist, removeFil import System.Exit import System.FilePath ((), pathSeparator) import qualified System.FilePath.Glob as Glob -import System.Process (readProcessWithExitCode) import Test.Hspec (shouldBe, Expectation) -- | A monad transformer for handle PSCi actions in tests @@ -58,12 +57,11 @@ execTestPSCi i = do jsEval :: TestPSCi String jsEval = liftIO $ do writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" - process <- findNodeProcess - result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process + result <- readNodeProcessWithExitCode Nothing [indexFile] "" case result of - Just (ExitSuccess, out, _) -> return out - Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure - Nothing -> putStrLn "Couldn't find node.js" >> exitFailure + Right (ExitSuccess, out, _) -> return out + Right (ExitFailure _, _, err) -> putStrLn err >> exitFailure + Left err -> putStrLn err >> exitFailure -- | Run a PSCi command and evaluate its outputs: -- * jsOutputEval is used to evaluate compiled JS output by PSCi diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 6b086fcacd..140e5a570e 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -9,12 +9,12 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST +import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe import Control.Monad.Writer.Class (tell) import Control.Exception import Data.Char (isSpace) @@ -34,12 +34,6 @@ import qualified System.FilePath.Glob as Glob import System.IO import Test.Tasty.Hspec - -findNodeProcess :: IO (Maybe String) -findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names - where - names = ["nodejs", "node"] - -- | -- Fetches code necessary to run the tests with. The resulting support code -- should then be checked in, so that npm/bower etc is not required to run the @@ -56,15 +50,15 @@ updateSupportCode = do else do callProcess "npm" ["install"] -- bower uses shebang "/usr/bin/env node", but we might have nodejs - node <- maybe cannotFindNode pure =<< findNodeProcess + node <- either cannotFindNode pure =<< findNodeProcess -- Sometimes we run as a root (e.g. in simple docker containers) -- And we are non-interactive: https://github.com/bower/bower/issues/1162 callProcess node ["node_modules/.bin/bower", "--allow-root", "install", "--config.interactive=false"] setCurrentDirectory "../.." where - cannotFindNode :: IO a - cannotFindNode = do - hPutStrLn stderr "Cannot find node (or nodejs) executable" + cannotFindNode :: String -> IO a + cannotFindNode message = do + hPutStrLn stderr message exitFailure readInput :: [FilePath] -> IO [(FilePath, T.Text)] From 0d6f928dc8c16f4ec6a36155a9c079d53c453e14 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Fri, 2 Jul 2021 19:09:57 +0200 Subject: [PATCH 032/105] Filter out Node.js experimental ES modules loader warning --- src/Language/PureScript/Interactive/IO.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index 3eab68f020..f1d61cb47a 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -10,6 +10,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Functor ((<&>)) +import Data.List (isInfixOf) import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getAppUserDataDirectory, getXdgDirectory, findExecutable, doesFileExist) @@ -58,7 +59,15 @@ readNodeProcessWithExitCode nodePath nodeArgs stdin = runExceptT $ do | major < 12 -> throwError "Unsupported node.js version." | otherwise -> pure (major, minor, patch) let nodeArgs' = if minor < 7 then "--experimental-modules" : nodeArgs else nodeArgs - lift $ readProcessWithExitCode process nodeArgs' stdin + lift (readProcessWithExitCode process nodeArgs' stdin) <&> \case + (ExitSuccess, out, err) -> + (ExitSuccess, out, censorExperimentalWarnings err) + (ExitFailure code, out, err) -> + (ExitFailure code, out, err) + +censorExperimentalWarnings :: String -> String +censorExperimentalWarnings = + unlines . filter (not . ("ExperimentalWarning" `isInfixOf`)) . lines -- | -- Grabs the filename where the history is stored. From 8e1caf89786be2771f5f160ef4b7a0d318ab7308 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Fri, 2 Jul 2021 22:24:52 +0200 Subject: [PATCH 033/105] Update bundler error messages --- src/Language/PureScript/Bundle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index aceb289d88..73ca90f55a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -242,10 +242,10 @@ printErrorMessage (ErrorInModule mid e) = displayIdentifier (ModuleIdentifier name ty) = name ++ " (" ++ showModuleType ty ++ ")" printErrorMessage (MissingEntryPoint mName) = - [ "Couldn't find neither an ES nor CommonJS module for the specified entry point: " ++ mName + [ "Could not find an ES module or CommonJS module for the specified entry point: " ++ mName ] printErrorMessage (MissingMainModule mName) = - [ "Couldn't find neither an ES nor CommonJS module for the specified main module: " ++ mName + [ "Could not find an ES module or CommonJS module for the specified main module: " ++ mName ] -- | Calculate the ModuleIdentifier imported by an import declaration or a require(...) statement. From d5437e01fce02c8932d62f86efcaca9c46cbc2e9 Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Sat, 3 Jul 2021 17:00:41 +0200 Subject: [PATCH 034/105] Fix HLint warnings --- src/Language/PureScript/Bundle.hs | 10 +++++----- src/Language/PureScript/CodeGen/JS.hs | 4 ++-- src/Language/PureScript/Errors.hs | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 8f88b8416a..951f06859a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -452,7 +452,7 @@ toModule mids mid filename top , JSImportNameSpace _ _ jsIdent <- jsImportNameSpace , JSFromClause _ _ importPath <- jsFromClause , importPath' <- checkImportPath (strValue importPath) mid mids - = fromMaybe (err UnsupportedImport) (pure <$> identName jsIdent) >>= \name -> + = maybe (err UnsupportedImport) pure (identName jsIdent) >>= \name -> pure [Import item name importPath'] toModuleElements (JSModuleImportDeclaration _ _) = err UnsupportedImport @@ -521,12 +521,12 @@ toModule mids mid filename top toExport (Just from) name as | from == "./foreign.js" = pure . (ForeignReexport, as,, []) $ - (JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot - (stringLiteral name) JSNoAnnot) + JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot + (stringLiteral name) JSNoAnnot | Just from' <- stripSuffix "/index.js" =<< stripPrefix "../" from = pure . (RegularExport name, as,, []) $ - (JSMemberSquare (JSIdentifier sp (T.unpack . moduleNameToJs . ModuleName $ T.pack from')) JSNoAnnot - (stringLiteral name) JSNoAnnot) + JSMemberSquare (JSIdentifier sp (T.unpack . moduleNameToJs . ModuleName $ T.pack from')) JSNoAnnot + (stringLiteral name) JSNoAnnot | otherwise = err UnsupportedExport toExport Nothing name as = pure $ toRegularExport name as diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 7133b7cf0f..d75ed5778c 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -68,14 +68,14 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = comments <- not <$> asks optionsNoComments let header = if comments && not (null coms) then AST.Comment Nothing coms else id let foreign' = maybe [] (pure . AST.Import Nothing "$foreign") $ if null foreigns then Nothing else foreignInclude - let moduleBody = maybe [] (uncurry (:)) . fmap (first header) . uncons $ foreign' ++ jsImports ++ concat optimized + let moduleBody = (maybe [] (uncurry (:) . first header) . uncons) $ foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) return $ moduleBody ++ (maybeToList . exportsToJs foreignInclude $ foreignExps) ++ (maybeToList . exportsToJs Nothing $ standardExps) - ++ (mapMaybe reExportsToJs reExps') + ++ mapMaybe reExportsToJs reExps' where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index df4eda2c9a..a0e55bfd4e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -711,7 +711,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DeprecatedFFICommonJSModule mn path) = paras [ line $ "A CommonJS foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " , indent . lineS $ path - , line $ "CommonJS foreign modules are deprecated and won't be supported in the future." + , line "CommonJS foreign modules are deprecated and won't be supported in the future." ] renderSimpleErrorMessage (UnsupportedFFICommonJSExports mn idents) = paras [ line $ "The following CommonJS exports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " From b0216afa97de07549708a5f5e7595065b6e0c0d7 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Wed, 8 Jul 2020 11:00:12 +0200 Subject: [PATCH 035/105] Desugar record accessor to a special function call --- src/Language/PureScript/Constants/Prelude.hs | 10 ++++++ src/Language/PureScript/Sugar.hs | 2 ++ src/Language/PureScript/Sugar/Accessor.hs | 36 ++++++++++++++++++++ 3 files changed, 48 insertions(+) create mode 100644 src/Language/PureScript/Sugar/Accessor.hs diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 39af647330..24b1df8c8b 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -273,6 +273,16 @@ pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") + +-- Data.Record + +pattern DataRecord :: ModuleName +pattern DataRecord = ModuleName "Data.Record" + +getField :: Qualified Ident +getField = Qualified (Just DataRecord) (Ident "getField") + + dataArray :: forall a. (IsString a) => a dataArray = "Data_Array" diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 52a33486b6..9a12423518 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -32,6 +32,7 @@ import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S import Language.PureScript.Sugar.TypeDeclarations as S import Language.PureScript.TypeChecker.Synonyms (SynonymMap) +import Language.PureScript.Sugar.Accessor as S -- | -- The desugaring pipeline proceeds as follows: @@ -69,6 +70,7 @@ desugar desugar externs = desugarSignedLiterals >>> desugarObjectConstructors + >>> fmap (map desugarAccessorModule) >=> desugarDoModule >=> desugarAdoModule >=> desugarLetPatternModule diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs new file mode 100644 index 0000000000..7289149735 --- /dev/null +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -0,0 +1,36 @@ +-- | +module Language.PureScript.Sugar.Accessor (desugarAccessorModule) where + +import Prelude.Compat + +import Data.List (groupBy, concatMap) +import Data.Function (on) + +import Language.PureScript.AST +import Language.PureScript.Types +import Language.PureScript.Crash +import Language.PureScript.AST.SourcePos +import qualified Language.PureScript.Constants.Prelude as C + +-- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ +-- expressions. +desugarAccessorModule :: Module -> Module +desugarAccessorModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarAccessor ds) exts + +-- | Desugar a single let expression +desugarAccessor :: Declaration -> Declaration +desugarAccessor decl = + let (f, _, _) = everywhereOnValues id replace id + in f decl + where + replace :: Expr -> Expr + replace (Accessor label e) = + App + (App + (Var nullSourceSpan C.getField) + (TypedValue False (Constructor nullSourceSpan C.SProxy) + (TypeApp nullSourceAnn + (TypeConstructor nullSourceAnn C.SProxyType) + (TypeLevelString nullSourceAnn label)))) + e + replace other = other From dfa92af893c3724d7c7bb1703dc5765f5c2f89b3 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Wed, 8 Jul 2020 15:32:03 +0200 Subject: [PATCH 036/105] Overloaded record accessors --- src/Language/PureScript/Sugar.hs | 2 +- src/Language/PureScript/Sugar/Accessor.hs | 32 ++++++++++++++++------- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 9a12423518..bee9fb39e8 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -70,7 +70,7 @@ desugar desugar externs = desugarSignedLiterals >>> desugarObjectConstructors - >>> fmap (map desugarAccessorModule) + >>> fmap (map (desugarAccessorModule externs)) >=> desugarDoModule >=> desugarAdoModule >=> desugarLetPatternModule diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 7289149735..58d709a8b7 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -5,27 +5,41 @@ import Prelude.Compat import Data.List (groupBy, concatMap) import Data.Function (on) +import Data.Monoid (Any(..)) +import Control.Monad.Writer import Language.PureScript.AST import Language.PureScript.Types import Language.PureScript.Crash import Language.PureScript.AST.SourcePos -import qualified Language.PureScript.Constants.Prelude as C +import Language.PureScript.Externs +import Language.PureScript.Names +import qualified Language.PureScript.Constants as C -- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ -- expressions. -desugarAccessorModule :: Module -> Module -desugarAccessorModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarAccessor ds) exts +desugarAccessorModule :: [ExternsFile] -> Module -> Module +desugarAccessorModule externs m | not (any (\e -> efModuleName e == ModuleName "Data.Record") externs) = m +desugarAccessorModule _externs (Module ss coms mn ds exts) = + let (ds', Any used) = runWriter $ traverse desugarAccessor ds + extraImports = + if used then + addDefaultImport (Qualified (Just C.DataRecord) C.DataRecord) + . addDefaultImport (Qualified (Just C.DataSymbol) C.DataSymbol) + else + id + in extraImports $ Module ss coms mn ds' exts -- | Desugar a single let expression -desugarAccessor :: Declaration -> Declaration +desugarAccessor :: Declaration -> Writer Any Declaration desugarAccessor decl = - let (f, _, _) = everywhereOnValues id replace id + let (f, _, _) = everywhereOnValuesM pure replace pure in f decl where - replace :: Expr -> Expr - replace (Accessor label e) = - App + replace :: Expr -> Writer Any Expr + replace (Accessor label e) = do + tell (Any True) + pure $ App (App (Var nullSourceSpan C.getField) (TypedValue False (Constructor nullSourceSpan C.SProxy) @@ -33,4 +47,4 @@ desugarAccessor decl = (TypeConstructor nullSourceAnn C.SProxyType) (TypeLevelString nullSourceAnn label)))) e - replace other = other + replace other = pure other From ef5aca38227b9cfc7020b95081ecb2134622c153 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Thu, 22 Oct 2020 10:52:29 +0200 Subject: [PATCH 037/105] Fix warnings --- src/Language/PureScript/Sugar/Accessor.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 58d709a8b7..ab69c09c9d 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -3,15 +3,11 @@ module Language.PureScript.Sugar.Accessor (desugarAccessorModule) where import Prelude.Compat -import Data.List (groupBy, concatMap) -import Data.Function (on) import Data.Monoid (Any(..)) import Control.Monad.Writer import Language.PureScript.AST import Language.PureScript.Types -import Language.PureScript.Crash -import Language.PureScript.AST.SourcePos import Language.PureScript.Externs import Language.PureScript.Names import qualified Language.PureScript.Constants as C From a896388a72aeeedc7d615414ad5f4cdce4d1d67f Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 27 Oct 2020 12:23:13 +0100 Subject: [PATCH 038/105] Optimize back the common case of `Record` --- src/Language/PureScript/Constants/Prelude.hs | 61 +++++++++++++++++++- src/Language/PureScript/CoreFn/Optimizer.hs | 25 +++++++- 2 files changed, 84 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 24b1df8c8b..fcaeac2cf7 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -273,14 +273,73 @@ pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") +pattern IsSymbolIdent :: Qualified Ident +pattern IsSymbolIdent = Qualified (Just DataSymbol) (Ident "IsSymbol") + + +typ :: forall a. (IsString a) => a +typ = "Type" + +kindBoolean :: forall a. (IsString a) => a +kindBoolean = "Boolean" + +kindOrdering :: forall a. (IsString a) => a +kindOrdering = "Ordering" + +kindRowList :: forall a. (IsString a) => a +kindRowList = "RowList" + +symbol :: forall a. (IsString a) => a +symbol = "Symbol" + +doc :: forall a. (IsString a) => a +doc = "Doc" + +-- Modules + +prim :: forall a. (IsString a) => a +prim = "Prim" + +moduleBoolean :: forall a. (IsString a) => a +moduleBoolean = "Boolean" + +moduleOrdering :: forall a. (IsString a) => a +moduleOrdering = "Ordering" + +moduleRow :: forall a. (IsString a) => a +moduleRow = "Row" + +moduleRowList :: forall a. (IsString a) => a +moduleRowList = "RowList" + +moduleSymbol :: forall a. (IsString a) => a +moduleSymbol = "Symbol" + +typeError :: forall a. (IsString a) => a +typeError = "TypeError" + +pattern SProxyType :: Qualified (ProperName 'TypeName) +pattern SProxyType = Qualified (Just DataSymbol) (ProperName "SProxy") + +pattern SProxy :: Qualified (ProperName 'ConstructorName) +pattern SProxy = Qualified (Just DataSymbol) (ProperName "SProxy") + +pattern SProxyIdent :: Qualified Ident +pattern SProxyIdent = Qualified (Just DataSymbol) (Ident "SProxy") -- Data.Record pattern DataRecord :: ModuleName pattern DataRecord = ModuleName "Data.Record" +pattern DataRecord_getField :: Qualified Ident +pattern DataRecord_getField = Qualified (Just DataRecord) (Ident "getField") + +pattern DataRecord_hasFieldRecord :: Qualified Ident +pattern DataRecord_hasFieldRecord = Qualified (Just DataRecord) (Ident "hasFieldRecord") + getField :: Qualified Ident -getField = Qualified (Just DataRecord) (Ident "getField") +getField = DataRecord_getField dataArray :: forall a. (IsString a) => a diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 6b3c9ef2b5..9c39949746 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -24,7 +24,7 @@ optimizeModuleDecls :: [Bind Ann] -> [Bind Ann] optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity - transformExprs = optimizeUnusedPartialFn . optimizeClosedRecordUpdate + transformExprs = optimizeUnusedPartialFn . optimizeClosedRecordUpdate . optimizeRecordGetField optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) = @@ -54,3 +54,26 @@ optimizeUnusedPartialFn (Let _ (App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) = originalCoreFn optimizeUnusedPartialFn e = e + +-- | Optimize +-- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Data_Symbol.SProxy.value)(x)` +-- into +-- `x.f` +optimizeRecordGetField :: Expr a -> Expr a +optimizeRecordGetField + (App ann + (App _ + (App _ + (Var _ C.DataRecord_getField) + (App _ + (App _ + (Var _ C.DataRecord_hasFieldRecord) + (App _ + (Var _ C.IsSymbolIdent) + (Abs _ _ + (Literal _ (StringLiteral label))))) + _)) + (Var _ C.SProxyIdent)) + object) = + Accessor ann label object +optimizeRecordGetField e = e From 4b3fe2bae8ae1392ee0abdfd58ecd4b3fea2aae9 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 28 Sep 2021 10:48:34 +0000 Subject: [PATCH 039/105] Fix post-merge breakage --- src/Language/PureScript/Constants/Prelude.hs | 42 -------------------- src/Language/PureScript/CoreFn/Optimizer.hs | 1 + src/Language/PureScript/Sugar.hs | 2 +- src/Language/PureScript/Sugar/Accessor.hs | 3 +- 4 files changed, 3 insertions(+), 45 deletions(-) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index fcaeac2cf7..e69799aa31 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -276,48 +276,6 @@ pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") pattern IsSymbolIdent :: Qualified Ident pattern IsSymbolIdent = Qualified (Just DataSymbol) (Ident "IsSymbol") - -typ :: forall a. (IsString a) => a -typ = "Type" - -kindBoolean :: forall a. (IsString a) => a -kindBoolean = "Boolean" - -kindOrdering :: forall a. (IsString a) => a -kindOrdering = "Ordering" - -kindRowList :: forall a. (IsString a) => a -kindRowList = "RowList" - -symbol :: forall a. (IsString a) => a -symbol = "Symbol" - -doc :: forall a. (IsString a) => a -doc = "Doc" - --- Modules - -prim :: forall a. (IsString a) => a -prim = "Prim" - -moduleBoolean :: forall a. (IsString a) => a -moduleBoolean = "Boolean" - -moduleOrdering :: forall a. (IsString a) => a -moduleOrdering = "Ordering" - -moduleRow :: forall a. (IsString a) => a -moduleRow = "Row" - -moduleRowList :: forall a. (IsString a) => a -moduleRowList = "RowList" - -moduleSymbol :: forall a. (IsString a) => a -moduleSymbol = "Symbol" - -typeError :: forall a. (IsString a) => a -typeError = "TypeError" - pattern SProxyType :: Qualified (ProperName 'TypeName) pattern SProxyType = Qualified (Just DataSymbol) (ProperName "SProxy") diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 9c39949746..2b408bea55 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -13,6 +13,7 @@ import Language.PureScript.Names (Ident(UnusedIdent), Qualified(Qualified)) import Language.PureScript.Label import Language.PureScript.Types import qualified Language.PureScript.Constants.Prim as C +import qualified Language.PureScript.Constants.Prelude as C -- | -- CoreFn optimization pass. diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index bee9fb39e8..8f99c4c029 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -70,7 +70,7 @@ desugar desugar externs = desugarSignedLiterals >>> desugarObjectConstructors - >>> fmap (map (desugarAccessorModule externs)) + >>> fmap (desugarAccessorModule externs) >=> desugarDoModule >=> desugarAdoModule >=> desugarLetPatternModule diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index ab69c09c9d..a544380a5b 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -3,14 +3,13 @@ module Language.PureScript.Sugar.Accessor (desugarAccessorModule) where import Prelude.Compat -import Data.Monoid (Any(..)) import Control.Monad.Writer import Language.PureScript.AST import Language.PureScript.Types import Language.PureScript.Externs import Language.PureScript.Names -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C -- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ -- expressions. From 3cda1fa5629219d959e833bb0f147883e6f1d03f Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 28 Sep 2021 11:01:37 +0000 Subject: [PATCH 040/105] Run workflows on restaumatic branch --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e33fc6eb44..7459bb4203 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,9 +2,9 @@ name: "CI" on: push: - branches: [ "master" ] + branches: [ "master", "restaumatic" ] pull_request: - branches: [ "master" ] + branches: [ "master", "restaumatic" ] release: types: [ "published" ] From ee2fb90e0ecdd41baca8e4a602b5df0fc27c84fd Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 28 Sep 2021 11:01:59 +0000 Subject: [PATCH 041/105] Add missing module --- purescript.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/purescript.cabal b/purescript.cabal index 5317db211d..e7d32bbe93 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -284,6 +284,7 @@ library Language.PureScript.Publish.Utils Language.PureScript.Renamer Language.PureScript.Sugar + Language.PureScript.Sugar.Accessor Language.PureScript.Sugar.AdoNotation Language.PureScript.Sugar.BindingGroups Language.PureScript.Sugar.CaseDeclarations From abce72aa41627e3f02ab4239544a80dfaaec4fde Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 27 Oct 2020 12:28:45 +0100 Subject: [PATCH 042/105] Bump version --- src/Language/PureScript/Externs.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index c10d96c2f4..49f0d2f4b9 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -159,11 +159,14 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration +currentVersion :: String +currentVersion = showVersion Paths.version ++ "-restaumatic1" + -- | Check whether the version in an externs file matches the currently running -- version. externsIsCurrentVersion :: ExternsFile -> Bool externsIsCurrentVersion ef = - T.unpack (efVersion ef) == showVersion Paths.version + T.unpack (efVersion ef) == currentVersion -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment @@ -206,7 +209,7 @@ moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where - efVersion = T.pack (showVersion Paths.version) + efVersion = T.pack currentVersion efModuleName = mn efExports = map renameRef exps efImports = mapMaybe importDecl ds From ac4ccabb77ed37e2aee9d978aa9e3f547dae7524 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Wed, 13 Oct 2021 14:21:00 +0000 Subject: [PATCH 043/105] Bump also version for ide exports --- src/Language/PureScript/Externs.hs | 1 + src/Language/PureScript/Ide/Externs.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 49f0d2f4b9..4ef40fce65 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -12,6 +12,7 @@ module Language.PureScript.Externs , moduleToExternsFile , applyExternsFileToEnvironment , externsFileName + , currentVersion ) where import Prelude.Compat diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 7a67d160d8..8ab575b9b8 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -9,9 +9,9 @@ import Protolude hiding (to, from, (&)) import Codec.CBOR.Term as Term import "monad-logger" Control.Monad.Logger -import Data.Version (showVersion) import qualified Data.Text as Text import qualified Language.PureScript as P +import qualified Language.PureScript.Externs as Externs import qualified Language.PureScript.Make.Monad as Make import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types @@ -40,7 +40,7 @@ readExternFile fp = do _ -> throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) where - version = toS (showVersion P.version) + version = toS Externs.currentVersion convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = From becb77c5f30b8db3b86adad8f63e9dcbdd45f047 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Sun, 17 Oct 2021 08:56:47 +0000 Subject: [PATCH 044/105] Update version --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 4ef40fce65..a32d8877b2 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -161,7 +161,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic1" +currentVersion = showVersion Paths.version ++ "-restaumatic-esm1" -- | Check whether the version in an externs file matches the currently running -- version. From 2df41480bdaae1109ec518a76317aa43d1b6c450 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Sun, 17 Oct 2021 09:29:07 +0000 Subject: [PATCH 045/105] Bundle: detect functions as internal members --- src/Language/PureScript/Bundle.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 951f06859a..f45bc3e18a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -666,6 +666,10 @@ matchInternalMember stmt , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit = pure (name, decl) + -- function foo(...args) { body } + | JSFunction a0 jsIdent a1 args a2 body _ <- stmt + , JSIdentName _ name <- jsIdent + = pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body) | otherwise = Nothing From e2a0fd0445a3c7fba7fb220416459dc43ff94279 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Sun, 17 Oct 2021 12:20:43 +0000 Subject: [PATCH 046/105] Fix lint errors --- src/Language/PureScript/Constants/Prelude.hs | 11 ++++------- src/Language/PureScript/CoreFn/Optimizer.hs | 4 ++-- src/Language/PureScript/Sugar/Accessor.hs | 2 +- 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index e69799aa31..e39ec9a06d 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -290,14 +290,11 @@ pattern SProxyIdent = Qualified (Just DataSymbol) (Ident "SProxy") pattern DataRecord :: ModuleName pattern DataRecord = ModuleName "Data.Record" -pattern DataRecord_getField :: Qualified Ident -pattern DataRecord_getField = Qualified (Just DataRecord) (Ident "getField") +pattern GetField :: Qualified Ident +pattern GetField = Qualified (Just DataRecord) (Ident "getField") -pattern DataRecord_hasFieldRecord :: Qualified Ident -pattern DataRecord_hasFieldRecord = Qualified (Just DataRecord) (Ident "hasFieldRecord") - -getField :: Qualified Ident -getField = DataRecord_getField +pattern HasFieldRecord :: Qualified Ident +pattern HasFieldRecord = Qualified (Just DataRecord) (Ident "hasFieldRecord") dataArray :: forall a. (IsString a) => a diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 2b408bea55..bd7015b790 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -65,10 +65,10 @@ optimizeRecordGetField (App ann (App _ (App _ - (Var _ C.DataRecord_getField) + (Var _ C.GetField) (App _ (App _ - (Var _ C.DataRecord_hasFieldRecord) + (Var _ C.HasFieldRecord) (App _ (Var _ C.IsSymbolIdent) (Abs _ _ diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index a544380a5b..1fc6ebf114 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -36,7 +36,7 @@ desugarAccessor decl = tell (Any True) pure $ App (App - (Var nullSourceSpan C.getField) + (Var nullSourceSpan C.GetField) (TypedValue False (Constructor nullSourceSpan C.SProxy) (TypeApp nullSourceAnn (TypeConstructor nullSourceAnn C.SProxyType) From 4784e2d531f1e4bdebf324ef77120d4ac54265d9 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Fri, 22 Oct 2021 08:48:36 +0000 Subject: [PATCH 047/105] Fix getField optimization for plain records --- src/Language/PureScript/Constants/Prelude.hs | 3 +++ src/Language/PureScript/CoreFn/Optimizer.hs | 10 ++++++---- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index e39ec9a06d..18905c085f 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -276,6 +276,9 @@ pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") pattern IsSymbolIdent :: Qualified Ident pattern IsSymbolIdent = Qualified (Just DataSymbol) (Ident "IsSymbol") +pattern IsSymbolDict :: Qualified Ident +pattern IsSymbolDict = Qualified (Just DataSymbol) (Ident "IsSymbol$Dict") + pattern SProxyType :: Qualified (ProperName 'TypeName) pattern SProxyType = Qualified (Just DataSymbol) (ProperName "SProxy") diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index bd7015b790..18f6d9052c 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -6,7 +6,7 @@ import Data.List (lookup) import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.CoreFn.Ann -import Language.PureScript.CoreFn.Expr +import Language.PureScript.CoreFn.Expr as Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals import Language.PureScript.Names (Ident(UnusedIdent), Qualified(Qualified)) @@ -70,9 +70,11 @@ optimizeRecordGetField (App _ (Var _ C.HasFieldRecord) (App _ - (Var _ C.IsSymbolIdent) - (Abs _ _ - (Literal _ (StringLiteral label))))) + (Var _ C.IsSymbolDict) + (Literal _ (ObjectLiteral + [ ("reflectSymbol", Abs _ _ + (Literal _ (StringLiteral label))) + ])))) _)) (Var _ C.SProxyIdent)) object) = From 007ff269a7462229547e52ecefecbcadbde0933f Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 26 Oct 2021 17:30:11 +0000 Subject: [PATCH 048/105] Update version --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a32d8877b2..4ef40fce65 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -161,7 +161,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic-esm1" +currentVersion = showVersion Paths.version ++ "-restaumatic1" -- | Check whether the version in an externs file matches the currently running -- version. From 97a513e4ea1d65312e8b0de3707323d3a70459eb Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Fri, 3 Jun 2022 11:50:29 +0000 Subject: [PATCH 049/105] Fix imports generated for OverloadedRecordFields (SProxy->Proxy) --- src/Language/PureScript/Constants/Prelude.hs | 15 +++--- src/Language/PureScript/CoreFn/Optimizer.hs | 4 +- src/Language/PureScript/Sugar/Accessor.hs | 50 +++++++++++--------- 3 files changed, 39 insertions(+), 30 deletions(-) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 1ac98e9296..574267eb86 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -279,14 +279,17 @@ pattern IsSymbolIdent = Qualified (Just DataSymbol) (Ident "IsSymbol") pattern IsSymbolDict :: Qualified Ident pattern IsSymbolDict = Qualified (Just DataSymbol) (Ident "IsSymbol$Dict") -pattern SProxyType :: Qualified (ProperName 'TypeName) -pattern SProxyType = Qualified (Just DataSymbol) (ProperName "SProxy") +pattern TypeProxy :: ModuleName +pattern TypeProxy = ModuleName "Type.Proxy" -pattern SProxy :: Qualified (ProperName 'ConstructorName) -pattern SProxy = Qualified (Just DataSymbol) (ProperName "SProxy") +pattern ProxyType :: Qualified (ProperName 'TypeName) +pattern ProxyType = Qualified (Just TypeProxy) (ProperName "Proxy") -pattern SProxyIdent :: Qualified Ident -pattern SProxyIdent = Qualified (Just DataSymbol) (Ident "SProxy") +pattern Proxy :: Qualified (ProperName 'ConstructorName) +pattern Proxy = Qualified (Just TypeProxy) (ProperName "Proxy") + +pattern ProxyIdent :: Qualified Ident +pattern ProxyIdent = Qualified (Just TypeProxy) (Ident "Proxy") pattern DataReflectable :: ModuleName diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 90acb5adce..9ba787e94e 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -55,7 +55,7 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = closedRecordFields _ = Nothing -- | Optimize --- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Data_Symbol.SProxy.value)(x)` +-- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Type_Proxy.Proxy.value)(x)` -- into -- `x.f` optimizeRecordGetField :: Expr a -> Expr a @@ -74,7 +74,7 @@ optimizeRecordGetField (Literal _ (StringLiteral label))) ])))) _)) - (Var _ C.SProxyIdent)) + (Var _ C.ProxyIdent)) object) = Accessor ann label object optimizeRecordGetField e = e diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 1fc6ebf114..e6d61c6127 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -1,45 +1,51 @@ -- | -module Language.PureScript.Sugar.Accessor (desugarAccessorModule) where +module Language.PureScript.Sugar.Accessor + ( desugarAccessorModule + ) where -import Prelude.Compat +import Prelude.Compat -import Control.Monad.Writer +import Control.Monad.Writer -import Language.PureScript.AST -import Language.PureScript.Types -import Language.PureScript.Externs -import Language.PureScript.Names -import qualified Language.PureScript.Constants.Prelude as C +import Language.PureScript.AST +import qualified Language.PureScript.Constants.Prelude + as C +import Language.PureScript.Externs +import Language.PureScript.Names +import Language.PureScript.Types -- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ -- expressions. desugarAccessorModule :: [ExternsFile] -> Module -> Module -desugarAccessorModule externs m | not (any (\e -> efModuleName e == ModuleName "Data.Record") externs) = m +desugarAccessorModule externs m + | not (any (\e -> efModuleName e == ModuleName "Data.Record") externs) = m desugarAccessorModule _externs (Module ss coms mn ds exts) = let (ds', Any used) = runWriter $ traverse desugarAccessor ds - extraImports = - if used then - addDefaultImport (Qualified (Just C.DataRecord) C.DataRecord) - . addDefaultImport (Qualified (Just C.DataSymbol) C.DataSymbol) - else - id - in extraImports $ Module ss coms mn ds' exts + extraImports = if used + then addDefaultImport (Qualified (Just C.DataRecord) C.DataRecord) + . addDefaultImport (Qualified (Just C.TypeProxy) C.TypeProxy) + else id + in extraImports $ Module ss coms mn ds' exts -- | Desugar a single let expression desugarAccessor :: Declaration -> Writer Any Declaration desugarAccessor decl = - let (f, _, _) = everywhereOnValuesM pure replace pure - in f decl - where + let (f, _, _) = everywhereOnValuesM pure replace pure in f decl + where replace :: Expr -> Writer Any Expr replace (Accessor label e) = do tell (Any True) pure $ App (App (Var nullSourceSpan C.GetField) - (TypedValue False (Constructor nullSourceSpan C.SProxy) + (TypedValue + False + (Constructor nullSourceSpan C.Proxy) (TypeApp nullSourceAnn - (TypeConstructor nullSourceAnn C.SProxyType) - (TypeLevelString nullSourceAnn label)))) + (TypeConstructor nullSourceAnn C.ProxyType) + (TypeLevelString nullSourceAnn label) + ) + ) + ) e replace other = pure other From 73d3ee939afc46fc916dc0f564e9d57ff9712108 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Fri, 3 Jun 2022 11:51:58 +0000 Subject: [PATCH 050/105] Update version --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 4ef40fce65..7be969c363 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -161,7 +161,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic1" +currentVersion = showVersion Paths.version ++ "-restaumatic2" -- | Check whether the version in an externs file matches the currently running -- version. From 272bbe4e745b4abcfc28498a3931f8b62513351c Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Sun, 5 Jun 2022 09:21:54 +0000 Subject: [PATCH 051/105] Fix test golden --- tests/purs/warning/ImplicitQualifiedImportReExport.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/purs/warning/ImplicitQualifiedImportReExport.out b/tests/purs/warning/ImplicitQualifiedImportReExport.out index b0667d0940..cbf9bd416d 100644 --- a/tests/purs/warning/ImplicitQualifiedImportReExport.out +++ b/tests/purs/warning/ImplicitQualifiedImportReExport.out @@ -21,7 +21,7 @@ Warning 2 of 2: Module Data.Either was imported as Y with unspecified imports. As this module is being re-exported, consider using the explicit form: - import Data.Either (Either(..), choose, either, fromLeft, fromLeft', fromRight, fromRight', hush, isLeft, isRight, note, note') as Y + import Data.Either (Either(..), blush, choose, either, fromLeft, fromLeft', fromRight, fromRight', hush, isLeft, isRight, note, note') as Y From ba6f317285aa2ac063096798bddb3dc8a8518bcc Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 25 Aug 2023 18:57:15 +0200 Subject: [PATCH 052/105] it typechecks, ship it! --- purescript.cabal | 2 +- src/Language/PureScript/CodeGen/JS.hs | 6 +-- src/Language/PureScript/CodeGen/JS/Printer.hs | 28 ++-------- src/Language/PureScript/CoreFn/Optimizer.hs | 25 --------- src/Language/PureScript/CoreImp/AST.hs | 18 +++---- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Sugar.hs | 2 +- src/Language/PureScript/Sugar/Accessor.hs | 51 ------------------- 8 files changed, 19 insertions(+), 115 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index cc76bafb16..9073f5112f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -352,7 +352,7 @@ library Language.PureScript.Renamer Language.PureScript.Roles Language.PureScript.Sugar - Language.PureScript.Sugar.Accessor + -- Language.PureScript.Sugar.Accessor Language.PureScript.Sugar.AdoNotation Language.PureScript.Sugar.BindingGroups Language.PureScript.Sugar.CaseDeclarations diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 37da30f6b2..faac2ed39e 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -166,12 +166,12 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = -- Generates JavaScript code for exporting at least one identifier, -- eventually from another module. - exportsToJs :: Maybe PSString -> [Ident] -> Maybe Mod.Export - exportsToJs from = fmap (flip Mod.Export from) . NEL.nonEmpty . fmap runIdent + exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST.Export + exportsToJs from = fmap (flip AST.Export from) . NEL.nonEmpty . fmap runIdent -- Generates JavaScript code for re-exporting at least one identifier from -- from another module. - reExportsToJs :: (ModuleName, [Ident]) -> Maybe Mod.Export + reExportsToJs :: (ModuleName, [Ident]) -> Maybe AST.Export reExportsToJs = uncurry exportsToJs . first (Just . moduleImportPath) moduleImportPath :: ModuleName -> PSString diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index ff3c88f94e..9341190041 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -121,26 +121,6 @@ literals = mkPattern' match' , mconcat <$> forM com comment , prettyPrintJS' js ] - match (Import _ ident from) = return . emit $ - "import * as " <> ident <> " from " <> prettyPrintStringJS from - match (Export _ idents from) = mconcat <$> sequence - [ return $ emit "export {\n" - , withIndent $ do - let exportsStrings = emit . exportedIdentToString from <$> idents - indentString <- currentIndent - return . intercalate (emit ",\n") . NEL.toList $ (indentString <>) <$> exportsStrings - , return $ emit "\n" - , currentIndent - , return . emit $ "}" <> maybe "" ((" from " <>) . prettyPrintStringJS) from - ] - where - exportedIdentToString Nothing ident - | nameIsJsReserved ident || nameIsJsBuiltIn ident - = "$$" <> ident <> " as " <> ident - exportedIdentToString _ "$main" - = T.concatMap identCharToText "$main" <> " as $main" - exportedIdentToString _ ident - = T.concatMap identCharToText ident match (Comment PureAnnotation js) = mconcat <$> sequence [ return $ emit "/* #__PURE__ */ " , prettyPrintJS' js @@ -175,13 +155,13 @@ comment (BlockComment com) = fmap mconcat $ sequence $ Just (x, xs) -> x `T.cons` removeComments xs Nothing -> "" -prettyImport :: (Emit gen) => AST.Import -> StateT PrinterState Maybe gen -prettyImport (AST.Import ident from) = +prettyImport :: (Emit gen) => Import -> StateT PrinterState Maybe gen +prettyImport (Import ident from) = return . emit $ "import * as " <> ident <> " from " <> prettyPrintStringJS from <> ";" -prettyExport :: (Emit gen) => AST.Export -> StateT PrinterState Maybe gen -prettyExport (AST.Export idents from) = +prettyExport :: (Emit gen) => Export -> StateT PrinterState Maybe gen +prettyExport (Export idents from) = mconcat <$> sequence [ return $ emit "export {\n" , withIndent $ do diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index bd55ead3b6..722893c439 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -23,31 +23,6 @@ optimizeModuleDecls = map transformBinds transformExprs = optimizeDataFunctionApply --- | Optimize --- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Type_Proxy.Proxy.value)(x)` --- into --- `x.f` -optimizeRecordGetField :: Expr a -> Expr a -optimizeRecordGetField - (App ann - (App _ - (App _ - (Var _ C.GetField) - (App _ - (App _ - (Var _ C.HasFieldRecord) - (App _ - (Var _ C.IsSymbolDict) - (Literal _ (ObjectLiteral - [ ("reflectSymbol", Abs _ _ - (Literal _ (StringLiteral label))) - ])))) - _)) - (Var _ C.ProxyIdent)) - object) = - Accessor ann label object -optimizeRecordGetField e = e - optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of (App a (App _ (Var _ fn) x) y) diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 75b3b48a8a..cce54333ed 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -5,7 +5,7 @@ import Prelude import Control.Monad ((>=>)) import Control.Monad.Identity (Identity (..), runIdentity) -import qualified Data.List.NonEmpty as NEL (NonEmpty) + -- import Data.List.NonEmpty qualified as NEL (NonEmpty) import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) @@ -109,10 +109,10 @@ data AST -- ^ instanceof check | Comment CIComments AST -- ^ Commented JavaScript - | Import (Maybe SourceSpan) Text PSString - -- ^ Imported identifier and path to its module - | Export (Maybe SourceSpan) (NEL.NonEmpty Text) (Maybe PSString) - -- ^ Exported identifiers and optional path to their module (for re-exports) + -- | Import (Maybe SourceSpan) Text PSString + -- -- ^ Imported identifier and path to its module + -- | Export (Maybe SourceSpan) (NEL.NonEmpty Text) (Maybe PSString) + -- -- ^ Exported identifiers and optional path to their module (for re-exports) deriving (Show, Eq) withSourceSpan :: SourceSpan -> AST -> AST @@ -145,8 +145,8 @@ withSourceSpan withSpan = go where go (Throw _ js) = Throw ss js go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 go c@Comment {} = c - go (Import _ ident from) = Import ss ident from - go (Export _ idents from) = Export ss idents from + -- go (Import _ ident from) = Import ss ident from + -- go (Export _ idents from) = Export ss idents from getSourceSpan :: AST -> Maybe SourceSpan getSourceSpan = go where @@ -175,8 +175,8 @@ getSourceSpan = go where go (Throw ss _) = ss go (InstanceOf ss _ _) = ss go (Comment _ _) = Nothing - go (Import ss _ _) = ss - go (Export ss _ _) = ss + -- go (Import ss _ _) = ss + -- go (Export ss _ _) = ss everywhere :: (AST -> AST) -> AST -> AST everywhere f = go where diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 590bf37947..120c2da4f6 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -40,7 +40,7 @@ readExternFile fp = do _ -> throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) where - version = toS Externs.currentVersion + version = toS (showVersion P.version) convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 1b5446db49..b592c96104 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -62,7 +62,7 @@ desugar desugar externs = desugarSignedLiterals >>> desugarObjectConstructors - >>> fmap (desugarAccessorModule externs) + -- >>> fmap (desugarAccessorModule externs) >=> desugarDoModule >=> desugarAdoModule >=> desugarLetPatternModule diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index e6d61c6127..e69de29bb2 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -1,51 +0,0 @@ --- | -module Language.PureScript.Sugar.Accessor - ( desugarAccessorModule - ) where - -import Prelude.Compat - -import Control.Monad.Writer - -import Language.PureScript.AST -import qualified Language.PureScript.Constants.Prelude - as C -import Language.PureScript.Externs -import Language.PureScript.Names -import Language.PureScript.Types - --- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ --- expressions. -desugarAccessorModule :: [ExternsFile] -> Module -> Module -desugarAccessorModule externs m - | not (any (\e -> efModuleName e == ModuleName "Data.Record") externs) = m -desugarAccessorModule _externs (Module ss coms mn ds exts) = - let (ds', Any used) = runWriter $ traverse desugarAccessor ds - extraImports = if used - then addDefaultImport (Qualified (Just C.DataRecord) C.DataRecord) - . addDefaultImport (Qualified (Just C.TypeProxy) C.TypeProxy) - else id - in extraImports $ Module ss coms mn ds' exts - --- | Desugar a single let expression -desugarAccessor :: Declaration -> Writer Any Declaration -desugarAccessor decl = - let (f, _, _) = everywhereOnValuesM pure replace pure in f decl - where - replace :: Expr -> Writer Any Expr - replace (Accessor label e) = do - tell (Any True) - pure $ App - (App - (Var nullSourceSpan C.GetField) - (TypedValue - False - (Constructor nullSourceSpan C.Proxy) - (TypeApp nullSourceAnn - (TypeConstructor nullSourceAnn C.ProxyType) - (TypeLevelString nullSourceAnn label) - ) - ) - ) - e - replace other = pure other From 50aa943c6d4fa09fc2db8fdb7dfefc7652e831bb Mon Sep 17 00:00:00 2001 From: usagi-z Date: Mon, 28 Aug 2023 12:10:51 +0200 Subject: [PATCH 053/105] bring back desugarAccessorModule --- purescript.cabal | 2 +- src/Language/PureScript/Constants/Libs.hs | 7 ++++ src/Language/PureScript/Sugar.hs | 5 ++- src/Language/PureScript/Sugar/Accessor.hs | 50 +++++++++++++++++++++++ 4 files changed, 62 insertions(+), 2 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 9073f5112f..cc76bafb16 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -352,7 +352,7 @@ library Language.PureScript.Renamer Language.PureScript.Roles Language.PureScript.Sugar - -- Language.PureScript.Sugar.Accessor + Language.PureScript.Sugar.Accessor Language.PureScript.Sugar.AdoNotation Language.PureScript.Sugar.BindingGroups Language.PureScript.Sugar.CaseDeclarations diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 75c7385e0e..1e3f588e36 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -261,4 +261,11 @@ $(TH.declare do TH.mod "Unsafe.Coerce" do TH.asPair do TH.var "unsafeCoerce" + TH.mod "Type.Proxy" do + TH.dty "Proxy" ["Proxy"] + TH.asIdent do + TH.var "Proxy" + TH.mod "Data.Record" do + TH.asIdent do + TH.var "getField" ) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index b592c96104..f898bc6a44 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.Sugar (desugar, module S) where +import Prelude + import Control.Category ((>>>)) import Control.Monad ((>=>)) import Control.Monad.Error.Class (MonadError) @@ -25,6 +27,7 @@ import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S import Language.PureScript.Sugar.TypeDeclarations as S +import Language.PureScript.Sugar.Accessor as S -- | -- The desugaring pipeline proceeds as follows: @@ -62,7 +65,7 @@ desugar desugar externs = desugarSignedLiterals >>> desugarObjectConstructors - -- >>> fmap (desugarAccessorModule externs) + >>> fmap (desugarAccessorModule externs) >=> desugarDoModule >=> desugarAdoModule >=> desugarLetPatternModule diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index e69de29bb2..02c3d6c991 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -0,0 +1,50 @@ +-- | +module Language.PureScript.Sugar.Accessor + ( desugarAccessorModule + ) where + +import Prelude + +import Control.Monad.Writer + +import Language.PureScript.AST +import Language.PureScript.Constants.Libs qualified as C +import Language.PureScript.Externs +import Language.PureScript.Names +import Language.PureScript.Types + +-- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ +-- expressions. +desugarAccessorModule :: [ExternsFile] -> Module -> Module +desugarAccessorModule externs m + | not (any (\e -> efModuleName e == ModuleName "Data.Record") externs) = m +desugarAccessorModule _externs (Module ss coms mn ds exts) = + let (ds', Any used) = runWriter $ traverse desugarAccessor ds + extraImports = if used + then addDefaultImport (Qualified (ByModuleName C.M_Data_Record) C.M_Data_Record) + . addDefaultImport (Qualified (ByModuleName C.M_Type_Proxy) C.M_Type_Proxy) + else id + in extraImports $ Module ss coms mn ds' exts + +-- | Desugar a single let expression +desugarAccessor :: Declaration -> Writer Any Declaration +desugarAccessor decl = + let (f, _, _) = everywhereOnValuesM pure replace pure in f decl + where + replace :: Expr -> Writer Any Expr + replace (Accessor label e) = do + tell (Any True) + pure $ App + (App + (Var nullSourceSpan C.I_getField) + (TypedValue + False + (Constructor nullSourceSpan C.C_Proxy) + (TypeApp nullSourceAnn + (TypeConstructor nullSourceAnn C.Proxy) + (TypeLevelString nullSourceAnn label) + ) + ) + ) + e + replace other = pure other From 3761609566bca457b60dbb072c2992ac6ac2f99f Mon Sep 17 00:00:00 2001 From: usagi-z Date: Mon, 28 Aug 2023 12:44:07 +0200 Subject: [PATCH 054/105] bring back optimizeRecordGetField --- src/Language/PureScript/Constants/Libs.hs | 3 +++ src/Language/PureScript/CoreFn/Optimizer.hs | 29 ++++++++++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 1e3f588e36..833176f84f 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -166,6 +166,7 @@ $(TH.declare do TH.mod "Data.Symbol" do TH.cls "IsSymbol" + TH.asIdent do TH.var "IsSymbolDict" -- purescript-arrays @@ -268,4 +269,6 @@ $(TH.declare do TH.mod "Data.Record" do TH.asIdent do TH.var "getField" + TH.var "hasFieldRecord" + ) diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 722893c439..2176dbfcaa 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -9,7 +9,8 @@ import Language.PureScript.CoreFn.Expr (Bind, Expr(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues) import Language.PureScript.Constants.Libs qualified as C - +-- import Language.PureScript.CoreImp.AST (AST(StringLiteral, ObjectLiteral)) +import Language.PureScript.AST.Literals (Literal(..)) -- | -- CoreFn optimization pass. -- @@ -22,6 +23,32 @@ optimizeModuleDecls = map transformBinds (transformBinds, _, _) = everywhereOnValues identity transformExprs identity transformExprs = optimizeDataFunctionApply + . optimizeRecordGetField + +-- | Optimize +-- `Data_Record.getField(Data_Record.hasFieldRecord(new Data_Symbol.IsSymbol(function() { return "f"; }))())(Type_Proxy.Proxy.value)(x)` +-- into +-- `x.f` +optimizeRecordGetField :: Expr a -> Expr a +optimizeRecordGetField + (App ann + (App _ + (App _ + (Var _ C.I_getField) + (App _ + (App _ + (Var _ C.I_hasFieldRecord) + (App _ + (Var _ C.I_IsSymbolDict) + (Literal _ (ObjectLiteral + [ ("reflectSymbol", Abs _ _ + (Literal _ (StringLiteral label))) + ])))) + _)) + (Var _ C.I_Proxy)) + object) = + Accessor ann label object +optimizeRecordGetField e = e optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of From d1e32f575ff783bdc33e254c74fb6f12db63675e Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 09:05:20 +0200 Subject: [PATCH 055/105] enable CI --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 11234f418d..64bb375dcb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,7 +2,7 @@ name: "CI" on: push: - branches: [ "master", "restaumatic" ] + branches: [ "master", "restaumatic", "restaumatic-0.15.10" ] pull_request: branches: [ "master" ] paths: From 37a66e890c2e4abf2fd6fd00cd6a61763e638d54 Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 10:29:47 +0200 Subject: [PATCH 056/105] whitespace 1 --- src/Language/PureScript/Errors.hs | 86 +++++++++++++++---------------- 1 file changed, 43 insertions(+), 43 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e52a7b8d1a..e83cec1a0a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -221,7 +221,7 @@ errorModule :: ErrorMessage -> Maybe ModuleName errorModule = findHint matchModule where matchModule (ErrorInModule mn) = Just mn - matchModule _ = Nothing + matchModule _ = Nothing findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints @@ -230,9 +230,9 @@ findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints stripModuleAndSpan :: ErrorMessage -> ErrorMessage stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e where - shouldStrip (ErrorInModule _) = True + shouldStrip (ErrorInModule _) = True shouldStrip (PositionedError _) = True - shouldStrip _ = False + shouldStrip _ = False -- | Get the error code for a particular error type errorCode :: ErrorMessage -> Text @@ -544,7 +544,7 @@ errorSuggestion err = qstr :: Maybe ModuleName -> Text qstr (Just mn) = " as " <> runModuleName mn - qstr Nothing = "" + qstr Nothing = "" suggestionSpan :: ErrorMessage -> Maybe SourceSpan suggestionSpan e = @@ -559,12 +559,12 @@ suggestionSpan e = case simple of MissingTypeDeclaration{} -> startOnly ss MissingKindDeclaration{} -> startOnly ss - _ -> ss + _ -> ss showSuggestion :: SimpleErrorMessage -> Text showSuggestion suggestion = case errorSuggestion suggestion of Just (ErrorSuggestion x) -> x - _ -> "" + _ -> "" ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String ansiColor (intensity, color) = @@ -1655,13 +1655,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn) nameType :: Name -> Text - nameType (IdentName _) = "value" - nameType (ValOpName _) = "operator" - nameType (TyName _) = "type" - nameType (TyOpName _) = "type operator" - nameType (DctorName _) = "data constructor" + nameType (IdentName _) = "value" + nameType (ValOpName _) = "operator" + nameType (TyName _) = "type" + nameType (TyOpName _) = "type operator" + nameType (DctorName _) = "data constructor" nameType (TyClassName _) = "type class" - nameType (ModName _) = "module" + nameType (ModName _) = "module" runName :: Qualified Name -> Text runName (Qualified qb (IdentName name)) = @@ -1700,7 +1700,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon levelText :: Text levelText = case level of - Error -> "error" + Error -> "error" Warning -> "warning" paras :: forall f. Foldable f => f Box.Box -> Box.Box @@ -1720,18 +1720,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon case (hintCategory x, hintCategory y) of (OtherHint, _) -> False (_, OtherHint) -> False - (c1, c2) -> c1 == c2 + (c1, c2) -> c1 == c2 -- See https://github.com/purescript/purescript/issues/1802 stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] stripRedundantHints ExprDoesNotHaveType{} = stripFirst isCheckHint where isCheckHint ErrorCheckingType{} = True - isCheckHint _ = False + isCheckHint _ = False stripRedundantHints TypesDoNotUnify{} = stripFirst isUnifyHint where isUnifyHint ErrorUnifyingTypes{} = True - isUnifyHint _ = False + isUnifyHint _ = False stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _ _) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' @@ -1739,7 +1739,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon stripRedundantHints NoInstanceFound{} = stripFirst isSolverHint where isSolverHint ErrorSolvingConstraint{} = True - isSolverHint _ = False + isSolverHint _ = False stripRedundantHints _ = id stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] @@ -1751,27 +1751,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon stripFirst _ [] = [] hintCategory :: ErrorMessageHint -> HintCategory - hintCategory ErrorCheckingType{} = ExprHint - hintCategory ErrorInferringType{} = ExprHint - hintCategory ErrorInExpression{} = ExprHint - hintCategory ErrorUnifyingTypes{} = CheckHint - hintCategory ErrorInSubsumption{} = CheckHint - hintCategory ErrorInApplication{} = CheckHint - hintCategory ErrorCheckingKind{} = CheckHint - hintCategory ErrorSolvingConstraint{} = SolverHint - hintCategory PositionedError{} = PositionHint - hintCategory ErrorInDataConstructor{} = DeclarationHint - hintCategory ErrorInTypeConstructor{} = DeclarationHint - hintCategory ErrorInBindingGroup{} = DeclarationHint - hintCategory ErrorInDataBindingGroup{} = DeclarationHint - hintCategory ErrorInTypeSynonym{} = DeclarationHint - hintCategory ErrorInValueDeclaration{} = DeclarationHint - hintCategory ErrorInTypeDeclaration{} = DeclarationHint - hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint - hintCategory ErrorInKindDeclaration{} = DeclarationHint - hintCategory ErrorInRoleDeclaration{} = DeclarationHint - hintCategory ErrorInForeignImport{} = DeclarationHint - hintCategory _ = OtherHint + hintCategory ErrorCheckingType{} = ExprHint + hintCategory ErrorInferringType{} = ExprHint + hintCategory ErrorInExpression{} = ExprHint + hintCategory ErrorUnifyingTypes{} = CheckHint + hintCategory ErrorInSubsumption{} = CheckHint + hintCategory ErrorInApplication{} = CheckHint + hintCategory ErrorCheckingKind{} = CheckHint + hintCategory ErrorSolvingConstraint{} = SolverHint + hintCategory PositionedError{} = PositionHint + hintCategory ErrorInDataConstructor{} = DeclarationHint + hintCategory ErrorInTypeConstructor{} = DeclarationHint + hintCategory ErrorInBindingGroup{} = DeclarationHint + hintCategory ErrorInDataBindingGroup{} = DeclarationHint + hintCategory ErrorInTypeSynonym{} = DeclarationHint + hintCategory ErrorInValueDeclaration{} = DeclarationHint + hintCategory ErrorInTypeDeclaration{} = DeclarationHint + hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint + hintCategory ErrorInKindDeclaration{} = DeclarationHint + hintCategory ErrorInRoleDeclaration{} = DeclarationHint + hintCategory ErrorInForeignImport{} = DeclarationHint + hintCategory _ = OtherHint prettyPrintPlainIdent :: Ident -> Text prettyPrintPlainIdent ident = @@ -1923,10 +1923,10 @@ prettyPrintRef ReExportRef{} = Nothing prettyPrintKindSignatureFor :: KindSignatureFor -> Text -prettyPrintKindSignatureFor DataSig = "data" -prettyPrintKindSignatureFor NewtypeSig = "newtype" +prettyPrintKindSignatureFor DataSig = "data" +prettyPrintKindSignatureFor NewtypeSig = "newtype" prettyPrintKindSignatureFor TypeSynonymSig = "type" -prettyPrintKindSignatureFor ClassSig = "class" +prettyPrintKindSignatureFor ClassSig = "class" prettyPrintSuggestedTypeSimplified :: Type a -> String prettyPrintSuggestedTypeSimplified = prettyPrintSuggestedType . eraseForAllKindAnnotations . eraseKindApps @@ -2022,7 +2022,7 @@ withoutPosition :: ErrorMessage -> ErrorMessage withoutPosition (ErrorMessage hints se) = ErrorMessage (filter go hints) se where go (PositionedError _) = False - go _ = True + go _ = True positionedError :: SourceSpan -> ErrorMessageHint positionedError = PositionedError . pure @@ -2056,7 +2056,7 @@ parU xs f = collectErrors :: [Either MultipleErrors b] -> m [b] collectErrors es = case partitionEithers es of - ([], rs) -> return rs + ([], rs) -> return rs (errs, _) -> throwError $ fold errs internalCompilerError From c40bcd1b4a6902f8b3ed38822986e7fb8a472c5c Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 10:32:01 +0200 Subject: [PATCH 057/105] whitespace 2 --- src/Language/PureScript/Bundle.hs | 22 +++++++++++----------- src/Language/PureScript/Errors.hs | 6 +++--- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 6649e82a56..26b932323f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -216,7 +216,7 @@ printErrorMessage (MissingMainModule mName) = -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str -fromStringLiteral _ = Nothing +fromStringLiteral _ = Nothing strValue :: String -> String strValue str = go $ drop 1 str @@ -245,17 +245,17 @@ strValue str = go $ drop 1 str go "" = "" commaList :: JSCommaList a -> [a] -commaList JSLNil = [] -commaList (JSLOne x) = [x] +commaList JSLNil = [] +commaList (JSLOne x) = [x] commaList (JSLCons l _ x) = commaList l ++ [x] trailingCommaList :: JSCommaTrailingList a -> [a] trailingCommaList (JSCTLComma l _) = commaList l -trailingCommaList (JSCTLNone l) = commaList l +trailingCommaList (JSCTLNone l) = commaList l identName :: JSIdent -> Maybe String identName (JSIdentName _ ident) = Just ident -identName _ = Nothing +identName _ = Nothing exportStatementIdentifiers :: JSStatement -> [String] exportStatementIdentifiers (JSVariable _ jsExpressions _) = @@ -276,12 +276,12 @@ varNames :: JSCommaList JSExpression -> [String] varNames = mapMaybe varName . commaList where varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident - varName _ = Nothing + varName _ = Nothing data ForeignModuleExports = ForeignModuleExports { cjsExports :: [String] - , esExports :: [String] + , esExports :: [String] } deriving (Show) instance Semigroup ForeignModuleExports where @@ -334,13 +334,13 @@ getExportedIdentifiers mname top exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) = mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers - exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent + exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs data ForeignModuleImports = ForeignModuleImports { cjsImports :: [String] - , esImports :: [String] + , esImports :: [String] } deriving (Show) instance Semigroup ForeignModuleImports where @@ -440,5 +440,5 @@ matchExportsAssignment stmt extractLabel :: JSPropertyName -> Maybe String extractLabel (JSPropertyString _ nm) = Just $ strValue nm -extractLabel (JSPropertyIdent _ nm) = Just nm -extractLabel _ = Nothing +extractLabel (JSPropertyIdent _ nm) = Just nm +extractLabel _ = Nothing diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e83cec1a0a..972e6b69a8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -416,11 +416,11 @@ addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hi -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap - { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) -- ^ a map from skolems to their new names, including source and naming info - , umUnknownMap :: M.Map Int Int + , umUnknownMap :: M.Map Int Int -- ^ a map from unification variables to their new names - , umNextIndex :: Int + , umNextIndex :: Int -- ^ unknowns and skolems share a source of names during renaming, to -- avoid overlaps in error messages. This is the next label for either case. } deriving Show From 0f1e90b47e9d43fa6f8c40ec270f7d09ba2497ef Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 10:35:55 +0200 Subject: [PATCH 058/105] ws 3 --- src/Language/PureScript/CodeGen/JS.hs | 4 +-- src/Language/PureScript/CodeGen/JS/Printer.hs | 16 ++++----- src/Language/PureScript/CoreImp/AST.hs | 7 ++-- src/Language/PureScript/Interactive/IO.hs | 36 +++++++++---------- src/Language/PureScript/Make/Actions.hs | 15 ++++---- 5 files changed, 36 insertions(+), 42 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index faac2ed39e..14d122a37d 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -46,7 +46,7 @@ import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) import Language.PureScript.Constants.Prim qualified as C -import System.FilePath.Posix (()) +import System.FilePath.Posix (()) -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a -- module. @@ -134,7 +134,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = -- Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] getNames (NonRec _ ident _) = [ident] - getNames (Rec vals) = map (snd . fst) vals + getNames (Rec vals) = map (snd . fst) vals -- Creates alternative names for each module to ensure they don't collide -- with declaration names. diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 9341190041..6740e2a7a1 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -121,9 +121,9 @@ literals = mkPattern' match' , mconcat <$> forM com comment , prettyPrintJS' js ] - match (Comment PureAnnotation js) = mconcat <$> sequence + match (Comment PureAnnotation js) = mconcat <$> sequence [ return $ emit "/* #__PURE__ */ " - , prettyPrintJS' js + , prettyPrintJS' js ] match _ = mzero @@ -153,7 +153,7 @@ comment (BlockComment com) = fmap mconcat $ sequence $ Just rest -> removeComments rest Nothing -> case T.uncons t of Just (x, xs) -> x `T.cons` removeComments xs - Nothing -> "" + Nothing -> "" prettyImport :: (Emit gen) => Import -> StateT PrinterState Maybe gen prettyImport (Import ident from) = @@ -187,20 +187,20 @@ accessor = mkPattern match match (Indexer _ (StringLiteral _ prop) val) = case decodeString prop of Just s | isValidJsIdentifier s -> Just (s, val) - _ -> Nothing + _ -> Nothing match _ = Nothing indexer :: (Emit gen) => Pattern PrinterState AST (gen, AST) indexer = mkPattern' match where match (Indexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val - match _ = mzero + match _ = mzero lam :: Pattern PrinterState AST ((Maybe Text, [Text], Maybe SourceSpan), AST) lam = mkPattern match where match (Function ss name args ret) = Just ((name, args, ss), ret) - match _ = Nothing + match _ = Nothing app :: (Emit gen) => Pattern PrinterState AST (gen, AST) app = mkPattern' match @@ -214,7 +214,7 @@ instanceOf :: Pattern PrinterState AST (AST, AST) instanceOf = mkPattern match where match (InstanceOf _ val ty) = Just (val, ty) - match _ = Nothing + match _ = Nothing unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen unary' op mkStr = Wrap match (<>) @@ -232,7 +232,7 @@ negateOperator :: (Emit gen) => Operator PrinterState AST gen negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-") where isNegate (Unary _ Negate _) = True - isNegate _ = False + isNegate _ = False binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2) diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index cce54333ed..482bc99331 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -3,10 +3,9 @@ module Language.PureScript.CoreImp.AST where import Prelude -import Control.Monad ((>=>)) -import Control.Monad.Identity (Identity (..), runIdentity) - -- import Data.List.NonEmpty qualified as NEL (NonEmpty) -import Data.Text (Text) +import Control.Monad ((>=>)) +import Control.Monad.Identity (Identity(..), runIdentity) +import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments (Comment) diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index d679465269..34c9a287a5 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -4,24 +4,22 @@ module Language.PureScript.Interactive.IO (findNodeProcess, readNodeProcessWithE import Prelude -import Control.Monad (msum, void) -import Control.Monad.Error.Class (throwError) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Functor ((<&>)) -import Data.List (isInfixOf) -import Protolude (note) -import System.Directory (XdgDirectory (..), - createDirectoryIfMissing, - doesFileExist, findExecutable, - getAppUserDataDirectory, - getXdgDirectory) -import System.Exit (ExitCode (ExitFailure, ExitSuccess)) -import System.FilePath (takeDirectory, ()) -import System.Process (readProcessWithExitCode) -import Text.Parsec (many1, parse, sepBy, ()) -import Text.Parsec.Char (char, digit) +import Control.Monad (msum, void) +import Control.Monad.Error.Class (throwError) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Functor ((<&>)) +import Data.List (isInfixOf) +import System.Directory (XdgDirectory (..), createDirectoryIfMissing, + getAppUserDataDirectory, getXdgDirectory, + findExecutable, doesFileExist) +import System.Exit (ExitCode(ExitFailure, ExitSuccess)) +import System.FilePath (takeDirectory, ()) +import System.Process (readProcessWithExitCode) +import Text.Parsec ((), many1, parse, sepBy) +import Text.Parsec.Char (char, digit) +import Protolude (note) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -44,7 +42,7 @@ findNodeVersion node = do result <- readProcessWithExitCode node ["--version"] "" return $ case result of (ExitSuccess, version, _) -> Just version - (ExitFailure _, _, _) -> Nothing + (ExitFailure _, _, _) -> Nothing readNodeProcessWithExitCode :: Maybe FilePath -> [String] -> String -> IO (Either String (ExitCode, String, String)) readNodeProcessWithExitCode nodePath nodeArgs stdin = runExceptT $ do diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 8a294e60de..d90fe8ea4f 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -201,10 +201,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = targetFilename :: ModuleName -> CodegenTarget -> FilePath targetFilename mn = \case - JS -> outputFilename mn "index.js" + JS -> outputFilename mn "index.js" JSSourceMap -> outputFilename mn "index.js.map" - CoreFn -> outputFilename mn "corefn.json" - Docs -> outputFilename mn "docs.json" + CoreFn -> outputFilename mn "corefn.json" + Docs -> outputFilename mn "docs.json" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -334,13 +334,11 @@ checkForeignDecls :: CF.Module ann -> FilePath -> Make (Either MultipleErrors (F checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path - let parseResult :: Either MultipleErrors JS.JSAST parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path traverse checkFFI parseResult - where mname = CF.moduleName m modSS = CF.moduleSourceSpan m @@ -369,9 +367,9 @@ checkForeignDecls m path = do pure (ESModule, esExports) foreignIdents <- either - errorInvalidForeignIdentifiers - (pure . S.fromList) - (parseIdents foreignIdentsStrs) + errorInvalidForeignIdentifiers + (pure . S.fromList) + (parseIdents foreignIdentsStrs) let importedIdents = S.fromList (CF.moduleForeign m) let unusedFFI = foreignIdents S.\\ importedIdents @@ -383,7 +381,6 @@ checkForeignDecls m path = do unless (null missingFFI) $ throwError . errorMessage' modSS . MissingFFIImplementations mname $ S.toList missingFFI - pure (foreignModuleType, foreignIdents) errorParsingModule :: Bundle.ErrorMessage -> MultipleErrors From 29c95746dff45787d451b52dec6682e385d5a318 Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 10:39:24 +0200 Subject: [PATCH 059/105] ws 4 --- src/Language/PureScript/CoreImp/AST.hs | 40 +++++++++++++------------- tests/TestUtils.hs | 6 ++-- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 482bc99331..adedeb4369 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -134,16 +134,16 @@ withSourceSpan withSpan = go where go (ModuleAccessor _ s1 s2) = ModuleAccessor ss s1 s2 go (Block _ js) = Block ss js go (VariableIntroduction _ name j) = VariableIntroduction ss name j - go (Assignment _ j1 j2) = Assignment ss j1 j2 - go (While _ j1 j2) = While ss j1 j2 - go (For _ name j1 j2 j3) = For ss name j1 j2 j3 - go (ForIn _ name j1 j2) = ForIn ss name j1 j2 - go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3 - go (Return _ js) = Return ss js - go (ReturnNoResult _) = ReturnNoResult ss - go (Throw _ js) = Throw ss js - go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 - go c@Comment {} = c + go (Assignment _ j1 j2) = Assignment ss j1 j2 + go (While _ j1 j2) = While ss j1 j2 + go (For _ name j1 j2 j3) = For ss name j1 j2 j3 + go (ForIn _ name j1 j2) = ForIn ss name j1 j2 + go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3 + go (Return _ js) = Return ss js + go (ReturnNoResult _) = ReturnNoResult ss + go (Throw _ js) = Throw ss js + go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 + go c@Comment{} = c -- go (Import _ ident from) = Import ss ident from -- go (Export _ idents from) = Export ss idents from @@ -164,16 +164,16 @@ getSourceSpan = go where go (ModuleAccessor ss _ _) = ss go (Block ss _) = ss go (VariableIntroduction ss _ _) = ss - go (Assignment ss _ _) = ss - go (While ss _ _) = ss - go (For ss _ _ _ _) = ss - go (ForIn ss _ _ _) = ss - go (IfElse ss _ _ _) = ss - go (Return ss _) = ss - go (ReturnNoResult ss) = ss - go (Throw ss _) = ss - go (InstanceOf ss _ _) = ss - go (Comment _ _) = Nothing + go (Assignment ss _ _) = ss + go (While ss _ _) = ss + go (For ss _ _ _ _) = ss + go (ForIn ss _ _ _) = ss + go (IfElse ss _ _ _) = ss + go (Return ss _) = ss + go (ReturnNoResult ss) = ss + go (Throw ss _) = ss + go (InstanceOf ss _ _) = ss + go (Comment _ _) = Nothing -- go (Import ss _ _) = ss -- go (Export ss _ _) = ss diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 5c8a961cca..146093c452 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -114,7 +114,7 @@ getSupportModuleTuples = do fileContents <- readInput pursFiles modules <- runExceptT $ ExceptT . return $ CST.parseFromFiles id fileContents case modules of - Right ms -> return (fmap (fmap snd) ms) + Right ms -> return (fmap (fmap snd) ms) Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) getSupportModuleNames :: IO [T.Text] @@ -136,8 +136,8 @@ createOutputFile logfileName = do openFile (tmp logpath logfileName) WriteMode data SupportModules = SupportModules - { supportModules :: [P.Module] - , supportExterns :: [P.ExternsFile] + { supportModules :: [P.Module] + , supportExterns :: [P.ExternsFile] , supportForeigns :: M.Map P.ModuleName FilePath } From 049673d0f834a169a6063021f15d78f53d66dfe9 Mon Sep 17 00:00:00 2001 From: usagi-z Date: Fri, 1 Sep 2023 14:16:48 +0200 Subject: [PATCH 060/105] ws 5 --- app/Command/REPL.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index c59086ffc0..eb254be45c 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Command.REPL (command) where @@ -27,8 +27,8 @@ import System.IO (hPutStrLn, stderr) -- | Command line options data PSCiOptions = PSCiOptions - { psciInputGlob :: [String] - , psciBackend :: Backend + { psciInputGlob :: [String] + , psciBackend :: Backend } inputFile :: Opts.Parser FilePath @@ -84,11 +84,11 @@ pasteMode = -- | All of the functions required to implement a PSCi backend data Backend = forall state. Backend - { _backendSetup :: IO state + { _backendSetup :: IO state -- ^ Initialize, and call the continuation when the backend is ready - , _backendEval :: state -> String -> IO () + , _backendEval :: state -> String -> IO () -- ^ Evaluate JavaScript code - , _backendReload :: state -> IO () + , _backendReload :: state -> IO () -- ^ Reload the compiled code , _backendShutdown :: state -> IO () -- ^ Shut down the backend From 6cca3e1a072abaa007a4de2e817ebe7ed9567bdc Mon Sep 17 00:00:00 2001 From: usagi-z Date: Mon, 4 Sep 2023 10:05:06 +0200 Subject: [PATCH 061/105] fix tests at the cost of marking version as a company fork --- src/Language/PureScript/Externs.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 6f3deddfb6..aebd84b019 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -167,7 +167,7 @@ currentVersion = showVersion Paths.version ++ "-restaumatic2" -- version. externsIsCurrentVersion :: ExternsFile -> Bool externsIsCurrentVersion ef = - T.unpack (efVersion ef) == currentVersion + T.unpack (efVersion ef) == showVersion Paths.version -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment @@ -210,7 +210,7 @@ moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where - efVersion = T.pack currentVersion + efVersion = T.pack (showVersion Paths.version) efModuleName = mn efExports = map renameRef exps efImports = mapMaybe importDecl ds From 4e1934b6bda77da5c24dd10d3c7cc87d5079a528 Mon Sep 17 00:00:00 2001 From: usagi-z Date: Mon, 4 Sep 2023 11:29:49 +0200 Subject: [PATCH 062/105] silence hlint --- tests/TestBundle.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index bff8f30d5a..626344e288 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -53,7 +53,7 @@ assertBundles support inputFiles outputFile = do Right _ -> do jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir let entryPoint = modulesDir "index.cjs" - let entryModule = map (`ModuleIdentifier` Regular) ["Main"] + let entryModule = [(`ModuleIdentifier` Regular) "Main"] bundled <- runExceptT $ do input <- forM jsFiles $ \filename -> do js <- liftIO $ readUTF8File filename From 60bf48242c4d29aca71ac24f378a58ddbfa80772 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Tue, 5 Sep 2023 13:34:56 +0000 Subject: [PATCH 063/105] Use IsSymbol Ident --- src/Language/PureScript/Constants/Libs.hs | 5 +++-- src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 833176f84f..c51243f6fb 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -1,13 +1,14 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TemplateHaskell #-} + -- | Various constants which refer to things in the Prelude and other core libraries module Language.PureScript.Constants.Libs where import Protolude qualified as P import Data.String (IsString) -import Language.PureScript.PSString (PSString) import Language.PureScript.Constants.TH qualified as TH +import Language.PureScript.PSString (PSString) -- Core lib values @@ -166,7 +167,7 @@ $(TH.declare do TH.mod "Data.Symbol" do TH.cls "IsSymbol" - TH.asIdent do TH.var "IsSymbolDict" + TH.asIdent do TH.var "IsSymbol" -- purescript-arrays diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 2176dbfcaa..30838e14b2 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -39,7 +39,7 @@ optimizeRecordGetField (App _ (Var _ C.I_hasFieldRecord) (App _ - (Var _ C.I_IsSymbolDict) + (Var _ C.I_IsSymbol) (Literal _ (ObjectLiteral [ ("reflectSymbol", Abs _ _ (Literal _ (StringLiteral label))) From 6050c5cf22564ca2f79956ab7a823467902d1341 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Tue, 5 Sep 2023 13:50:17 +0000 Subject: [PATCH 064/105] Add pattern by hand --- src/Language/PureScript/Constants/Libs.hs | 4 ++++ src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index c51243f6fb..0b44d3e408 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -9,6 +9,7 @@ import Protolude qualified as P import Data.String (IsString) import Language.PureScript.Constants.TH qualified as TH import Language.PureScript.PSString (PSString) +import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..)) -- Core lib values @@ -273,3 +274,6 @@ $(TH.declare do TH.var "hasFieldRecord" ) + +pattern IsSymbolDict :: Qualified Ident +pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict") diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 30838e14b2..9e2c9fa37c 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -39,7 +39,7 @@ optimizeRecordGetField (App _ (Var _ C.I_hasFieldRecord) (App _ - (Var _ C.I_IsSymbol) + (Var _ C.IsSymbolDict) (Literal _ (ObjectLiteral [ ("reflectSymbol", Abs _ _ (Literal _ (StringLiteral label))) From 85bd4c3151e59a9e9ceac8d4fe80866274266101 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Tue, 5 Sep 2023 15:04:32 +0000 Subject: [PATCH 065/105] fix currentVersion --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index aebd84b019..df83afefc9 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -161,7 +161,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic2" +currentVersion = showVersion Paths.version ++ "-restaumatic1" -- | Check whether the version in an externs file matches the currently running -- version. From 56856253c211d275ce18ee93432bde2fdf72aea3 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Wed, 6 Sep 2023 06:24:51 +0000 Subject: [PATCH 066/105] Revert currentVersion --- src/Language/PureScript/Externs.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index df83afefc9..8973bc3a21 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -167,7 +167,7 @@ currentVersion = showVersion Paths.version ++ "-restaumatic1" -- version. externsIsCurrentVersion :: ExternsFile -> Bool externsIsCurrentVersion ef = - T.unpack (efVersion ef) == showVersion Paths.version + T.unpack (efVersion ef) == currentVersion -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment @@ -210,7 +210,7 @@ moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where - efVersion = T.pack (showVersion Paths.version) + efVersion = T.pack currentVersion efModuleName = mn efExports = map renameRef exps efImports = mapMaybe importDecl ds From 71b85d3f4337586c5875a7a48e318aa617b44be1 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Wed, 6 Sep 2023 07:35:10 +0000 Subject: [PATCH 067/105] Fix version used by IDE --- src/Language/PureScript/Ide/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 120c2da4f6..1936626665 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -40,7 +40,7 @@ readExternFile fp = do _ -> throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) where - version = toS (showVersion P.version) + version = toS (showVersion P.currentVersion) convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = From 62d066101156528948145ddd40758ca1b2f9ece1 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Wed, 6 Sep 2023 07:47:58 +0000 Subject: [PATCH 068/105] Remove Show --- src/Language/PureScript/Ide/Externs.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 1936626665..b14f3d8b78 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -10,7 +10,6 @@ import Protolude hiding (to, from, (&)) import Codec.CBOR.Term as Term import Control.Lens (preview, view, (&), (^.)) import "monad-logger" Control.Monad.Logger (MonadLogger, logErrorN) -import Data.Version (showVersion) import Data.Text qualified as Text import Language.PureScript qualified as P import Language.PureScript.Make.Monad qualified as Make @@ -40,7 +39,7 @@ readExternFile fp = do _ -> throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) where - version = toS (showVersion P.currentVersion) + version = toS P.currentVersion convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = From 85f9dff8003f60c023575972b7079eb0f3ee71ef Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Wed, 6 Sep 2023 09:14:37 +0000 Subject: [PATCH 069/105] Cleanup Github Workfows --- .github/workflows/ci.yml | 82 ++++++++++++++++++++-------------------- 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 64bb375dcb..d0f18c0ff1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,9 +2,9 @@ name: "CI" on: push: - branches: [ "master", "restaumatic", "restaumatic-0.15.10" ] + branches: ["master", "restaumatic", "restaumatic-0.15.10"] pull_request: - branches: [ "master" ] + branches: ["master", "restaumatic"] paths: - .github/workflows/**/*.yml - app/**/* @@ -23,7 +23,7 @@ on: - update-changelog.hs - weeder.dhall release: - types: [ "published" ] + types: ["published"] defaults: run: @@ -58,8 +58,6 @@ jobs: image: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 - os: ["macOS-11"] - os: ["windows-2019"] - - os: ["self-hosted", "macos", "ARM64"] - - os: ["self-hosted", "Linux", "ARM64"] runs-on: "${{ matrix.os }}" container: "${{ matrix.image }}" @@ -82,7 +80,6 @@ jobs: with: node-version: "16" - - id: "haskell" name: "(Non-Linux only) Install Haskell" # Note: here we exclude the self-hosted runners because this action does not work on ARM @@ -198,11 +195,15 @@ jobs: - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" - # This requires the gh command line tool to be installed on our - # self-hosted runners - env: - GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}" - run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" + # Astonishingly, GitHub doesn't currently maintain a first-party action + # for uploading assets to GitHub releases! This is the best third-party + # one I could find, but as this step handles a token, it seems + # particularly important that we lock it down to a specific audited + # version, instead of a tag like the other steps. + uses: "AButler/upload-release-assets@ec6d3263266dc57eb6645b5f75e827987f7c217d" + with: + repo-token: "${{ secrets.GITHUB_TOKEN }}" + files: "sdist-test/bundle/*.{tar.gz,sha}" lint: runs-on: "ubuntu-latest" @@ -223,7 +224,6 @@ jobs: echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - - name: "Fix working directory ownership" run: | chown root:root . @@ -269,32 +269,32 @@ jobs: - run: "ci/fix-home stack exec weeder" - make-prerelease: - runs-on: "ubuntu-latest" - needs: - - "build" - - "lint" - if: "${{ github.event_name == 'push' && needs.build.outputs.do-not-prerelease != 'true' }}" - steps: - - uses: "actions/download-artifact@v3" - - uses: "ncipollo/release-action@v1.10.0" - with: - tag: "v${{ needs.build.outputs.version }}" - artifacts: "*-bundle/*" - prerelease: true - body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." - - uses: "actions/checkout@v3" - - uses: "actions/setup-node@v3" - with: - node-version: "16.x" - registry-url: "https://registry.npmjs.org" - - name: "Publish npm package" - working-directory: "npm-package" - env: - BUILD_VERSION: "${{ needs.build.outputs.version }}" - NODE_AUTH_TOKEN: "${{ secrets.NPM_TOKEN }}" - run: | - src_version=$(node -pe 'require("./package.json").version') - npm version --allow-same-version "$BUILD_VERSION" - sed -i -e "s/--purs-ver=${src_version//./\\.}/--purs-ver=$BUILD_VERSION/" package.json - npm publish --tag next +;13u # make-prerelease: + # runs-on: "ubuntu-latest" + # needs: + # - "build" + # - "lint" + # if: "${{ github.event_name == 'push' && needs.build.outputs.do-not-prerelease != 'true' }}" + # steps: + # - uses: "actions/download-artifact@v3" + # - uses: "ncipollo/release-action@v1.10.0" + # with: + # tag: "v${{ needs.build.outputs.version }}" + # artifacts: "*-bundle/*" + # prerelease: true + # body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." + # - uses: "actions/checkout@v3" + # - uses: "actions/setup-node@v3" + # with: + # node-version: "16.x" + # registry-url: "https://registry.npmjs.org" + # - name: "Publish npm package" + # working-directory: "npm-package" + # env: + # BUILD_VERSION: "${{ needs.build.outputs.version }}" + # NODE_AUTH_TOKEN: "${{ secrets.NPM_TOKEN }}" + # run: | + # src_version=$(node -pe 'require("./package.json").version') + # npm version --allow-same-version "$BUILD_VERSION" + # sed -i -e "s/--purs-ver=${src_version//./\\.}/--purs-ver=$BUILD_VERSION/" package.json + # npm publish --tag next From 919d2fe8de446b81e12179cf5b6c7ad823579333 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Wed, 6 Sep 2023 09:15:18 +0000 Subject: [PATCH 070/105] Remove ;13u --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d0f18c0ff1..570526f800 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -269,7 +269,7 @@ jobs: - run: "ci/fix-home stack exec weeder" -;13u # make-prerelease: + # make-prerelease: # runs-on: "ubuntu-latest" # needs: # - "build" From 6ac5ae588586047ddd6aa68b13dd1af4f6d1d066 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Wed, 13 Sep 2023 10:43:52 +0200 Subject: [PATCH 071/105] Update ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 570526f800..d7d635e514 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,7 +2,7 @@ name: "CI" on: push: - branches: ["master", "restaumatic", "restaumatic-0.15.10"] + branches: ["master", "restaumatic"] pull_request: branches: ["master", "restaumatic"] paths: From 4827f7946605ed759bb65415eae7cbba94913dbd Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 22 Jan 2024 16:17:53 +0100 Subject: [PATCH 072/105] Update Externs.hs --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 8973bc3a21..c14ffad80d 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -161,7 +161,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic1" +currentVersion = showVersion Paths.version ++ "-restaumatic3" -- | Check whether the version in an externs file matches the currently running -- version. From 4ac46a598f0a53a90515a7151dfb8ff09a0e346b Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Tue, 13 Feb 2024 17:42:23 +0000 Subject: [PATCH 073/105] set currentVersion to restaumatic1 --- src/Language/PureScript/Externs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index c5dec928ca..db57b2c2e0 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -163,7 +163,7 @@ data ExternsDeclaration = instance Serialise ExternsDeclaration currentVersion :: String -currentVersion = showVersion Paths.version ++ "-restaumatic3" +currentVersion = showVersion Paths.version ++ "-restaumatic1" -- | Check whether the version in an externs file matches the currently running -- version. From 3377aa0480c4a642726af86189ce57fcd2e3743e Mon Sep 17 00:00:00 2001 From: Alex Date: Tue, 26 Dec 2023 12:24:25 +0500 Subject: [PATCH 074/105] Make cut-off, the main piece --- purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 2 +- .../PureScript/AST/Declarations/ChainId.hs | 2 +- src/Language/PureScript/Docs/Collect.hs | 2 +- src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Externs.hs | 6 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Make.hs | 124 +++- src/Language/PureScript/Make/Actions.hs | 69 ++- src/Language/PureScript/Make/BuildPlan.hs | 228 +++++--- src/Language/PureScript/Make/Cache.hs | 39 +- src/Language/PureScript/Make/ExternsDiff.hs | 440 ++++++++++++++ src/Language/PureScript/Make/Monad.hs | 18 +- tests/TestMake.hs | 543 ++++++++++++++---- tests/TestUtils.hs | 2 +- 15 files changed, 1250 insertions(+), 230 deletions(-) create mode 100644 src/Language/PureScript/Make/ExternsDiff.hs diff --git a/purescript.cabal b/purescript.cabal index b867ef00b1..7957251ac8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -336,6 +336,7 @@ library Language.PureScript.Make.Actions Language.PureScript.Make.BuildPlan Language.PureScript.Make.Cache + Language.PureScript.Make.ExternsDiff Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index cf0c83a42d..7184cbb812 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -165,7 +165,7 @@ importPrim = . addDefaultImport (Qualified ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed - deriving (Show, Generic, NFData, Serialise) + deriving (Eq, Show, Generic, NFData, Serialise) -- | -- An item in a list of explicit imports or exports diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs index aacfc11fe8..5997c55b04 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -1,5 +1,5 @@ module Language.PureScript.AST.Declarations.ChainId - ( ChainId + ( ChainId(..) , mkChainId ) where diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 0da65d2251..ad538c1ae4 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -96,7 +96,7 @@ compileForDocs outputDir inputFiles = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions outputDir filePathMap foreigns False) - { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "Compiling documentation for " + { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for " } P.make makeActions (map snd ms) either throwError return result diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..0c087e9cf1 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -82,7 +82,7 @@ data FunctionalDependency = FunctionalDependency -- ^ the type arguments which determine the determined type arguments , fdDetermined :: [Int] -- ^ the determined type arguments - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance NFData FunctionalDependency instance Serialise FunctionalDependency diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index db57b2c2e0..a949aacae6 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -90,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) instance Serialise ExternsFixity @@ -105,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) instance Serialise ExternsTypeFixity @@ -158,7 +158,7 @@ data ExternsDeclaration = , edInstanceNameSource :: NameSource , edInstanceSourceSpan :: SourceSpan } - deriving (Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData) instance Serialise ExternsDeclaration diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 5f88b079c3..2650cba284 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -79,7 +79,7 @@ make -> P.Make ([P.ExternsFile], P.Environment) make ms = do foreignFiles <- P.inferForeignModules filePathMap - externs <- P.make (buildActions foreignFiles) (map snd ms) + externs <- P.make' (buildActions foreignFiles) (map snd ms) return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs) where buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5228dc86e6..8d0212e456 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -4,6 +4,8 @@ module Language.PureScript.Make rebuildModule , rebuildModule' , make + , make' + , makeImp , inferForeignModules , module Monad , module Actions @@ -27,7 +29,7 @@ import Data.Function (on) import Data.Foldable (fold, for_) import Data.List (foldl', sortOn) import Data.List.NonEmpty qualified as NEL -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T @@ -37,16 +39,17 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Convert qualified as Docs import Language.PureScript.Environment (initEnvironment) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) import Language.PureScript.Linter (Name(..), lint, lintImports) import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) -import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName) +import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName) import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult) import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad @@ -56,7 +59,6 @@ import System.FilePath (replaceExtension) -- | Rebuild a single module. -- --- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -133,23 +135,50 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ Right d -> d evalSupplyT nextVar'' $ codegen renamed docs exts + -- evaluate $ trace ("\n===== externs: " <> show moduleName <> ":\n" <> show exts) () return exts --- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file +-- and an @externs.cbor@ file. -- --- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without --- having to typecheck those modules again. +-- If timestamps or hashes have not changed, existing externs files can be used +-- to provide upstream modules' types without having to typecheck those modules +-- again. +-- +-- This version will collect an return externs only of modules that were used +-- during the build. make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] -make ma@MakeActions{..} ms = do +make ma ms = makeImp ma ms False + +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file +-- and an @externs.cbor@ file. +-- +-- If timestamps or hashes have not changed, existing externs files can be used +-- to provide upstream modules' types without having to typecheck those modules +-- again. +-- +-- This version will collect an return all externs of all passed modules. +make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [CST.PartialResult Module] + -> m [ExternsFile] +make' ma ms = makeImp ma ms True + +makeImp :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [CST.PartialResult Module] + -> Bool + -> m [ExternsFile] +makeImp ma@MakeActions{..} ms collectAll = do checkModuleNames cacheDb <- readCacheDb (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms - (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) + (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) collectAll -- Limit concurrent module builds to the number of capabilities as -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. @@ -160,16 +189,19 @@ make ma@MakeActions{..} ms = do let concurrency = max 1 capabilities lock <- C.newQSem concurrency + let sortedModuleNames = getModuleName . CST.resPartial <$> sorted let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted let totalModuleCount = length toBeRebuilt for_ toBeRebuilt $ \m -> fork $ do + -- evaluate $ trace ("resPartial:" <> show (CST.resPartial $ m)) () + -- evaluate $ trace ("resFull:" <> show (CST.resFull $ m)) () let moduleName = getModuleName . CST.resPartial $ m let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) buildModule lock buildPlan moduleName totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) - (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) + (deps `inOrderOf` sortedModuleNames) -- Prevent hanging on other modules when there is an internal error -- (the exception is thrown, but other threads waiting on MVars are released) @@ -179,7 +211,7 @@ make ma@MakeActions{..} ms = do (failures, successes) <- let splitResults = \case - BuildJobSucceeded _ exts -> + BuildJobSucceeded _ exts _ -> Right exts BuildJobFailed errs -> Left errs @@ -195,7 +227,6 @@ make ma@MakeActions{..} ms = do -- If generating docs, also generate them for the Prim modules outputPrimDocs - -- All threads have completed, rethrow any caught errors. let errors = M.elems failures unless (null errors) $ throwError (mconcat errors) @@ -203,10 +234,14 @@ make ma@MakeActions{..} ms = do -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. - let lookupResult mn = - fromMaybe (internalError "make: module not found in results") + let lookupResult mn@(ModuleName name) = + fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name) $ M.lookup mn successes - return (map (lookupResult . getModuleName . CST.resPartial) sorted) + + if collectAll then + pure $ map lookupResult sortedModuleNames + else + pure $ mapMaybe (flip M.lookup successes) sortedModuleNames where checkModuleNames :: m () @@ -251,7 +286,32 @@ make ma@MakeActions{..} ms = do mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps case mexterns of - Just (_, externs) -> do + Just (_, depsDiffExterns) -> do + let externs = fst <$> depsDiffExterns + --evaluate $ trace ("diff:" <> show moduleName <> ":" <> show (snd <$> depsDiffExterns)) () + --evaluate $ trace ("check diff:" <> show moduleName <> ":" <> show (isNothing $ traverse snd depsDiffExterns)) () + let prevResult = BuildPlan.getPrevResult buildPlan moduleName + let depsDiffs = traverse snd depsDiffExterns + let maySkipBuild moduleIndex + -- Just exts <- BuildPlan.getPrevResult buildPlan moduleName + -- we may skip built only for up-to-date modules + | Just (True, exts) <- prevResult + -- check if no dep's externs have changed + -- if one of the diffs is Nothing means we can not check and need to rebuild + --, Just False <- checkDiffs m <$> traverse snd depsDiffExterns = do + , Just False <- checkDiffs m <$> depsDiffs = do + -- We should update modification times to mark existing + -- compilation results as actual. If it fails to update timestamp + -- on any of exiting codegen targets, it will run the build process. + updated <- updateOutputTimestamp moduleName + --evaluate $ trace ("updated:" <> show updated <> ":" <> show moduleName) () + if updated then do + progress $ SkippingModule moduleName moduleIndex + pure $ Just (exts, MultipleErrors [], Just (emptyDiff moduleName)) + else + pure Nothing + | otherwise = pure Nothing + -- We need to ensure that all dependencies have been included in Env C.modifyMVar_ (bpEnv buildPlan) $ \env -> do let @@ -265,19 +325,25 @@ make ma@MakeActions{..} ms = do idx <- C.takeMVar (bpIndex buildPlan) C.putMVar (bpIndex buildPlan) (idx + 1) - -- Bracket all of the per-module work behind the semaphore, including - -- forcing the result. This is done to limit concurrency and keep - -- memory usage down; see comments above. - (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do - -- Eventlog markers for profiling; see debug/eventlog.js - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" - -- Force the externs and warnings to avoid retaining excess module - -- data after the module is finished compiling. - extsAndWarnings <- evaluate . force <=< listen $ do - rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" - return extsAndWarnings - return $ BuildJobSucceeded (pwarnings' <> warnings) exts + (exts, warnings, diff) <- do + let doBuild = do + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + return extsAndWarnings + let diff = diffExterns exts <$> (snd <$> prevResult) <*> depsDiffs + pure (exts, warnings, diff) + maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure + return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff + Nothing -> return BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index d90fe8ea4f..952925689d 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -13,7 +13,7 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Monad (unless, when) +import Control.Monad (guard, unless, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (asks) @@ -46,8 +46,8 @@ import Language.PureScript.Docs.Prim qualified as Docs.Prim import Language.PureScript.Docs.Types qualified as Docs import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') import Language.PureScript.Externs (ExternsFile, externsFileName) -import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile) -import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache) +import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile) +import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVersion, fromCacheDbVersioned, normaliseForCache, toCacheDbVersioned) import Language.PureScript.Names (Ident(..), ModuleName, runModuleName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.Pretty.Common (SMap(..)) @@ -71,16 +71,26 @@ data RebuildPolicy data ProgressMessage = CompilingModule ModuleName (Maybe (Int, Int)) -- ^ Compilation started for the specified module + | SkippingModule ModuleName (Maybe (Int, Int)) deriving (Show, Eq, Ord) -- | Render a progress message renderProgressMessage :: T.Text -> ProgressMessage -> T.Text -renderProgressMessage infx (CompilingModule mn mi) = - T.concat - [ renderProgressIndex mi - , infx - , runModuleName mn - ] +renderProgressMessage infx msg = case msg of + CompilingModule mn mi -> + T.concat + [ renderProgressIndex mi + , "Compiling " + , infx + , runModuleName mn + ] + SkippingModule mn mi -> + T.concat + [renderProgressIndex mi + , "Skipping " + , infx + , runModuleName mn + ] where renderProgressIndex :: Maybe (Int, Int) -> T.Text renderProgressIndex = maybe "" $ \(start, end) -> @@ -109,6 +119,9 @@ data MakeActions m = MakeActions -- externs file, or if any of the requested codegen targets were not produced -- the last time this module was compiled, this function must return Nothing; -- this indicates that the module will have to be recompiled. + , updateOutputTimestamp :: ModuleName -> m Bool + -- ^ Updates the modification time of existing output files to mark them as + -- actual. , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. @@ -141,8 +154,14 @@ readCacheDb' => FilePath -- ^ The path to the output directory -> m CacheDb -readCacheDb' outputDir = - fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) +readCacheDb' outputDir = do + --fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) + --fromMaybe mempty <$> (fmap fromCacheDbVersioned <$> readJSONFile (cacheDbFile outputDir)) + mdb <- readJSONFile (cacheDbFile outputDir) + pure $ fromMaybe mempty $ do + db <- mdb + guard $ cacheDbIsCurrentVersion db + pure $ fromCacheDbVersioned db writeCacheDb' :: (MonadIO m, MonadError MultipleErrors m) @@ -151,7 +170,7 @@ writeCacheDb' -> CacheDb -- ^ The CacheDb to be written -> m () -writeCacheDb' = writeJSONFile . cacheDbFile +writeCacheDb' = (. toCacheDbVersioned) . writeJSONFile . cacheDbFile writePackageJson' :: (MonadIO m, MonadError MultipleErrors m) @@ -174,7 +193,18 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs + MakeActions + getInputTimestampsAndHashes + getOutputTimestamp + updateOutputTimestamp + readExterns + codegen + ffiCodegen + progress + readCacheDb + writeCacheDb + writePackageJson + outputPrimDocs where getInputTimestampsAndHashes @@ -234,6 +264,17 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = then Just externsTimestamp else Nothing + updateOutputTimestamp :: ModuleName -> Make Bool + updateOutputTimestamp mn = do + curTime <- getCurrentTime + ok <- setTimestamp (outputFilename mn externsFileName) curTime + -- then update all actual codegen targets + codegenTargets <- asks optionsCodegenTargets + let outputPaths = fmap (targetFilename mn) (S.toList codegenTargets) + results <- traverse (flip setTimestamp curTime) outputPaths + -- if something goes wrong, something failed to update, return Nothing + pure $ and (ok : results) + readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do let path = outputDir T.unpack (runModuleName mn) externsFileName @@ -314,7 +355,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling " + progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "" readCacheDb :: Make CacheDb readCacheDb = readCacheDb' outputDir diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 3eba2359a3..38554fcec0 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,9 +1,9 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) - , buildJobSuccess , construct , getResult + , getPrevResult , collectResults , markComplete , needsRebuild @@ -11,15 +11,16 @@ module Language.PureScript.Make.BuildPlan import Prelude -import Control.Concurrent.Async.Lifted as A -import Control.Concurrent.Lifted as C +import Control.Concurrent.Async.Lifted qualified as A +import Control.Concurrent.Lifted qualified as C import Control.Monad.Base (liftBase) -import Control.Monad (foldM) +import Control.Monad (foldM, guard) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Foldable (foldl') import Data.Map qualified as M -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, catMaybes) +import Data.Set qualified as S +import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Language.PureScript.AST (Module, getModuleName) import Language.PureScript.Crash (internalError) @@ -28,6 +29,7 @@ import Language.PureScript.Errors (MultipleErrors(..)) import Language.PureScript.Externs (ExternsFile) import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged) +import Language.PureScript.Make.ExternsDiff (ExternsDiff, emptyDiff) import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) @@ -36,14 +38,14 @@ import System.Directory (getCurrentDirectory) -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt + , bpPreviousBuilt :: M.Map ModuleName (Bool, Prebuilt) , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int } data Prebuilt = Prebuilt - { pbModificationTime :: UTCTime - , pbExternsFile :: ExternsFile + { pbExternsFile :: ExternsFile } newtype BuildJob = BuildJob @@ -52,33 +54,43 @@ newtype BuildJob = BuildJob } data BuildJobResult - = BuildJobSucceeded !MultipleErrors !ExternsFile - -- ^ Succeeded, with warnings and externs + = BuildJobSucceeded !MultipleErrors !ExternsFile (Maybe ExternsDiff) + -- ^ Succeeded, with warnings and externs, also holds externs diff with + -- previous build result if any (lazily evaluated). -- | BuildJobFailed !MultipleErrors - -- ^ Failed, with errors + -- ^ Failed, with errors. | BuildJobSkipped - -- ^ The build job was not run, because an upstream build job failed + -- ^ The build job was not run, because an upstream build job failed. -buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) -buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) +type SuccessResult = (MultipleErrors, (ExternsFile, Maybe ExternsDiff)) + +buildJobSuccess :: BuildJobResult -> Maybe SuccessResult +buildJobSuccess (BuildJobSucceeded warnings externs diff) = Just (warnings, (externs, diff)) buildJobSuccess _ = Nothing -- | Information obtained about a particular module while constructing a build -- plan; used to decide whether a module needs rebuilding. data RebuildStatus = RebuildStatus - { statusModuleName :: ModuleName - , statusRebuildNever :: Bool - , statusNewCacheInfo :: Maybe CacheInfo + { rsModuleName :: ModuleName + , rsRebuildNever :: Bool + , rsNewCacheInfo :: Maybe CacheInfo -- ^ New cache info for this module which should be stored for subsequent -- incremental builds. A value of Nothing indicates that cache info for -- this module should not be stored in the build cache, because it is being -- rebuilt according to a RebuildPolicy instead. - , statusPrebuilt :: Maybe Prebuilt - -- ^ Prebuilt externs and timestamp for this module, if any. + , rsPrebuilt :: Maybe UTCTime + -- ^ Prebuilt timestamp (compilation time) for this module. + , rsUpToDate :: Bool + -- ^ Whether or not module (timestamp or content) changed since previous + -- compilation (checked against provided cache-db info). } +-- | Construct common error message indicating a bug in the internal logic +barrierError :: T.Text -> a +barrierError infx = internalError $ "make: " <> T.unpack infx <> " no barrier" + -- | Called when we finished compiling a module and want to report back the -- compilation result, as well as any potential errors that were thrown. markComplete @@ -88,8 +100,9 @@ markComplete -> BuildJobResult -> m () markComplete buildPlan moduleName result = do - let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) - putMVar rVar result + let BuildJob rVar = + fromMaybe (barrierError "markComplete") $ M.lookup moduleName (bpBuildJobs buildPlan) + C.putMVar rVar result -- | Whether or not the module with the given ModuleName needs to be rebuilt needsRebuild :: BuildPlan -> ModuleName -> Bool @@ -103,8 +116,10 @@ collectResults => BuildPlan -> m (M.Map ModuleName BuildJobResult) collectResults buildPlan = do - let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) - barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan + let mapExts exts = BuildJobSucceeded (MultipleErrors []) exts Nothing + let prebuiltResults = + M.map (mapExts . pbExternsFile) (bpPrebuilt buildPlan) + barrierResults <- traverse (C.readMVar . bjResult) $ bpBuildJobs buildPlan pure (M.union prebuiltResults barrierResults) -- | Gets the the build result for a given module name independent of whether it @@ -113,14 +128,23 @@ getResult :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> m (Maybe (MultipleErrors, ExternsFile)) + -> m (Maybe SuccessResult) getResult buildPlan moduleName = - case M.lookup moduleName (bpPrebuilt buildPlan) of - Just es -> - pure (Just (MultipleErrors [], pbExternsFile es)) + -- may bring back first lookup for bpPrebuilt + case M.lookup moduleName (bpBuildJobs buildPlan) of + Just bj -> + buildJobSuccess <$> C.readMVar (bjResult bj) Nothing -> do - r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) - pure $ buildJobSuccess r + let exts = pbExternsFile + $ fromMaybe (barrierError "getResult") + $ M.lookup moduleName (bpPrebuilt buildPlan) + pure (Just (MultipleErrors [], (exts, Just $ emptyDiff moduleName ))) + +-- | Gets preloaded previous built result for modules that are going to be built. This +-- will be used to skip compilation if dep's externs have not changed. +getPrevResult :: BuildPlan -> ModuleName -> Maybe (Bool, ExternsFile) +getPrevResult buildPlan moduleName = + fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) -- | Constructs a BuildPlan for the given module graph. -- @@ -131,26 +155,75 @@ construct => MakeActions m -> CacheDb -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) + -> Bool + -- ^ If True will preload all the externs, otherwise will load only needed for + -- the build. -> m (BuildPlan, CacheDb) -construct MakeActions{..} cacheDb (sorted, graph) = do +construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do let sortedModuleNames = map (getModuleName . CST.resPartial) sorted rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus - let prebuilt = - foldl' collectPrebuiltModules M.empty $ - mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses - let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames - buildJobs <- foldM makeBuildJob M.empty toBeRebuilt + + -- Split modules into those that have to be rebuilt and those that have a valid + -- prebuilt input. The Bool value in rebuildMap means if we may skip the + -- compilation (if externs of dependencies have not changed). If it is False we + -- should re-compile the module due to the following: the module's source have + -- changed or some of dependencies were compiled later than the module. + let (rebuildMap, prebuiltMap) = splitModules rebuildStatuses + + let toBeRebuilt = M.keys rebuildMap + + -- Set of all dependencies of modules to be rebuilt. + let allBuildDeps = S.unions (S.fromList . moduleDeps <$> toBeRebuilt) + let inBuildDeps = flip S.member allBuildDeps + + -- We only need prebuilt results for deps of the modules to be build. + let toLoadPrebuilt + | preloadAll = prebuiltMap + | otherwise = M.filterWithKey (const . inBuildDeps) prebuiltMap + + -- We will need previously built results for modules to be build + -- to skip rebuilding if deps have not changed. + let toLoadPrev = + M.mapMaybeWithKey + ( \mn prev -> do + -- We load previous build result for all up-to-date modules, and + -- also for changed modules that have dependants. + upToDate <- fst <$> prev + guard (upToDate || inBuildDeps mn) + prev + ) + rebuildMap + + (prebuiltLoad, prevLoad) <- + A.concurrently + (A.mapConcurrently id $ M.mapWithKey loadPrebuilt toLoadPrebuilt) + (A.mapConcurrently id $ M.mapWithKey + (\mn (up, ts) -> fmap (up,) <$> loadPrebuilt mn ts) toLoadPrev) + + let prebuilt = M.mapMaybe id prebuiltLoad + let previous = M.mapMaybe id prevLoad + + -- If for some reason (wrong version, files corruption) loading fails, + -- those modules should be rebuilt too. + let failedLoads = M.keys $ M.filter isNothing prebuiltLoad + buildJobs <- foldM makeBuildJob M.empty (toBeRebuilt <> failedLoads) + env <- C.newMVar primEnv idx <- C.newMVar 1 pure - ( BuildPlan prebuilt buildJobs env idx + ( BuildPlan prebuilt previous buildJobs env idx , let update = flip $ \s -> - M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + M.alter (const (rsNewCacheInfo s)) (rsModuleName s) in foldl' update cacheDb rebuildStatuses ) where + -- Timestamp here is just to ensure that we will try to load modules that + -- have previous built results available. + loadPrebuilt :: ModuleName -> UTCTime -> m (Maybe Prebuilt) + loadPrebuilt = const . fmap (fmap Prebuilt . snd) . readExterns + makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) @@ -160,56 +233,59 @@ construct MakeActions{..} cacheDb (sorted, graph) = do inputInfo <- getInputTimestampsAndHashes moduleName case inputInfo of Left RebuildNever -> do - prebuilt <- findExistingExtern moduleName + timestamp <- getOutputTimestamp moduleName pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = True - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = True + , rsPrebuilt = timestamp + , rsUpToDate = True + , rsNewCacheInfo = Nothing }) Left RebuildAlways -> do pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = Nothing - , statusNewCacheInfo = Nothing + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrebuilt = Nothing + , rsUpToDate = False + , rsNewCacheInfo = Nothing }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo - prebuilt <- - if isUpToDate - then findExistingExtern moduleName - else pure Nothing + timestamp <- getOutputTimestamp moduleName pure (RebuildStatus - { statusModuleName = moduleName - , statusRebuildNever = False - , statusPrebuilt = prebuilt - , statusNewCacheInfo = Just newCacheInfo + { rsModuleName = moduleName + , rsRebuildNever = False + , rsPrebuilt = timestamp + , rsUpToDate = isUpToDate + , rsNewCacheInfo = Just newCacheInfo }) - findExistingExtern :: ModuleName -> m (Maybe Prebuilt) - findExistingExtern moduleName = runMaybeT $ do - timestamp <- MaybeT $ getOutputTimestamp moduleName - externs <- MaybeT $ snd <$> readExterns moduleName - pure (Prebuilt timestamp externs) - - collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt - collectPrebuiltModules prev (moduleName, rebuildNever, pb) - | rebuildNever = M.insert moduleName pb prev - | otherwise = do - let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) - case traverse (fmap pbModificationTime . flip M.lookup prev) deps of - Nothing -> - -- If we end up here, one of the dependencies didn't exist in the - -- prebuilt map and so we know a dependency needs to be rebuilt, which - -- means we need to be rebuilt in turn. - prev - Just modTimes -> - case maximumMaybe modTimes of - Just depModTime | pbModificationTime pb < depModTime -> - prev - _ -> M.insert moduleName pb prev + moduleDeps = fromMaybe graphError . flip lookup graph + where + graphError = internalError "make: module not found in dependency graph." + + splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (Bool, UTCTime)), M.Map ModuleName UTCTime) + splitModules = foldl' collectByStatus (M.empty, M.empty) + + collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) + | Nothing <- mbPb = (M.insert mn Nothing build, prev) + | Just pb <- mbPb, not upToDate = toRebuild (False, pb) + | Just pb <- mbPb, rebuildNever = toPrebuilt pb + | Just pb <- mbPb = do + let deps = moduleDeps mn + let modTimes = map (flip M.lookup prev) deps + + case maximumMaybe (catMaybes modTimes) of + -- Check if any of deps where build later. This means we should + -- recompile even if the source is up-to-date. + Just depModTime | pb < depModTime -> toRebuild (False, pb) + -- If one of the deps is not in the prebuilt, we should rebuild. + _ | any isNothing modTimes -> toRebuild (upToDate, pb) + _ -> toPrebuilt pb + where + toRebuild v = (M.insert mn (Just v) build, prev) + toPrebuilt v = (build, M.insert mn v prev) maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 092544fa73..f703b18789 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -6,6 +6,9 @@ module Language.PureScript.Make.Cache , checkChanged , removeModules , normaliseForCache + , cacheDbIsCurrentVersion + , toCacheDbVersioned + , fromCacheDbVersioned ) where import Prelude @@ -23,14 +26,19 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Monoid (All(..)) import Data.Set (Set) -import Data.Text (Text) +import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) import System.FilePath qualified as FilePath +import Paths_purescript as Paths + import Language.PureScript.Names (ModuleName) +import Data.Version (showVersion) +import Data.Aeson ((.=)) +import Data.Aeson.Types ((.:)) digestToHex :: Digest a -> Text digestToHex = decodeUtf8 . convertToBase Base16 @@ -63,6 +71,35 @@ hash = ContentHash . Hash.hash type CacheDb = Map ModuleName CacheInfo +data CacheDbVersioned = CacheDbVersioned { cdbVersion :: Text, cdbModules :: CacheDb } + --deriving stock (Show) + deriving (Eq, Ord) + +instance Aeson.FromJSON CacheDbVersioned where + parseJSON = Aeson.withObject "CacheDb" $ \v -> + CacheDbVersioned + <$> v .: "version" + <*> v .: "modules" + +instance Aeson.ToJSON CacheDbVersioned where + toJSON CacheDbVersioned{..} = + Aeson.object + [ "version" .= cdbVersion + , "modules" .= cdbModules + ] + +cacheDbIsCurrentVersion :: CacheDbVersioned -> Bool +cacheDbIsCurrentVersion ef = + unpack (cdbVersion ef) == showVersion Paths.version + +toCacheDbVersioned :: CacheDb -> CacheDbVersioned +toCacheDbVersioned = + CacheDbVersioned (pack $ showVersion Paths.version) + +fromCacheDbVersioned :: CacheDbVersioned -> CacheDb +fromCacheDbVersioned = + cdbModules + -- | A CacheInfo contains all of the information we need to store about a -- particular module in the cache database. newtype CacheInfo = CacheInfo diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs new file mode 100644 index 0000000000..25dd6f8b15 --- /dev/null +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -0,0 +1,440 @@ +module Language.PureScript.Make.ExternsDiff + ( ExternsDiff + , emptyDiff + , diffExterns + , checkDiffs + ) where + +import Protolude hiding (check, moduleName, trace) + +import Data.Graph as G (graphFromEdges, reachable) +import Data.List qualified as L +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T + +import Language.PureScript.AST qualified as P +import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) +import Language.PureScript.Constants.Prim (primModules) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.Names (ModuleName) +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P + +type RefStatus = Bool + +data ExternsDiff = ExternsDiff + {edModuleName :: ModuleName, edRefs :: M.Map Ref RefStatus} + deriving (Show) + +-- | Empty diff means no effective difference between externs. +emptyDiff :: P.ModuleName -> ExternsDiff +emptyDiff mn = ExternsDiff mn mempty + +isRefRemoved :: RefStatus -> Bool +isRefRemoved = not + +-- Refs structure appropriate for storing and checking externs diffs. +data Ref + = TypeClassRef (P.ProperName 'P.ClassName) + | TypeOpRef (P.OpName 'P.TypeOpName) + | TypeRef (P.ProperName 'P.TypeName) + | -- we use separate ref for a data constructor and keep here origin type as well + ConstructorRef (P.ProperName 'P.TypeName) (P.ProperName 'P.ConstructorName) + | ValueRef P.Ident + | ValueOpRef (P.OpName 'P.ValueOpName) + | -- instance ref points to the class and types defined in the same module + -- TypeInstanceRef P.Ident (Maybe (P.ProperName 'P.ClassName)) [P.ProperName 'P.TypeName] + TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] + deriving (Show, Eq, Ord) + +diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff +diffExterns newExts oldExts depsDiffs = + ExternsDiff modName $ + addStatus (changedRefs <> affectedReExported <> allAffectedLocalRefs) + where + modName = P.efModuleName newExts + -- Marks if ref was removed + addStatus = M.fromSet (flip S.notMember removedSet) + + depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) + + -- To get changed reexported refs, we take those which were removed (not + -- present in new extern's exports) or changed in dependencies. + goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref + goRe _ = [] + + oldExports = concatMap goRe (P.efExports oldExts) + newReExports = concatMap goRe (P.efExports newExts) + checkRe (mn, ref) + | (mn, ref) `notElem` newReExports = True + | Just True <- elem ref <$> M.lookup mn depsDiffsMap = True + | otherwise = False + affectedReExported = S.fromList $ map snd $ filter checkRe oldExports + + getDecls = map stripDeclaration . P.efDeclarations + getTypeFixities = P.efTypeFixities + getFixities = P.efFixities + + -- Type class instances if changed (added/removed) indirectly effect back + -- the class or the types that are defined in the module, meaning if the + -- instance is added/removed we will recompile modules that use the type + -- class or (if the type class defined in another module) we have to + -- recompile modules that use types defined in this module affected by the + -- instance. + applyInstances (a, r, c, u) = + let checkType t (TypeRef t') = t' == t + checkType _ _ = False + uRefs = map fst u + go (TypeInstanceRef _ (clsMod, cls) types) + | clsRef <- TypeClassRef cls = + if clsMod == modName + then -- If the class is defined in this module we ensure that is marked as changed + maybe [] pure $ find ((==) clsRef) uRefs + else case S.member clsRef <$> M.lookup clsMod depsDiffsMap of + Just True -> + -- if the type class is in another module and it has + -- changed we don't need to care about instance types. + [] + -- Otherwise mark instance types as changed. + _ -> + foldMap (\t -> filter (checkType t) uRefs) types + go _ = mempty + affected = foldMap (S.fromList . go . fst) (a <> r <> c) + (uc, uu) = L.partition (flip S.member affected . fst) u + in (a, r, c <> uc, uu) + + declsSplit = + applyInstances $ + splitRefs (getDecls newExts) (getDecls oldExts) (externsDeclarationToRef modName) + + -- Make the context for fixity's data constructor search: place all + -- known refs in the map. + getRefsSet (a, r, c, u) = S.fromList $ map fst (a <> r <> c <> u) + fixityCtx = M.insert modName (getRefsSet declsSplit) depsDiffsMap + + -- Determine which declarations where directly changed or removed. + (_, removed, changed, unchangedRefs) = + foldl + zipTuple4 + (mempty, mempty, mempty, mempty) + [ declsSplit + , splitRefs (getFixities newExts) (getFixities oldExts) (pure . externsFixityToRef fixityCtx) + , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) + ] + + removedSet = S.fromList (map fst removed) + changedRefs = S.fromList $ map fst (removed <> changed) + + diffsMapWithLocal + | null changedRefs = depsDiffsMap + | otherwise = M.insert modName changedRefs depsDiffsMap + + -- Affected refs here are refs that depend on external or local changed refs. + -- + -- Rest local refs are refs that do not depend on external/local changed, but + -- may depend on affected local refs and need to be checked. + hasChangedDeps (mn, ref) = + Just True == (S.member ref <$> M.lookup mn diffsMapWithLocal) + (affectedLocalRefs, restLocalRefs) = + L.partition (any hasChangedDeps . snd) unchangedRefs + + -- Use graph to go though local refs and their cyclic dependencies on each other. + -- The graph includes only local refs that depend on other local refs. + toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) deps) + + vtxs = toNode <$> (map (map S.toList) restLocalRefs <> (map (const mempty) <$> affectedLocalRefs)) + (graph, fromVtx, toVtx) = G.graphFromEdges vtxs + refsGraph = do + (_, t, _) <- vtxs + let v = fromMaybe (internalError "diffExterns: vertex not found") $ toVtx t + let deps = G.reachable graph v + let toKey = (\(_, k, _) -> k) . fromVtx + pure (t, map toKey deps) + + -- Get local refs that depend on affected refs (affected refs are included + -- in the graph too). + allAffectedLocalRefs = + S.fromList $ + map fst $ + filter (any (flip elem (fst <$> affectedLocalRefs)) . snd) refsGraph + +checkDiffs :: P.Module -> [ExternsDiff] -> Bool +checkDiffs (P.Module _ _ _ decls exports) diffs + | all isEmpty diffs = False + | isNothing mbSearch = True + | null searches = False + | otherwise = checkReExports || checkUsage searches decls + where + mbSearch = makeSearches decls diffs + searches = fromMaybe S.empty mbSearch + -- Check if the module reexports any of searched refs. + checkReExports = flip (maybe False) exports $ any $ \case + P.ModuleRef _ mn -> not . null $ S.filter ((== Just mn) . fst) searches + _ -> False + +-- Goes though the module and try to find any usage of the refs. +checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool +checkUsage searches decls = foldMap findUsage decls /= mempty + where + findUsage decl = + let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty + in extr mempty decl + + toSearched = (,) <$> P.getQual <*> P.disqualify + + -- To check data constructors we remove an origin type from it. + emptyName = P.ProperName "" + stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n + stripCtorType x = x + + searches' = S.map (map stripCtorType) searches + check = (\x -> [x | x]) . flip S.member searches' . toSearched + + checkType = check . map TypeRef + checkTypeOp = check . map TypeOpRef + checkValue = check . map ValueRef + checkValueOp = check . map ValueOpRef + checkCtor = check . map (ConstructorRef emptyName) + checkClass = check . map TypeClassRef + + onTypes = P.everythingOnTypes (<>) $ \case + P.TypeConstructor _ n -> checkType n + P.TypeOp _ n -> checkTypeOp n + P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) + _ -> mempty + + foldCtor f (P.DataConstructorDeclaration _ _ vars) = + foldMap (f . snd) vars + + constraintTypes = + foldMap (\c -> P.constraintArgs c <> P.constraintKindArgs c) + + goDecl _ = \case + P.TypeDeclaration t -> onTypes (P.tydeclType t) + P.DataDeclaration _ _ _ _ ctors -> foldMap (foldCtor onTypes) ctors + P.TypeSynonymDeclaration _ _ _ t -> onTypes t + P.KindDeclaration _ _ _ t -> onTypes t + P.FixityDeclaration _ (Right (P.TypeFixity _ tn _)) -> + checkType tn + P.FixityDeclaration _ (Left (P.ValueFixity _ (P.Qualified by val) _)) -> + either (checkValue . P.Qualified by) (checkCtor . P.Qualified by) val + P.TypeClassDeclaration _ _ _ cs _ _ -> + foldMap onTypes (constraintTypes cs) + P.TypeInstanceDeclaration _ _ _ _ _ cs tc sts _ -> + foldMap onTypes (constraintTypes cs <> sts) <> checkClass tc + _ -> mempty + + isLocal scope ident = P.LocalIdent ident `S.member` scope + goExpr scope expr = case expr of + P.Var _ n + | P.isUnqualified n && isLocal scope (P.disqualify n) -> mempty + | otherwise -> checkValue n + P.Constructor _ n -> checkCtor n + P.Op _ n -> checkValueOp n + P.TypedValue _ _ t -> onTypes t + _ -> mempty + + goBinder _ binder = case binder of + P.ConstructorBinder _ n _ -> checkCtor n + P.OpBinder _ n -> checkValueOp n + _ -> mempty + +-- | Traverses imports and returns a set of refs to be searched though the +-- module. Returns Nothing if removed refs found in imports (no need to search +-- through the module). If an empty set is returned then no changes apply to the +-- module. +makeSearches :: [P.Declaration] -> [ExternsDiff] -> Maybe (Set (Maybe ModuleName, Ref)) +makeSearches decls depsDiffs = + foldM go mempty decls + where + diffsMap = M.fromList (map (liftM2 (,) edModuleName edRefs) depsDiffs) + + -- Add data constructors to refs if all are implicitly imported using (..). + getCtor n (ConstructorRef tn _) = tn == n + getCtor _ _ = False + getCtors n = M.keys . M.filterWithKey (const . getCtor n) + addCtors mn (P.TypeRef _ n Nothing) = maybe [] (getCtors n) (M.lookup mn diffsMap) + addCtors _ _ = [] + getRefs = (toRefs <>) . addCtors + + go s (P.ImportDeclaration _ mn dt qual) + -- We return Nothing if we encounter removed refs in imports. + | Just diffs <- M.lookup mn diffsMap + , removed <- M.keysSet $ M.filter isRefRemoved diffs = + fmap ((s <>) . S.map (qual,) . M.keysSet) $ case dt of + P.Explicit dRefs + | any (flip S.member removed) refs -> Nothing + | otherwise -> + -- search only refs encountered in the import. + Just $ M.filterWithKey (const . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + P.Hiding dRefs + | any (flip S.member removed) refs -> Nothing + | otherwise -> + -- search only refs not encountered in the import. + Just $ M.filterWithKey (const . not . flip elem refs) diffs + where + refs = foldMap (getRefs mn) dRefs + -- search all changed refs + P.Implicit -> Just diffs + go s _ = Just s + +toRefs :: P.DeclarationRef -> [Ref] +toRefs = \case + P.TypeClassRef _ n -> [TypeClassRef n] + P.TypeOpRef _ n -> [TypeOpRef n] + P.TypeRef _ n c -> [TypeRef n] <> (ConstructorRef n <$> fromMaybe [] c) + P.ValueRef _ i -> [ValueRef i] + P.ValueOpRef _ n -> [ValueOpRef n] + _ -> [] + +isEmpty :: ExternsDiff -> Bool +isEmpty (ExternsDiff _ refs) + | null refs = True + | otherwise = False + +type Tuple4 m a = (m a, m a, m a, m a) + +zipTuple4 :: Monoid (m a) => Tuple4 m a -> Tuple4 m a -> Tuple4 m a +zipTuple4 (f1, s1, t1, fo1) (f2, s2, t2, fo2) = + (f1 <> f2, s1 <> s2, t1 <> t2, fo1 <> fo2) + +-- | Returns refs as a tuple of four (added, removed, changed, unchanged). +splitRefs :: Ord r => Eq a => [a] -> [a] -> (a -> Maybe r) -> Tuple4 [] r +splitRefs new old toRef = + M.foldrWithKey go (added, [], [], []) oldMap + where + toMap = M.fromList . mapMaybe (((<$>) . flip (,)) <*> toRef) + newMap = toMap new + oldMap = toMap old + added = M.keys $ M.difference newMap oldMap + go ref decl (a, r, c, u) = case M.lookup ref newMap of + Nothing -> (a, r <> [ref], c, u) + Just newDecl + | decl /= newDecl -> (a, r, c <> [ref], u) + | otherwise -> (a, r, c, u <> [ref]) + +-- | Traverses the type and finds all the refs within. +typeDeps :: P.Type a -> S.Set (ModuleName, Ref) +typeDeps = P.everythingOnTypes (<>) $ + \case + P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn) + | isPrimModule mn -> mempty + | otherwise -> S.singleton (mn, TypeRef tn) + P.TypeConstructor _ _ -> + internalError "typeDeps: type is not qualified" + P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn) + | isPrimModule mn -> mempty + | otherwise -> S.singleton (mn, TypeOpRef tn) + P.ConstrainedType _ c _ -> + S.singleton (map TypeClassRef (qualified $ P.constraintClass c)) + P.TypeOp _ _ -> + internalError "typeDeps: type is not qualified" + _ -> mempty + +qualified :: P.Qualified b -> (ModuleName, b) +qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) +qualified _ = internalError "ExternsDiff: type is not qualified" + +type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) + +-- | To get fixity's data constructor dependency we should provide it with the +-- context (that contains all known refs) to search in. +externsFixityToRef :: Map ModuleName (Set Ref) -> P.ExternsFixity -> RefWithDeps +externsFixityToRef refs (P.ExternsFixity _ _ n alias) = + (ValueOpRef n, maybe mempty S.singleton $ getDep (qualified alias)) + where + getDep (mn, Left i) = Just (mn, ValueRef i) + getDep (mn, Right p) = + (mn,) <$> (M.lookup mn refs >>= S.lookupMin . S.filter (goRef p)) + goRef c (ConstructorRef _ c') = c' == c + goRef _ _ = False + +externsTypeFixityToRef :: P.ExternsTypeFixity -> RefWithDeps +externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = + ( TypeOpRef n + , S.singleton (map TypeRef (qualified alias)) + ) + +externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps +externsDeclarationToRef moduleName = \case + P.EDType n t tk + | isDictName n -> Nothing + | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) + -- + P.EDTypeSynonym n args t -> + Just (TypeRef n, typeDeps t <> foldArgs args) + -- + P.EDDataConstructor n _ tn t _ + | isDictName n -> Nothing + | otherwise -> + Just + ( ConstructorRef tn n + , -- Add the type as a dependency: if the type has changed (e.g. + -- constructors removed/added) it should affect all the constructors + -- in the type. + S.insert (moduleName, TypeRef tn) (typeDeps t) + ) + -- + P.EDValue n t -> + Just (ValueRef n, typeDeps t) + -- + P.EDClass n args members constraints _ _ -> + Just + ( TypeClassRef n + , foldArgs args <> constraintsDeps constraints <> foldMap (typeDeps . snd) members + ) + -- + P.EDInstance cn n args kinds types constraints _ _ _ _ -> + Just + ( TypeInstanceRef n (qualified cn) (mapMaybe myType types) + , maybe mempty constraintsDeps constraints <> instanceArgsDeps args <> foldMap typeDeps kinds + ) + where + goDataTypeArg (_, st, _) = maybe mempty typeDeps st + typeKindDeps (P.DataType _ args _) = foldMap goDataTypeArg args + typeKindDeps _ = mempty + + myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn)) + | isPrimModule mn || moduleName /= mn = Nothing + | otherwise = Just tn + myType _ = Nothing + + foldArgs = foldMap typeDeps . mapMaybe snd + instanceArgsDeps = foldMap (typeDeps . snd) + constraintsDeps = + foldMap + ( \(P.Constraint _ cls kArgs args _) -> + S.singleton (TypeClassRef <$> qualified cls) + <> foldMap typeDeps kArgs + <> foldMap typeDeps args + ) + +-- | Removes excessive info from declarations before comparing. +stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration +stripDeclaration = \case + P.EDType n t (P.DataType dt args ctors) -> + -- Remove data constructors types, we don't need them, we only need to know + -- if the list of ctors has changed. + P.EDType n t (P.DataType dt args (map (map (const [])) ctors)) + -- + P.EDInstance cn n fa ks ts cs ch chi ns ss -> + P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss + -- + decl -> decl + where + emptySP = P.SourcePos 0 0 + -- emptySS = SourceSpan "" emptySP emptySP + stripChain (ChainId (n, _)) = ChainId (n, emptySP) + +isPrimModule :: ModuleName -> Bool +isPrimModule = flip S.member (S.fromList primModules) + +-- | Check if type name is a type class dictionary name. +isDictName :: P.ProperName a -> Bool +isDictName = + T.isInfixOf "$" . P.runProperName diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 8c86144e9a..ed553cf28f 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -5,6 +5,8 @@ module Language.PureScript.Make.Monad , makeIO , getTimestamp , getTimestampMaybe + , getCurrentTime + , setTimestamp , readTextFile , readJSONFile , readJSONFileIO @@ -35,14 +37,16 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson qualified as Aeson import Data.ByteString qualified as B +import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) +import Data.Time.Clock qualified as Time import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), singleError) import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options (Options) -import System.Directory (createDirectoryIfMissing, getModificationTime) +import System.Directory (createDirectoryIfMissing, getModificationTime, setModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) @@ -85,6 +89,18 @@ getTimestampMaybe :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ( getTimestampMaybe path = makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path +-- | Get current system time. +getCurrentTime :: (MonadIO m) => m UTCTime +getCurrentTime = + liftIO Time.getCurrentTime + +-- | Set a file's modification time in the 'Make' monad, returning False if +-- the file does not exist. +setTimestamp :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> UTCTime -> m Bool +setTimestamp path time = + makeIO ("set a timestamp for file: " <> Text.pack path) $ (fmap isJust . catchDoesNotExist) $ setModificationTime path time + + -- | Read a text file strictly in the 'Make' monad, capturing any errors using -- the 'MonadError' instance. readTextFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m Text diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 610e8465c8..9865ad7a0f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -3,13 +3,13 @@ module TestMake where -import Prelude +import Prelude hiding (writeFile) import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad (guard, void) +import Control.Monad (guard, void, forM_) import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) @@ -36,141 +36,483 @@ timestampB = utcMidnightOnDate 2019 1 2 timestampC = utcMidnightOnDate 2019 1 3 timestampD = utcMidnightOnDate 2019 1 4 +oneSecond :: Int +oneSecond = 10 ^ (6::Int) -- microseconds. + +someMs :: Int +someMs = 10 ^ (3::Int) -- microseconds. + spec :: Spec spec = do let sourcesDir = "tests/purs/make" let moduleNames = Set.fromList . map P.moduleNameFromString + let modulePath name = sourcesDir (T.unpack name <> ".purs") + let foreignJsPath name = sourcesDir (T.unpack name <> ".js") + + -- Test helpers. + let testN fn name modules compile2 res = + fn name $ do + let names = map (\(mn, _, _) -> mn) modules + let paths = map modulePath names + let timestamp = utcMidnightOnDate 2019 1 + + forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do + writeFile (modulePath mn) (timestamp idx) content + + compile paths `shouldReturn` moduleNames names + + forM_ (zip [length modules..] modules) $ \(idx, (mn, _, mbContent)) -> do + maybe (pure ()) (writeFile (modulePath mn) (timestamp idx)) mbContent + + compile2 paths `shouldReturn` moduleNames res + + let test2 fn name (mAContent1, mAContent2, mBContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + ] compile res + + let testWithFailure2 fn name (mAContent1, mAContent2, mBContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + ] compileAllowingFailures res + + let test3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + , ("C", mCContent, Nothing) + ] compile res + + let testWithFailure3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = + testN fn name + [ ("A", mAContent1, Just mAContent2) + , ("B", mBContent, Nothing) + , ("C", mCContent, Nothing) + ] compileAllowingFailures res + + let recompile2 fn name ms = + test2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + + let recompileWithFailure2 fn name ms = + testWithFailure2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + + let noRecompile2 fn name ms = + test2 fn ("does not recompile when upstream not changed effectively: " <> name) ms ["A"] + before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do it "does not recompile if there are no changes" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" - writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - compile [modulePath] `shouldReturn` moduleNames [] + writeFile mPath timestampA "module Module where\nfoo = 0\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + compile [mPath] `shouldReturn` moduleNames [] it "recompiles if files have changed" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" - writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB "module Module where\nfoo = 1\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA "module Module where\nfoo = 0\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB "module Module where\nfoo = 1\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] it "does not recompile if hashes have not changed" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = modulePath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent - compile [modulePath] `shouldReturn` moduleNames [] + writeFile mPath timestampA moduleContent + compile [mPath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent + compile [mPath] `shouldReturn` moduleNames [] it "recompiles if the file path for a module has changed" $ do let modulePath1 = sourcesDir "Module1.purs" modulePath2 = sourcesDir "Module2.purs" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath1 timestampA moduleContent - writeFileWithTimestamp modulePath2 timestampA moduleContent + writeFile modulePath1 timestampA moduleContent + writeFile modulePath2 timestampA moduleContent compile [modulePath1] `shouldReturn` moduleNames ["Module"] compile [modulePath2] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was added" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" + let mPath = modulePath "Module" + mFFIPath = foreignJsPath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA moduleContent + compile [mPath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mFFIPath timestampB "export var bar = 1;\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was removed" $ do - let moduleBasePath = sourcesDir "Module" - modulePath = moduleBasePath ++ ".purs" - moduleFFIPath = moduleBasePath ++ ".js" + let mPath = modulePath "Module" + mFFIPath = foreignJsPath "Module" moduleContent = "module Module where\nfoo = 0\n" - writeFileWithTimestamp modulePath timestampA moduleContent - writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" - compile [modulePath] `shouldReturn` moduleNames ["Module"] - - removeFile moduleFFIPath - compile [modulePath] `shouldReturn` moduleNames ["Module"] - - it "recompiles downstream modules when a module is rebuilt" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent1 - writeFileWithTimestamp moduleBPath timestampB moduleBContent - compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] - - writeFileWithTimestamp moduleAPath timestampC moduleAContent2 - compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] - - it "only recompiles downstream modules when a module is rebuilt" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleCPath = sourcesDir "C.purs" - modulePaths = [moduleAPath, moduleBPath, moduleCPath] - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - moduleCContent = "module C where\nbaz = 3\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent1 - writeFileWithTimestamp moduleBPath timestampB moduleBContent - writeFileWithTimestamp moduleCPath timestampC moduleCContent + writeFile mPath timestampA moduleContent + writeFile mFFIPath timestampB "export var bar = 1;\n" + compile [mPath] `shouldReturn` moduleNames ["Module"] + + removeFile mFFIPath + compile [mPath] `shouldReturn` moduleNames ["Module"] + + it "recompiles downstream modules when a module is rebuilt and externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = '1'\n" + mBContent = "module B where\nimport A as A\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + it "only recompiles downstream modules when a module is rebuilt end externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = '1'\n" -- change externs here + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - writeFileWithTimestamp moduleAPath timestampD moduleAContent2 + writeFile mAPath timestampD mAContent2 compile modulePaths `shouldReturn` moduleNames ["A", "B"] + it "recompiles downstream after a module has been rebuilt separately" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + mPaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A where\nfoo = 1\n" + mBContent = "module B where\nimport A\nbar = 1\nbaz = foo\n" + mCContent = "module C where\nimport B\nqux = bar" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampB mCContent + + compile mPaths `shouldReturn` moduleNames ["A", "B", "C"] + + threadDelay oneSecond + + writeFile mAPath timestampC mAContent2 + compile [mAPath] `shouldReturn` moduleNames ["A"] + + compile mPaths `shouldReturn` moduleNames ["B", "C"] + + -- Reexports. + test3 it "recompiles downstream modules when a reexported module changed" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A (foo) as E\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["A", "B", "C"] + + -- test3 fit "reexported module changed" + -- ( "module A where\ndata ABC = A Int | B\n" + -- , "module A where\ndata ABC = A String | B\n" -- change externs here + -- , "module B (module E) where\nimport A (ABC(..)) as E\n" + -- , "module C where\nimport B as B\nbaz = B.A\n" + -- ) + -- ["A", "B", "C"] + + -- Imports. + testWithFailure2 it "recompiles downstream when removed reference found in imports" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo2 = 1\n" + , "module B where\nimport A (foo)\nbar = 1" + ) + ["A", "B"] + + test2 it "does not recompiles downstream when removed reference is not used" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo2 = 1\n" + , "module B where\nimport A\nbar = 1" + ) + ["A"] + + -- Usage in the code + -- signature + + -- inlined + testWithFailure2 it "recompiles downstream when found changed inlined type" + ( "module A where\ntype T = Int\n" + , "module A where\ntype T = String\n" + , "module B where\nimport A\nx = (1 :: T)" + ) + ["A", "B"] + + -- Transitive change. + test3 it "recompiles downstream due to transitive change" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\n" + , "module B where\nimport A (foo)\nbar = qux\nqux = foo" + , "module C where\nimport B (bar)\nbaz = bar\n" + ) + ["A", "B", "C"] + + test3 it "do not recompile downstream if no transitive change" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\n" + , "module B where\nimport A (foo)\nbar = 1\nqux = foo" + , "module C where\nimport B (bar)\nbaz = bar\n" + ) + ["A", "B"] + + noRecompile2 it "unused type changed" + ( "module A where\ntype SynA = Int\ntype SynA2 = Int" + , "module A where\ntype SynA = String\ntype SynA2 = Int" + , "module B where\nimport A as A\ntype SynB = A.SynA2" + ) + + -- Type synonyms. + recompile2 it "type synonym changed" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" + ) + + recompile2 it "type synonym dependency changed" + ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" + , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" + , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" + ) + + -- Data types. + recompile2 it "data type changed (parameter added)" + ( "module A where\ndata T = A Int | B Int\n" + , "module A where\ndata T a = A Int | B a\n" + , "module B where\nimport A (T)\ntype B = T" + ) + + recompile2 it "data type changed (constructor added)" + ( "module A where\ndata T = A Int | B Int\n" + , "module A where\ndata T = A Int | B Int | C Int\n" + , "module B where\nimport A (T(B))\nb = B" + ) + + recompile2 it "data type constructor dependency changed" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" + , "module B where\nimport A (AB(..))\nb = A" + ) + + noRecompile2 it "data type constructor changed, but not used" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" + -- use type and other constructor + , "module B where\nimport A (AB(..))\ntype B = AB\nb = B" + ) + + + -- Value operators. + recompile2 it "value op changed" + ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" + , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" + , "module B where\nimport A\nt = 1 :+: \"1\" " + ) + + recompile2 it "value op dependency changed" + ( "module A where\ndata T a = T a String\ninfixl 2 T as :+:\n" + , "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" + , "module B where\nimport A\nt = 1 :+: \"1\" " + ) + + + -- Type operators. + recompile2 it "type op changed" + ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" + , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" + , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" + ) + + recompile2 it "type op dependency changed" + ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" + , "module A where\ndata T b a = T a b\ninfixl 2 type T as :+:\n" + , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" + ) + + -- Type classes. + recompile2 it "type class changed" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , T.unlines + [ "module B where" + , "import A as A" + , "fn :: forall a. A.Cls a => a -> Int" + , "fn _ = 1" + ] + ) + + recompile2 it "type class changed (member affected)" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , T.unlines + [ "module B where" + , "import A as A" + , "fn x = A.m1 x" + ] + ) + + recompile2 it "type class instance added" + ( "module A where\nclass Cls a where m1 :: a -> Int\n" + , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" + , T.unlines + [ "module B where" + , "import A as A" + , "fn :: forall a. A.Cls a => a -> Int" + , "fn _ = 1" + ] + ) + + recompileWithFailure2 it "type class instance removed" + ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" + , "module A where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module B where" + , "import A (m1)" + , "x = m1 1" + ] + ) + + test3 it "recompiles downstream if instance added for type" + ( "module A where\nimport B\nnewtype T = T Int\n" + , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "t = T 1" + ] + ) + ["A", "C"] + + test3 it "recompiles downstream if instance added for type" + ( "module A where\nimport B\nnewtype T = T Int\n" + , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "t = T 1" + ] + ) + ["A", "C"] + + testWithFailure3 it "recompiles downstream if instance removed for type" + ( "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module A where\nimport B\nnewtype T = T Int\n" + , "module B where\nclass Cls a where m1 :: a -> Int\n" + , T.unlines + [ "module C where" + , "import A" + , "import B" + , "i :: Int" + , "i = m1 (T 1)" + ] + ) + ["A", "C"] + + testN it "doesn't recompile downstream if an instance added for the type and type class changed" + [ ( "A" + , "module A where\nclass Cls a where m1 :: a -> Char\n" + , Just "module A where\nclass Cls a where m1 :: a -> Int\n" + ) + , ( "B" + , "module B where\nimport A\nnewtype T = T Int\n" + , Just "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + ) + , ("C", "module C where\nimport B\ntype C = T", Nothing) + ] compile ["A", "B"] + + it "does not recompile downstream modules when a module is rebuilt but externs have not changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + mAContent1 = "module A where\nfoo = 0\n" + mAContent2 = "module A (foo) where\nbar = 1\nfoo = 1\n" + mBContent = + T.unlines + [ "module B where" + , "import A (foo)" + , "import C (baz)" + , "bar = foo" + , "qux = baz" + ] + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + -- + writeFile mAPath timestampD mAContent2 + threadDelay oneSecond + compile modulePaths `shouldReturn` moduleNames ["A"] + -- compile again to check that it won't try recompile skipped module again + compile modulePaths `shouldReturn` moduleNames [] + it "does not necessarily recompile modules which were not part of the previous batch" $ do - let moduleAPath = sourcesDir "A.purs" - moduleBPath = sourcesDir "B.purs" - moduleCPath = sourcesDir "C.purs" - modulePaths = [moduleAPath, moduleBPath, moduleCPath] - batch1 = [moduleAPath, moduleBPath] - batch2 = [moduleAPath, moduleCPath] - moduleAContent = "module A where\nfoo = 0\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - moduleCContent = "module C where\nbaz = 3\n" - - writeFileWithTimestamp moduleAPath timestampA moduleAContent - writeFileWithTimestamp moduleBPath timestampB moduleBContent - writeFileWithTimestamp moduleCPath timestampC moduleCContent + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + batch1 = [mAPath, mBPath] + batch2 = [mAPath, mCPath] + + mAContent = "module A where\nfoo = 0\n" + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] compile batch1 `shouldReturn` moduleNames [] compile batch2 `shouldReturn` moduleNames [] it "recompiles if a module fails to compile" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" - writeFileWithTimestamp modulePath timestampA moduleContent - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] - compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampA moduleContent + compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] + compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] it "recompiles if docs are requested but not up to date" $ do - let modulePath = sourcesDir "Module.purs" + let mPath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } - go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10 ^ (6::Int) -- microseconds. + go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFileWithTimestamp modulePath timestampA moduleContent1 + writeFile mPath timestampA moduleContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeFile mPath timestampB moduleContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -178,30 +520,29 @@ spec = do -- recompiled. go optsWithDocs `shouldReturn` moduleNames ["Module"] - it "recompiles if corefn is requested but not up to date" $ do - let modulePath = sourcesDir "Module.purs" + it "recompiles if CoreFn is requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" moduleContent1 = "module Module where\nx :: Int\nx = 1" moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - optsCorefnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } - go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10 ^ (6::Int) -- microseconds. + optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } + go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFileWithTimestamp modulePath timestampA moduleContent1 - go optsCorefnOnly `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp modulePath timestampB moduleContent2 + writeFile mPath timestampA moduleContent1 + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing corefn.json is now outdated, the module should be + -- Since the existing CoreFn.json is now outdated, the module should be -- recompiled. - go optsCorefnOnly `shouldReturn` moduleNames ["Module"] + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] -- Note [Sleeping to avoid flaky tests] -- -- One of the things we want to test here is that all requested output files -- (via the --codegen CLI option) must be up to date if we are to skip -- recompiling a particular module. Since we check for outdatedness by --- comparing the timestamp of the output files (eg. corefn.json, index.js) to +-- comparing the timestamp of the output files (eg. CoreFn.json, index.js) to -- the timestamp of the externs file, this check is susceptible to flakiness -- if the timestamp resolution is sufficiently coarse. To get around this, we -- delay for one second. @@ -232,8 +573,10 @@ compileWithOptions opts input = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions modulesDir filePathMap foreigns True) - { P.progress = \(P.CompilingModule mn _) -> - liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + { P.progress = \case + P.CompilingModule mn _ -> + liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + _ -> pure () } P.make makeActions (map snd ms) @@ -264,8 +607,8 @@ compile input = compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) compileAllowingFailures input = fmap snd (compileWithResult input) -writeFileWithTimestamp :: FilePath -> UTCTime -> T.Text -> IO () -writeFileWithTimestamp path mtime contents = do +writeFile :: FilePath -> UTCTime -> T.Text -> IO () +writeFile path mtime contents = do writeUTF8FileT path contents setModificationTime path mtime diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 146093c452..94f56fc449 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -147,7 +147,7 @@ setupSupportModules = do let modules = map snd ms supportExterns <- runExceptT $ do foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules) + externs <- ExceptT . fmap fst . runTest $ P.make' (makeActions modules foreigns) (CST.pureResult <$> modules) return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) From ac51b00f52a8f14ab0e1d1c6d22627974688b8ac Mon Sep 17 00:00:00 2001 From: Alex Date: Sun, 18 Jun 2023 22:07:51 +0500 Subject: [PATCH 075/105] Fix linting error. --- src/Language/PureScript/Make.hs | 1 - tests/TestMake.hs | 5 +---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8d0212e456..2292c21378 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -5,7 +5,6 @@ module Language.PureScript.Make , rebuildModule' , make , make' - , makeImp , inferForeignModules , module Monad , module Actions diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 9865ad7a0f..e08cda7314 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -1,7 +1,7 @@ -- Tests for the compiler's handling of incremental builds, i.e. the code in -- Language.PureScript.Make. -module TestMake where +module TestMake (spec) where import Prelude hiding (writeFile) @@ -39,9 +39,6 @@ timestampD = utcMidnightOnDate 2019 1 4 oneSecond :: Int oneSecond = 10 ^ (6::Int) -- microseconds. -someMs :: Int -someMs = 10 ^ (3::Int) -- microseconds. - spec :: Spec spec = do let sourcesDir = "tests/purs/make" From 1e07d607f899ac3347035df58d0d3b56949d52a8 Mon Sep 17 00:00:00 2001 From: Alex Date: Tue, 26 Dec 2023 12:30:40 +0500 Subject: [PATCH 076/105] Refactor externs diff and make api, fix some review sugs --- app/Command/Compile.hs | 2 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Make.hs | 92 ++++---- src/Language/PureScript/Make/Actions.hs | 7 +- src/Language/PureScript/Make/BuildPlan.hs | 54 +++-- src/Language/PureScript/Make/Cache.hs | 3 +- src/Language/PureScript/Make/ExternsDiff.hs | 219 +++++++++++++------- tests/TestUtils.hs | 4 +- 8 files changed, 231 insertions(+), 152 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..d43338580d 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -73,7 +73,7 @@ compile PSCMakeOptions{..} = do let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix - P.make makeActions (map snd ms) + P.make_ makeActions (map snd ms) printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 2650cba284..5f88b079c3 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -79,7 +79,7 @@ make -> P.Make ([P.ExternsFile], P.Environment) make ms = do foreignFiles <- P.inferForeignModules filePathMap - externs <- P.make' (buildActions foreignFiles) (map snd ms) + externs <- P.make (buildActions foreignFiles) (map snd ms) return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs) where buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 2292c21378..07810192c9 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,10 +1,8 @@ module Language.PureScript.Make - ( - -- * Make API - rebuildModule + ( make + , make_ + , rebuildModule , rebuildModule' - , make - , make' , inferForeignModules , module Monad , module Actions @@ -15,7 +13,7 @@ import Prelude import Control.Concurrent.Lifted as C import Control.DeepSeq (force) import Control.Exception.Lifted (onException, bracket_, evaluate) -import Control.Monad (foldM, unless, when, (<=<)) +import Control.Monad (foldM, unless, void, when, (<=<)) import Control.Monad.Base (MonadBase(liftBase)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -46,12 +44,31 @@ import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModule import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) -import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult) +import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult, isUpToDate) import Language.PureScript.Make.BuildPlan qualified as BuildPlan import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad + ( Make(..), + writeTextFile, + writeJSONFile, + writeCborFileIO, + writeCborFile, + setTimestamp, + runMake, + readTextFile, + readJSONFileIO, + readJSONFile, + readExternsFile, + readCborFileIO, + readCborFile, + makeIO, + hashFile, + getTimestampMaybe, + getTimestamp, + getCurrentTime, + copyFile ) import Language.PureScript.CoreFn qualified as CF import System.Directory (doesFileExist) import System.FilePath (replaceExtension) @@ -134,9 +151,12 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ Right d -> d evalSupplyT nextVar'' $ codegen renamed docs exts - -- evaluate $ trace ("\n===== externs: " <> show moduleName <> ":\n" <> show exts) () return exts +data MakeOptions = MakeOptions + { moCollectAllExterns :: Bool + } + -- | Compiles in "make" mode, compiling each module separately to a @.js@ file -- and an @externs.cbor@ file. -- @@ -144,40 +164,35 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- to provide upstream modules' types without having to typecheck those modules -- again. -- --- This version will collect an return externs only of modules that were used --- during the build. +-- It collects and returns externs for all modules passed. make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] -make ma ms = makeImp ma ms False +make = make' (MakeOptions {moCollectAllExterns = True}) -- | Compiles in "make" mode, compiling each module separately to a @.js@ file -- and an @externs.cbor@ file. -- --- If timestamps or hashes have not changed, existing externs files can be used --- to provide upstream modules' types without having to typecheck those modules --- again. --- --- This version will collect an return all externs of all passed modules. -make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +-- This version of make returns nothing. +make_ :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] - -> m [ExternsFile] -make' ma ms = makeImp ma ms True + -> m () +make_ ma ms = void $ make' (MakeOptions {moCollectAllExterns = False}) ma ms -makeImp :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m +make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeOptions + -> MakeActions m -> [CST.PartialResult Module] - -> Bool -> m [ExternsFile] -makeImp ma@MakeActions{..} ms collectAll = do +make' MakeOptions{..} ma@MakeActions{..} ms = do checkModuleNames cacheDb <- readCacheDb (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms - - (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) collectAll + let opts = BuildPlan.Options {optPreloadAllExterns = moCollectAllExterns} + (buildPlan, newCacheDb) <- BuildPlan.construct opts ma cacheDb (sorted, graph) -- Limit concurrent module builds to the number of capabilities as -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. @@ -192,8 +207,6 @@ makeImp ma@MakeActions{..} ms collectAll = do let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted let totalModuleCount = length toBeRebuilt for_ toBeRebuilt $ \m -> fork $ do - -- evaluate $ trace ("resPartial:" <> show (CST.resPartial $ m)) () - -- evaluate $ trace ("resFull:" <> show (CST.resFull $ m)) () let moduleName = getModuleName . CST.resPartial $ m let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) buildModule lock buildPlan moduleName totalModuleCount @@ -237,10 +250,11 @@ makeImp ma@MakeActions{..} ms collectAll = do fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name) $ M.lookup mn successes - if collectAll then - pure $ map lookupResult sortedModuleNames - else - pure $ mapMaybe (flip M.lookup successes) sortedModuleNames + pure $ + if moCollectAllExterns then + map lookupResult sortedModuleNames + else + mapMaybe (flip M.lookup successes) sortedModuleNames where checkModuleNames :: m () @@ -287,23 +301,19 @@ makeImp ma@MakeActions{..} ms collectAll = do case mexterns of Just (_, depsDiffExterns) -> do let externs = fst <$> depsDiffExterns - --evaluate $ trace ("diff:" <> show moduleName <> ":" <> show (snd <$> depsDiffExterns)) () - --evaluate $ trace ("check diff:" <> show moduleName <> ":" <> show (isNothing $ traverse snd depsDiffExterns)) () let prevResult = BuildPlan.getPrevResult buildPlan moduleName let depsDiffs = traverse snd depsDiffExterns let maySkipBuild moduleIndex - -- Just exts <- BuildPlan.getPrevResult buildPlan moduleName - -- we may skip built only for up-to-date modules - | Just (True, exts) <- prevResult - -- check if no dep's externs have changed - -- if one of the diffs is Nothing means we can not check and need to rebuild - --, Just False <- checkDiffs m <$> traverse snd depsDiffExterns = do + -- We may skip built only for up-to-date modules. + | Just (status, exts) <- prevResult + , isUpToDate status + -- Check if no dep's externs have changed. If any of the diffs + -- is Nothing means we can not check and need to rebuild. , Just False <- checkDiffs m <$> depsDiffs = do -- We should update modification times to mark existing -- compilation results as actual. If it fails to update timestamp -- on any of exiting codegen targets, it will run the build process. updated <- updateOutputTimestamp moduleName - --evaluate $ trace ("updated:" <> show updated <> ":" <> show moduleName) () if updated then do progress $ SkippingModule moduleName moduleIndex pure $ Just (exts, MultipleErrors [], Just (emptyDiff moduleName)) @@ -311,7 +321,7 @@ makeImp ma@MakeActions{..} ms collectAll = do pure Nothing | otherwise = pure Nothing - -- We need to ensure that all dependencies have been included in Env + -- We need to ensure that all dependencies have been included in Env. C.modifyMVar_ (bpEnv buildPlan) $ \env -> do let go :: Env -> ModuleName -> m Env diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 952925689d..26e5fcccce 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -155,8 +155,6 @@ readCacheDb' -- ^ The path to the output directory -> m CacheDb readCacheDb' outputDir = do - --fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) - --fromMaybe mempty <$> (fmap fromCacheDbVersioned <$> readJSONFile (cacheDbFile outputDir)) mdb <- readJSONFile (cacheDbFile outputDir) pure $ fromMaybe mempty $ do db <- mdb @@ -268,11 +266,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = updateOutputTimestamp mn = do curTime <- getCurrentTime ok <- setTimestamp (outputFilename mn externsFileName) curTime - -- then update all actual codegen targets + -- Then update timestamps of all actual codegen targets. codegenTargets <- asks optionsCodegenTargets let outputPaths = fmap (targetFilename mn) (S.toList codegenTargets) results <- traverse (flip setTimestamp curTime) outputPaths - -- if something goes wrong, something failed to update, return Nothing + -- If something goes wrong (any of targets doesn't exit, a file system + -- error), return False. pure $ and (ok : results) readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 38554fcec0..8669233b0e 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,6 +1,8 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) + , Options(..) + , isUpToDate , construct , getResult , getPrevResult @@ -34,11 +36,16 @@ import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) +newtype UpToDateStatus = UpToDateStatus Bool + +isUpToDate :: UpToDateStatus -> Bool +isUpToDate (UpToDateStatus b) = b + -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt - , bpPreviousBuilt :: M.Map ModuleName (Bool, Prebuilt) + , bpPreviousBuilt :: M.Map ModuleName (UpToDateStatus, Prebuilt) , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int @@ -130,7 +137,6 @@ getResult -> ModuleName -> m (Maybe SuccessResult) getResult buildPlan moduleName = - -- may bring back first lookup for bpPrebuilt case M.lookup moduleName (bpBuildJobs buildPlan) of Just bj -> buildJobSuccess <$> C.readMVar (bjResult bj) @@ -142,24 +148,27 @@ getResult buildPlan moduleName = -- | Gets preloaded previous built result for modules that are going to be built. This -- will be used to skip compilation if dep's externs have not changed. -getPrevResult :: BuildPlan -> ModuleName -> Maybe (Bool, ExternsFile) +getPrevResult :: BuildPlan -> ModuleName -> Maybe (UpToDateStatus, ExternsFile) getPrevResult buildPlan moduleName = fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) + +data Options = Options + { optPreloadAllExterns :: Bool + } + -- | Constructs a BuildPlan for the given module graph. -- -- The given MakeActions are used to collect various timestamps in order to -- determine whether a module needs rebuilding. construct :: forall m. MonadBaseControl IO m - => MakeActions m + => Options + -> MakeActions m -> CacheDb -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) - -> Bool - -- ^ If True will preload all the externs, otherwise will load only needed for - -- the build. -> m (BuildPlan, CacheDb) -construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do +construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do let sortedModuleNames = map (getModuleName . CST.resPartial) sorted rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus @@ -177,19 +186,20 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do let inBuildDeps = flip S.member allBuildDeps -- We only need prebuilt results for deps of the modules to be build. - let toLoadPrebuilt - | preloadAll = prebuiltMap - | otherwise = M.filterWithKey (const . inBuildDeps) prebuiltMap + let toLoadPrebuilt = + if optPreloadAllExterns + then prebuiltMap + else M.filterWithKey (const . inBuildDeps) prebuiltMap - -- We will need previously built results for modules to be build + -- We will need previously built results for modules to be built -- to skip rebuilding if deps have not changed. let toLoadPrev = M.mapMaybeWithKey ( \mn prev -> do -- We load previous build result for all up-to-date modules, and -- also for changed modules that have dependants. - upToDate <- fst <$> prev - guard (upToDate || inBuildDeps mn) + status <- fst <$> prev + guard (isUpToDate status || inBuildDeps mn) prev ) rebuildMap @@ -203,8 +213,8 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do let prebuilt = M.mapMaybe id prebuiltLoad let previous = M.mapMaybe id prevLoad - -- If for some reason (wrong version, files corruption) loading fails, - -- those modules should be rebuilt too. + -- If for some reason (wrong version, files corruption, etc) prebuilt + -- externs loading fails, those modules should be rebuilt too. let failedLoads = M.keys $ M.filter isNothing prebuiltLoad buildJobs <- foldM makeBuildJob M.empty (toBeRebuilt <> failedLoads) @@ -219,8 +229,8 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do foldl' update cacheDb rebuildStatuses ) where - -- Timestamp here is just to ensure that we will try to load modules that - -- have previous built results available. + -- Timestamp here is just to ensure that we will only try to load modules + -- that have previous built results available. loadPrebuilt :: ModuleName -> UTCTime -> m (Maybe Prebuilt) loadPrebuilt = const . fmap (fmap Prebuilt . snd) . readExterns @@ -251,13 +261,13 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory - (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo + (newCacheInfo, upToDate) <- checkChanged cacheDb moduleName cwd cacheInfo timestamp <- getOutputTimestamp moduleName pure (RebuildStatus { rsModuleName = moduleName , rsRebuildNever = False , rsPrebuilt = timestamp - , rsUpToDate = isUpToDate + , rsUpToDate = upToDate , rsNewCacheInfo = Just newCacheInfo }) @@ -265,7 +275,7 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do where graphError = internalError "make: module not found in dependency graph." - splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (Bool, UTCTime)), M.Map ModuleName UTCTime) + splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (UpToDateStatus, UTCTime)), M.Map ModuleName UTCTime) splitModules = foldl' collectByStatus (M.empty, M.empty) collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) @@ -284,7 +294,7 @@ construct MakeActions{..} cacheDb (sorted, graph) preloadAll = do _ | any isNothing modTimes -> toRebuild (upToDate, pb) _ -> toPrebuilt pb where - toRebuild v = (M.insert mn (Just v) build, prev) + toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prev) toPrebuilt v = (build, M.insert mn v prev) maximumMaybe :: Ord a => [a] -> Maybe a diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index f703b18789..4582d2fdf7 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -72,13 +72,12 @@ hash = ContentHash . Hash.hash type CacheDb = Map ModuleName CacheInfo data CacheDbVersioned = CacheDbVersioned { cdbVersion :: Text, cdbModules :: CacheDb } - --deriving stock (Show) deriving (Eq, Ord) instance Aeson.FromJSON CacheDbVersioned where parseJSON = Aeson.withObject "CacheDb" $ \v -> CacheDbVersioned - <$> v .: "version" + <$> v .: "version" <*> v .: "modules" instance Aeson.ToJSON CacheDbVersioned where diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 25dd6f8b15..31530ccce0 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -11,8 +11,6 @@ import Data.Graph as G (graphFromEdges, reachable) import Data.List qualified as L import Data.Map qualified as M import Data.Set qualified as S -import Data.Text qualified as T - import Language.PureScript.AST qualified as P import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) import Language.PureScript.Constants.Prim (primModules) @@ -22,57 +20,70 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P - -type RefStatus = Bool - -data ExternsDiff = ExternsDiff - {edModuleName :: ModuleName, edRefs :: M.Map Ref RefStatus} - deriving (Show) - --- | Empty diff means no effective difference between externs. -emptyDiff :: P.ModuleName -> ExternsDiff -emptyDiff mn = ExternsDiff mn mempty - -isRefRemoved :: RefStatus -> Bool -isRefRemoved = not +import Language.PureScript.Environment (isDictTypeName) -- Refs structure appropriate for storing and checking externs diffs. data Ref = TypeClassRef (P.ProperName 'P.ClassName) | TypeOpRef (P.OpName 'P.TypeOpName) | TypeRef (P.ProperName 'P.TypeName) - | -- we use separate ref for a data constructor and keep here origin type as well + | -- We use separate ref for a data constructor and keep here origin type as well. ConstructorRef (P.ProperName 'P.TypeName) (P.ProperName 'P.ConstructorName) + | -- A ad-hoc ref that points to the type with a set of constructors that changed. + -- It is needed to correctly handle effects of adding/removing of ctors. + CtorsSetRef (P.ProperName 'P.TypeName) | ValueRef P.Ident | ValueOpRef (P.OpName 'P.ValueOpName) - | -- instance ref points to the class and types defined in the same module - -- TypeInstanceRef P.Ident (Maybe (P.ProperName 'P.ClassName)) [P.ProperName 'P.TypeName] + | -- Instance ref points to the class and types defined in the same module. TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] deriving (Show, Eq, Ord) -diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff -diffExterns newExts oldExts depsDiffs = - ExternsDiff modName $ - addStatus (changedRefs <> affectedReExported <> allAffectedLocalRefs) - where - modName = P.efModuleName newExts - -- Marks if ref was removed - addStatus = M.fromSet (flip S.notMember removedSet) +data RefStatus = Removed | Updated + deriving (Show) - depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) +type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) - -- To get changed reexported refs, we take those which were removed (not - -- present in new extern's exports) or changed in dependencies. +type RefsWithStatus = M.Map Ref RefStatus + +type ModuleRefsMap = Map ModuleName (Set Ref) + +data ExternsDiff = ExternsDiff + {edModuleName :: ModuleName, edRefs :: Map Ref RefStatus} + deriving (Show) + +-- | Empty diff means no effective difference between externs. +emptyDiff :: P.ModuleName -> ExternsDiff +emptyDiff mn = ExternsDiff mn mempty + +isRefRemoved :: RefStatus -> Bool +isRefRemoved Removed = True +isRefRemoved _ = False + +-- To get changed reexported refs, we take those which were removed (not +-- present in new extern's exports) or changed in dependencies. +getReExported :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> RefsWithStatus +getReExported newExts oldExts depsDiffsMap = + -- S.fromList $ map snd $ filter checkRe oldExports + M.fromList $ mapMaybe checkRe oldExports + where goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref goRe _ = [] oldExports = concatMap goRe (P.efExports oldExts) newReExports = concatMap goRe (P.efExports newExts) checkRe (mn, ref) - | (mn, ref) `notElem` newReExports = True - | Just True <- elem ref <$> M.lookup mn depsDiffsMap = True - | otherwise = False - affectedReExported = S.fromList $ map snd $ filter checkRe oldExports + | (mn, ref) `notElem` newReExports = Just (ref, Removed) + | Just True <- elem ref <$> M.lookup mn depsDiffsMap = Just (ref, Updated) + | otherwise = Nothing + +-- Extracts declarations from old and new externs and compares them. Returns a +-- tuple of changed refs (a form of which have changed) and unchanged refs with +-- dependencies (refs they depend upon). +getChanged :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> (RefsWithStatus, [RefWithDeps]) +getChanged newExts oldExts depsDiffsMap = + (changedRefs, unchangedRefs) + where + modName = P.efModuleName newExts getDecls = map stripDeclaration . P.efDeclarations getTypeFixities = P.efTypeFixities @@ -87,25 +98,31 @@ diffExterns newExts oldExts depsDiffs = applyInstances (a, r, c, u) = let checkType t (TypeRef t') = t' == t checkType _ _ = False - uRefs = map fst u + uRefs = map fst u -- Unchanged refs. go (TypeInstanceRef _ (clsMod, cls) types) | clsRef <- TypeClassRef cls = if clsMod == modName - then -- If the class is defined in this module we ensure that is marked as changed + then -- If the class is defined in this module we ensure that is marked as changed. maybe [] pure $ find ((==) clsRef) uRefs else case S.member clsRef <$> M.lookup clsMod depsDiffsMap of Just True -> - -- if the type class is in another module and it has - -- changed we don't need to care about instance types. + -- If the type class is in another module and it has + -- changed we don't need to care about instance types + -- (because the instance change affects modules that use + -- the type class/its methods). [] - -- Otherwise mark instance types as changed. _ -> + -- Otherwise mark instance types as changed. foldMap (\t -> filter (checkType t) uRefs) types go _ = mempty + + -- Check class instances in added, removed and changed. affected = foldMap (S.fromList . go . fst) (a <> r <> c) (uc, uu) = L.partition (flip S.member affected . fst) u in (a, r, c <> uc, uu) + -- Group/split exported refs of the module into (added, removed, changed, + -- unchanged) - (a, r, c, u). declsSplit = applyInstances $ splitRefs (getDecls newExts) (getDecls oldExts) (externsDeclarationToRef modName) @@ -115,7 +132,9 @@ diffExterns newExts oldExts depsDiffs = getRefsSet (a, r, c, u) = S.fromList $ map fst (a <> r <> c <> u) fixityCtx = M.insert modName (getRefsSet declsSplit) depsDiffsMap - -- Determine which declarations where directly changed or removed. + -- Determine which declarations where directly changed or removed by + -- combining Declarations, Fixities and Type Fixities - as they are + -- separated in externs we handle them separately. We don't care about added things. (_, removed, changed, unchangedRefs) = foldl zipTuple4 @@ -125,28 +144,46 @@ diffExterns newExts oldExts depsDiffs = , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) ] - removedSet = S.fromList (map fst removed) - changedRefs = S.fromList $ map fst (removed <> changed) - - diffsMapWithLocal - | null changedRefs = depsDiffsMap - | otherwise = M.insert modName changedRefs depsDiffsMap + changedRefs = + M.fromList $ + map ((,Removed) . fst) removed <> map ((,Updated) . fst) changed - -- Affected refs here are refs that depend on external or local changed refs. - -- - -- Rest local refs are refs that do not depend on external/local changed, but - -- may depend on affected local refs and need to be checked. +-- Gets set of type constructors from new externs that have changed. +getCtorsSets :: P.ExternsFile -> P.ExternsFile -> Set Ref +getCtorsSets newExts oldExts = + S.map CtorsSetRef $ + M.keysSet $ + M.differenceWith comp (getSets newExts) (getSets oldExts) + where + getSets = M.fromList . foldMap goDecl . P.efDeclarations + goDecl = \case + P.EDType n _ (P.DataType _ _ ctors) -> + [(n, S.fromList $ fst <$> ctors)] + _ -> [] + comp a b = if a == b then Nothing else Just a + +-- Takes a list unchanged local refs with dependencies and finds that are affected by +-- changed refs. Cyclic dependencies between local refs are searched using +-- directed graph. +getAffectedLocal :: ModuleName -> ModuleRefsMap -> [RefWithDeps] -> Set Ref +getAffectedLocal modName diffsMap unchangedRefs = + affectedLocalRefs + where hasChangedDeps (mn, ref) = - Just True == (S.member ref <$> M.lookup mn diffsMapWithLocal) - (affectedLocalRefs, restLocalRefs) = + Just True == (S.member ref <$> M.lookup mn diffsMap) + (affectedByChanged, restLocalRefs) = L.partition (any hasChangedDeps . snd) unchangedRefs -- Use graph to go though local refs and their cyclic dependencies on each other. -- The graph includes only local refs that depend on other local refs. - toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) deps) + toNode (ref, deps) = (ref, ref, map snd $ filter ((== modName) . fst) (S.toList deps)) - vtxs = toNode <$> (map (map S.toList) restLocalRefs <> (map (const mempty) <$> affectedLocalRefs)) + -- Make graph vertexes from the rest local refs with deps and affected refs + -- with no deps. + vtxs = toNode <$> restLocalRefs <> (map (const mempty) <$> affectedByChanged) (graph, fromVtx, toVtx) = G.graphFromEdges vtxs + + -- Graph is a list of refs with (refs) dependencies. refsGraph = do (_, t, _) <- vtxs let v = fromMaybe (internalError "diffExterns: vertex not found") $ toVtx t @@ -155,11 +192,37 @@ diffExterns newExts oldExts depsDiffs = pure (t, map toKey deps) -- Get local refs that depend on affected refs (affected refs are included - -- in the graph too). - allAffectedLocalRefs = + -- in the graph result because a node's reachable list includes the node + -- itself). + affectedLocalRefs = S.fromList $ map fst $ - filter (any (flip elem (fst <$> affectedLocalRefs)) . snd) refsGraph + filter (any (flip elem (fst <$> affectedByChanged)) . snd) refsGraph + +diffExterns :: P.ExternsFile -> P.ExternsFile -> [ExternsDiff] -> ExternsDiff +diffExterns newExts oldExts depsDiffs = + ExternsDiff modName $ + affectedReExported <> changedRefs <> affectedLocalRefs + where + modName = P.efModuleName newExts + + depsDiffsMap = M.fromList (map (liftM2 (,) edModuleName (M.keysSet . edRefs)) depsDiffs) + + -- To get changed reexported refs, we take those which were removed (not + -- present in new extern's exports) or changed in dependencies. + affectedReExported = getReExported newExts oldExts depsDiffsMap + + (changedRefs, unchangedRefs) = getChanged newExts oldExts depsDiffsMap + + ctorsSets = getCtorsSets newExts oldExts + + -- Extend dependencies' diffs map with local changes. + diffsMapWithLocal + | null changedRefs && null ctorsSets = depsDiffsMap + | otherwise = M.insert modName (M.keysSet changedRefs <> ctorsSets) depsDiffsMap + + affectedLocalRefs = + M.fromSet (const Updated) $ getAffectedLocal modName diffsMapWithLocal unchangedRefs checkDiffs :: P.Module -> [ExternsDiff] -> Bool checkDiffs (P.Module _ _ _ decls exports) diffs @@ -244,8 +307,8 @@ checkUsage searches decls = foldMap findUsage decls /= mempty -- | Traverses imports and returns a set of refs to be searched though the -- module. Returns Nothing if removed refs found in imports (no need to search --- through the module). If an empty set is returned then no changes apply to the --- module. +-- through the module - the module needs to be recompiled). If an empty set is +-- returned then no changes apply to the module. makeSearches :: [P.Declaration] -> [ExternsDiff] -> Maybe (Set (Maybe ModuleName, Ref)) makeSearches decls depsDiffs = foldM go mempty decls @@ -268,18 +331,18 @@ makeSearches decls depsDiffs = P.Explicit dRefs | any (flip S.member removed) refs -> Nothing | otherwise -> - -- search only refs encountered in the import. + -- Search only refs encountered in the import. Just $ M.filterWithKey (const . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs P.Hiding dRefs | any (flip S.member removed) refs -> Nothing | otherwise -> - -- search only refs not encountered in the import. + -- Search only refs not encountered in the import. Just $ M.filterWithKey (const . not . flip elem refs) diffs where refs = foldMap (getRefs mn) dRefs - -- search all changed refs + -- Search all changed refs. P.Implicit -> Just diffs go s _ = Just s @@ -340,8 +403,6 @@ qualified :: P.Qualified b -> (ModuleName, b) qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) qualified _ = internalError "ExternsDiff: type is not qualified" -type RefWithDeps = (Ref, S.Set (ModuleName, Ref)) - -- | To get fixity's data constructor dependency we should provide it with the -- context (that contains all known refs) to search in. externsFixityToRef :: Map ModuleName (Set Ref) -> P.ExternsFixity -> RefWithDeps @@ -363,21 +424,25 @@ externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps externsDeclarationToRef moduleName = \case P.EDType n t tk - | isDictName n -> Nothing + | isDictTypeName n -> Nothing | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) -- P.EDTypeSynonym n args t -> Just (TypeRef n, typeDeps t <> foldArgs args) -- P.EDDataConstructor n _ tn t _ - | isDictName n -> Nothing + | isDictTypeName n -> Nothing | otherwise -> Just ( ConstructorRef tn n - , -- Add the type as a dependency: if the type has changed (e.g. - -- constructors removed/added) it should affect all the constructors - -- in the type. - S.insert (moduleName, TypeRef tn) (typeDeps t) + , -- Add the type as a dependency: if the type has changed (e.g. left side + -- param is added) we should recompile the module which uses the + -- constructor (even if there no the explicit type import). + -- Aso add the ad-hoc constructors set ref dependency: if a ctor + -- added/removed it should affect all constructors in the type, + -- because case statement's validity may be affected by newly added + -- or removed constructors. + typeDeps t <> S.fromList [(moduleName, TypeRef tn), (moduleName, CtorsSetRef tn)] ) -- P.EDValue n t -> @@ -415,12 +480,14 @@ externsDeclarationToRef moduleName = \case ) -- | Removes excessive info from declarations before comparing. +-- +-- TODO: params renaming will be needed to avoid recompilation because of params +-- name changes. stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration stripDeclaration = \case - P.EDType n t (P.DataType dt args ctors) -> - -- Remove data constructors types, we don't need them, we only need to know - -- if the list of ctors has changed. - P.EDType n t (P.DataType dt args (map (map (const [])) ctors)) + P.EDType n t (P.DataType dt args _) -> + -- Remove the notion of data constructors, we only compare type's left side. + P.EDType n t (P.DataType dt args []) -- P.EDInstance cn n fa ks ts cs ch chi ns ss -> P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss @@ -428,13 +495,7 @@ stripDeclaration = \case decl -> decl where emptySP = P.SourcePos 0 0 - -- emptySS = SourceSpan "" emptySP emptySP stripChain (ChainId (n, _)) = ChainId (n, emptySP) isPrimModule :: ModuleName -> Bool isPrimModule = flip S.member (S.fromList primModules) - --- | Check if type name is a type class dictionary name. -isDictName :: P.ProperName a -> Bool -isDictName = - T.isInfixOf "$" . P.runProperName diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 94f56fc449..97ea465999 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -147,7 +147,7 @@ setupSupportModules = do let modules = map snd ms supportExterns <- runExceptT $ do foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make' (makeActions modules foreigns) (CST.pureResult <$> modules) + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules) return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) @@ -231,7 +231,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do _ -> do unless hasExpectedModuleName $ error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." - compiledModulePath <$ P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + compiledModulePath <$ P.make_ actions (CST.pureResult <$> supportModules ++ map snd ms) getPsModuleName :: (a, AST.Module) -> T.Text getPsModuleName psModule = case snd psModule of From 82198faa51a817f3192cf2841866f202bc897831 Mon Sep 17 00:00:00 2001 From: Alex Date: Fri, 7 Jul 2023 18:44:13 +0500 Subject: [PATCH 077/105] Add comments to BuildPlan --- src/Language/PureScript/Make/BuildPlan.hs | 41 +++++++++++++++++------ 1 file changed, 30 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 8669233b0e..21a221f55f 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -36,24 +36,35 @@ import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) +-- This status tells if a module's exiting build artifacts are up to date with a +-- current module's content. It would be safe to re-use them, but only if +-- changes in its dependencies do require the module's rebuild. newtype UpToDateStatus = UpToDateStatus Bool isUpToDate :: UpToDateStatus -> Bool isUpToDate (UpToDateStatus b) = b +data Prebuilt = Prebuilt + { pbExternsFile :: ExternsFile + } + -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt + -- ^ Valid prebuilt results for modules, that are needed for rebuild, but + -- their rebuild is not required. , bpPreviousBuilt :: M.Map ModuleName (UpToDateStatus, Prebuilt) + -- ^ Previously built results for modules that are potentially required to be + -- rebuilt. We will always rebuild not up to date modules. But we will only + -- rebuild up to date modules, if their deps' externs have effectively + -- changed. Previously built result is needed to compare previous and newly + -- built externs to know what have changed. , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env , bpIndex :: C.MVar Int } -data Prebuilt = Prebuilt - { pbExternsFile :: ExternsFile - } newtype BuildJob = BuildJob { bjResult :: C.MVar BuildJobResult @@ -152,7 +163,6 @@ getPrevResult :: BuildPlan -> ModuleName -> Maybe (UpToDateStatus, ExternsFile) getPrevResult buildPlan moduleName = fmap pbExternsFile <$> M.lookup moduleName (bpPreviousBuilt buildPlan) - data Options = Options { optPreloadAllExterns :: Bool } @@ -278,24 +288,33 @@ construct Options{..} MakeActions{..} cacheDb (sorted, graph) = do splitModules :: [RebuildStatus] -> (M.Map ModuleName (Maybe (UpToDateStatus, UTCTime)), M.Map ModuleName UTCTime) splitModules = foldl' collectByStatus (M.empty, M.empty) - collectByStatus (build, prev) (RebuildStatus mn rebuildNever _ mbPb upToDate) - | Nothing <- mbPb = (M.insert mn Nothing build, prev) + collectByStatus (build, prebuilt) (RebuildStatus mn rebuildNever _ mbPb upToDate) + -- To build if no prebuilt result exits. + | Nothing <- mbPb = (M.insert mn Nothing build, prebuilt) + -- To build if not up to date. | Just pb <- mbPb, not upToDate = toRebuild (False, pb) + -- To prebuilt because of policy. | Just pb <- mbPb, rebuildNever = toPrebuilt pb + -- In other case analyze compilation times of dependencies. | Just pb <- mbPb = do let deps = moduleDeps mn - let modTimes = map (flip M.lookup prev) deps + let modTimes = map (flip M.lookup prebuilt) deps case maximumMaybe (catMaybes modTimes) of -- Check if any of deps where build later. This means we should - -- recompile even if the source is up-to-date. + -- recompile even if the module's source is up-to-date. This may + -- happen due to some partial builds or ide compilation + -- workflows involved that do not assume full project + -- compilation. We should treat those modules as NOT up to date + -- to ensure they are rebuilt. Just depModTime | pb < depModTime -> toRebuild (False, pb) - -- If one of the deps is not in the prebuilt, we should rebuild. + -- If one of the deps is not in the prebuilt, though the module + -- is up to date, we should add it in the rebuild queue. _ | any isNothing modTimes -> toRebuild (upToDate, pb) _ -> toPrebuilt pb where - toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prev) - toPrebuilt v = (build, M.insert mn v prev) + toRebuild (up, t) = (M.insert mn (Just (UpToDateStatus up, t)) build, prebuilt) + toPrebuilt v = (build, M.insert mn v prebuilt) maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing From fa35d0959a4f4ec6396d742eb0c3afdd74a658e2 Mon Sep 17 00:00:00 2001 From: Alex Date: Sat, 24 Feb 2024 21:03:31 +0500 Subject: [PATCH 078/105] Added requested changes, don't recompile downstream after the error, tests updated and commented. --- src/Language/PureScript/Make.hs | 10 +- src/Language/PureScript/Make/ExternsDiff.hs | 25 +- tests/TestMake.hs | 402 ++++++++++++-------- 3 files changed, 269 insertions(+), 168 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 07810192c9..55a17d3468 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -353,7 +353,15 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff - Nothing -> return BuildJobSkipped + -- If we got Nothing for deps externs, that means one of the deps failed + -- to compile. Though if we have a previous built result we will keep to + -- avoid potentially unnecessary recompilation next time. + Nothing -> return $ + case BuildPlan.getPrevResult buildPlan moduleName of + Just (_, exts) -> + BuildJobSucceeded (MultipleErrors []) exts (Just (emptyDiff moduleName)) + Nothing -> + BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 31530ccce0..910fd1a963 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -11,6 +11,7 @@ import Data.Graph as G (graphFromEdges, reachable) import Data.List qualified as L import Data.Map qualified as M import Data.Set qualified as S + import Language.PureScript.AST qualified as P import Language.PureScript.AST.Declarations.ChainId (ChainId (..)) import Language.PureScript.Constants.Prim (primModules) @@ -20,7 +21,6 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P -import Language.PureScript.Environment (isDictTypeName) -- Refs structure appropriate for storing and checking externs diffs. data Ref @@ -63,7 +63,6 @@ isRefRemoved _ = False -- present in new extern's exports) or changed in dependencies. getReExported :: P.ExternsFile -> P.ExternsFile -> ModuleRefsMap -> RefsWithStatus getReExported newExts oldExts depsDiffsMap = - -- S.fromList $ map snd $ filter checkRe oldExports M.fromList $ mapMaybe checkRe oldExports where goRe (P.ReExportRef _ es ref) = (P.exportSourceDefinedIn es,) <$> toRefs ref @@ -136,9 +135,7 @@ getChanged newExts oldExts depsDiffsMap = -- combining Declarations, Fixities and Type Fixities - as they are -- separated in externs we handle them separately. We don't care about added things. (_, removed, changed, unchangedRefs) = - foldl - zipTuple4 - (mempty, mempty, mempty, mempty) + fold [ declsSplit , splitRefs (getFixities newExts) (getFixities oldExts) (pure . externsFixityToRef fixityCtx) , splitRefs (getTypeFixities newExts) (getTypeFixities oldExts) (pure . externsTypeFixityToRef) @@ -224,6 +221,8 @@ diffExterns newExts oldExts depsDiffs = affectedLocalRefs = M.fromSet (const Updated) $ getAffectedLocal modName diffsMapWithLocal unchangedRefs +-- Checks if the externs diffs effect the module (the module uses any diff's +-- entries). True if uses, False if not. checkDiffs :: P.Module -> [ExternsDiff] -> Bool checkDiffs (P.Module _ _ _ decls exports) diffs | all isEmpty diffs = False @@ -233,12 +232,14 @@ checkDiffs (P.Module _ _ _ decls exports) diffs where mbSearch = makeSearches decls diffs searches = fromMaybe S.empty mbSearch + -- Check if the module reexports any of searched refs. checkReExports = flip (maybe False) exports $ any $ \case P.ModuleRef _ mn -> not . null $ S.filter ((== Just mn) . fst) searches _ -> False -- Goes though the module and try to find any usage of the refs. +-- Takes a set of refs to search in module's declarations, if found returns True. checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool checkUsage searches decls = foldMap findUsage decls /= mempty where @@ -254,7 +255,7 @@ checkUsage searches decls = foldMap findUsage decls /= mempty stripCtorType x = x searches' = S.map (map stripCtorType) searches - check = (\x -> [x | x]) . flip S.member searches' . toSearched + check = Any . flip S.member searches' . toSearched checkType = check . map TypeRef checkTypeOp = check . map TypeOpRef @@ -362,10 +363,6 @@ isEmpty (ExternsDiff _ refs) type Tuple4 m a = (m a, m a, m a, m a) -zipTuple4 :: Monoid (m a) => Tuple4 m a -> Tuple4 m a -> Tuple4 m a -zipTuple4 (f1, s1, t1, fo1) (f2, s2, t2, fo2) = - (f1 <> f2, s1 <> s2, t1 <> t2, fo1 <> fo2) - -- | Returns refs as a tuple of four (added, removed, changed, unchanged). splitRefs :: Ord r => Eq a => [a] -> [a] -> (a -> Maybe r) -> Tuple4 [] r splitRefs new old toRef = @@ -378,8 +375,8 @@ splitRefs new old toRef = go ref decl (a, r, c, u) = case M.lookup ref newMap of Nothing -> (a, r <> [ref], c, u) Just newDecl - | decl /= newDecl -> (a, r, c <> [ref], u) - | otherwise -> (a, r, c, u <> [ref]) + | decl /= newDecl -> (a, r, ref : c, u) + | otherwise -> (a, r, c, ref : u) -- | Traverses the type and finds all the refs within. typeDeps :: P.Type a -> S.Set (ModuleName, Ref) @@ -424,14 +421,14 @@ externsTypeFixityToRef (P.ExternsTypeFixity _ _ n alias) = externsDeclarationToRef :: ModuleName -> P.ExternsDeclaration -> Maybe RefWithDeps externsDeclarationToRef moduleName = \case P.EDType n t tk - | isDictTypeName n -> Nothing + | P.isDictTypeName n -> Nothing | otherwise -> Just (TypeRef n, typeDeps t <> typeKindDeps tk) -- P.EDTypeSynonym n args t -> Just (TypeRef n, typeDeps t <> foldArgs args) -- P.EDDataConstructor n _ tn t _ - | isDictTypeName n -> Nothing + | P.isDictTypeName n -> Nothing | otherwise -> Just ( ConstructorRef tn n diff --git a/tests/TestMake.hs b/tests/TestMake.hs index e08cda7314..c5d51f44c8 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -47,8 +47,8 @@ spec = do let foreignJsPath name = sourcesDir (T.unpack name <> ".js") -- Test helpers. - let testN fn name modules compile2 res = - fn name $ do + let testN itFn name modules compileFn res = + itFn name $ do let names = map (\(mn, _, _) -> mn) modules let paths = map modulePath names let timestamp = utcMidnightOnDate 2019 1 @@ -61,7 +61,7 @@ spec = do forM_ (zip [length modules..] modules) $ \(idx, (mn, _, mbContent)) -> do maybe (pure ()) (writeFile (modulePath mn) (timestamp idx)) mbContent - compile2 paths `shouldReturn` moduleNames res + compileFn paths `shouldReturn` moduleNames res let test2 fn name (mAContent1, mAContent2, mBContent) res = testN fn name @@ -73,7 +73,7 @@ spec = do testN fn name [ ("A", mAContent1, Just mAContent2) , ("B", mBContent, Nothing) - ] compileAllowingFailures res + ] compileWithFailure res let test3 fn name (mAContent1, mAContent2, mBContent, mCContent) res = testN fn name @@ -87,16 +87,16 @@ spec = do [ ("A", mAContent1, Just mAContent2) , ("B", mBContent, Nothing) , ("C", mCContent, Nothing) - ] compileAllowingFailures res + ] compileWithFailure res let recompile2 fn name ms = - test2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + test2 fn ("recompiles downstream when " <> name) ms ["A", "B"] let recompileWithFailure2 fn name ms = - testWithFailure2 fn ("recompiles when upstream changed effectively: " <> name) ms ["A", "B"] + testWithFailure2 fn ("recompiles downstream when " <> name) ms ["A", "B"] let noRecompile2 fn name ms = - test2 fn ("does not recompile when upstream not changed effectively: " <> name) ms ["A"] + test2 fn ("does not recompile downstream when " <> name) ms ["A"] before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do it "does not recompile if there are no changes" $ do @@ -157,6 +157,75 @@ spec = do removeFile mFFIPath compile [mPath] `shouldReturn` moduleNames ["Module"] + it "does not necessarily recompile modules which were not part of the previous batch" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mCPath = modulePath "C" + modulePaths = [mAPath, mBPath, mCPath] + + batch1 = [mAPath, mBPath] + batch2 = [mAPath, mCPath] + + mAContent = "module A where\nfoo = 0\n" + mBContent = "module B where\nimport A (foo)\nbar = foo\n" + mCContent = "module C where\nbaz = 3\n" + + writeFile mAPath timestampA mAContent + writeFile mBPath timestampB mBContent + writeFile mCPath timestampC mCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + + compile batch1 `shouldReturn` moduleNames [] + compile batch2 `shouldReturn` moduleNames [] + + it "recompiles if a module fails to compile" $ do + let mPath = sourcesDir "Module.purs" + moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" + + writeFile mPath timestampA moduleContent + compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] + compileWithFailure [mPath] `shouldReturn` moduleNames ["Module"] + + it "recompiles if docs are requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" + + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } + go opts = compileWithOptions opts [mPath] >>= assertSuccess + + writeFile mPath timestampA moduleContent1 + go optsWithDocs `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing docs.json is now outdated, the module should be + -- recompiled. + go optsWithDocs `shouldReturn` moduleNames ["Module"] + + it "recompiles if CoreFn is requested but not up to date" $ do + let mPath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } + go opts = compileWithOptions opts [mPath] >>= assertSuccess + + writeFile mPath timestampA moduleContent1 + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + writeFile mPath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing CoreFn.json is now outdated, the module should be + -- recompiled. + go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + + -- Cut off rebuild tests. + + -- If a module is compiled with effective changes for downstream they should + -- be rebuilt too. it "recompiles downstream modules when a module is rebuilt and externs changed" $ do let mAPath = modulePath "A" mBPath = modulePath "B" @@ -171,7 +240,9 @@ spec = do writeFile mAPath timestampC mAContent2 compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] - it "only recompiles downstream modules when a module is rebuilt end externs changed" $ do + -- If a module is compiled with no effective changes for downstream they should + -- not be rebuilt. + it "recompiles downstream modules only when a module is rebuilt end externs changed" $ do let mAPath = modulePath "A" mBPath = modulePath "B" mCPath = modulePath "C" @@ -190,6 +261,8 @@ spec = do writeFile mAPath timestampD mAContent2 compile modulePaths `shouldReturn` moduleNames ["A", "B"] + -- If module is compiled separately (e.g., with ide). Then downstream should + -- be rebuilt during the next build. it "recompiles downstream after a module has been rebuilt separately" $ do let mAPath = modulePath "A" mBPath = modulePath "B" @@ -214,8 +287,46 @@ spec = do compile mPaths `shouldReturn` moduleNames ["B", "C"] - -- Reexports. - test3 it "recompiles downstream modules when a reexported module changed" + -- If a module failed to compile, then the error is fixed and there are no + -- effective changes for downstream modules, they should not be recompiled. + it "does not recompile downstream modules after the error fixed and externs not changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" + mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" + mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + + writeFile mAPath timestampD mAContent1 + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + + -- If a module failed to compile, then the error is fixed and there are + -- effective changes for downstream modules, they should be recompiled. + it "recompiles downstream modules after the error fixed and externs changed" $ do + let mAPath = modulePath "A" + mBPath = modulePath "B" + mAContent1 = "module A where\nfoo :: Int\nfoo = 0\n" + mAContent2 = "module A where\nfoo :: Char\nfoo = 0\n" + mAContent3 = "module A where\nfoo :: Char\nfoo = '0'\n" + mBContent = "module B where\nimport A as A\nbar :: Int\nbar = A.foo\n" + + writeFile mAPath timestampA mAContent1 + writeFile mBPath timestampB mBContent + compile [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFile mAPath timestampC mAContent2 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A"] + writeFile mAPath timestampD mAContent3 + compileWithFailure [mAPath, mBPath] `shouldReturn` moduleNames ["A", "B"] + + -- Reexports: original ref is changed. + test3 it "recompiles downstream when a reexported ref changed" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here , "module B (module E) where\nimport A (foo) as E\n" @@ -223,13 +334,54 @@ spec = do ) ["A", "B", "C"] - -- test3 fit "reexported module changed" - -- ( "module A where\ndata ABC = A Int | B\n" - -- , "module A where\ndata ABC = A String | B\n" -- change externs here - -- , "module B (module E) where\nimport A (ABC(..)) as E\n" - -- , "module C where\nimport B as B\nbaz = B.A\n" - -- ) - -- ["A", "B", "C"] + -- Reexports: original ref is changed. Ref is imported but not used. + test3 it "does not recompile downstream when a reexported ref changed and the ref is imported but not used" + ( "module A where\nfoo = 0\n" + , "module A where\nfoo = '1'\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + -- Import but not use. + , "module C where\nimport B (foo)\nx = 1\n" + ) + ["A", "B"] + + -- Reexports: original export is removed from module. + testWithFailure3 it "recompiles downstream when a reexported ref removed" + ( "module A where\nfoo = 0\n" + , "module A where\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["A", "B", "C"] + + -- Reexports: ref is removed from reexporting module. + testWithFailure3 it "recompiles downstream when a reexported ref removed (from reexported)" + ( "module B (module E) where\nimport A (foo) as E\n" + , "module B where\nimport A (foo) as E\n" + , "module A where\nfoo = 0\n" + , "module C where\nimport B as B\nbaz = B.foo\n" + ) + ["B", "C"] + + -- Reexports: ref is imported but not used. Reexport ref is removed from + -- reexporting module. + testWithFailure3 it "recompiles downstream when a reexported ref removed (imported but not used)" + ( "module B (module E) where\nimport A (foo) as E\n" + , "module B where\nimport A (foo) as E\n" + , "module A where\nfoo = 0\n" + -- Import but not use. + , "module C where\nimport B (foo) as B\nx=1\n" + ) + ["B", "C"] + + -- Reexports: original ref Removed. Ref is imported but not used. + testWithFailure3 it "recompiles downstream when a reexported ref removed in original" + ( "module A where\nfoo = 0\n" + , "module A where\nbar = 1\n" -- change externs here + , "module B (module E) where\nimport A as E\n" + -- Import but not use. + , "module C where\nimport B (foo)\nx = 1\n" + ) + ["A", "B", "C"] -- Imports. testWithFailure2 it "recompiles downstream when removed reference found in imports" @@ -246,10 +398,8 @@ spec = do ) ["A"] - -- Usage in the code - -- signature - - -- inlined + -- We need to ensure that it finds refs everywhere inside a module. + -- Usage: Inlined type. testWithFailure2 it "recompiles downstream when found changed inlined type" ( "module A where\ntype T = Int\n" , "module A where\ntype T = String\n" @@ -257,7 +407,8 @@ spec = do ) ["A", "B"] - -- Transitive change. + -- Transitive change: module A changes, module B depends on A and module C + -- depends on B are both recompiled. test3 it "recompiles downstream due to transitive change" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\n" @@ -266,7 +417,7 @@ spec = do ) ["A", "B", "C"] - test3 it "do not recompile downstream if no transitive change" + test3 it "does not recompile downstream if no transitive change" ( "module A where\nfoo = 0\n" , "module A where\nfoo = '1'\n" , "module B where\nimport A (foo)\nbar = 1\nqux = foo" @@ -274,44 +425,50 @@ spec = do ) ["A", "B"] - noRecompile2 it "unused type changed" + -- Non effective change does not cause downstream rebuild. + test2 it "does not recompile downstream if unused type changed" ( "module A where\ntype SynA = Int\ntype SynA2 = Int" , "module A where\ntype SynA = String\ntype SynA2 = Int" , "module B where\nimport A as A\ntype SynB = A.SynA2" ) + ["A"] - -- Type synonyms. + -- Type synonym change. recompile2 it "type synonym changed" ( "module A where\ntype SynA = Int\n" , "module A where\ntype SynA = String\n" , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" ) + -- Type synonym indirect change. recompile2 it "type synonym dependency changed" ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" , "module A where\ntype SynA = String\ntype SynA2 = SynA\n" , "module B where\nimport A as A\ntype SynB = Array A.SynA2\n" ) - -- Data types. + -- Data type: parameter added. recompile2 it "data type changed (parameter added)" ( "module A where\ndata T = A Int | B Int\n" , "module A where\ndata T a = A Int | B a\n" , "module B where\nimport A (T)\ntype B = T" ) + -- Data type: constructor added. recompile2 it "data type changed (constructor added)" - ( "module A where\ndata T = A Int | B Int\n" - , "module A where\ndata T = A Int | B Int | C Int\n" + ( "module A where\ndata T = A | B\n" + , "module A where\ndata T = A | B | C\n" , "module B where\nimport A (T(B))\nb = B" ) + -- Data type: constructor indirectly changed. recompile2 it "data type constructor dependency changed" ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" , "module B where\nimport A (AB(..))\nb = A" ) + -- Data type: constructor changed but not used. noRecompile2 it "data type constructor changed, but not used" ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" , "module A where\ntype SynA = String\ndata AB = A SynA | B Int\n" @@ -319,14 +476,40 @@ spec = do , "module B where\nimport A (AB(..))\ntype B = AB\nb = B" ) + -- Data type: constructor added, but not imported. + noRecompile2 it "data type constructor added, but ctors not imported" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use just type + , "module B where\nimport A (AB)\ntype B = AB\n" + ) - -- Value operators. + -- Data type: constructor added, but not used. + noRecompile2 it "data type constructor added, but ctors not imported" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use type + , "module B where\nimport A (AB(..))\ntype B = AB\n" + ) + + -- Data type: constructor added, and constructors are used in the downstream + -- module (this may be need when there is a case statement without wildcard, + -- but we don't analyze the usage that deep). + recompile2 it "data type constructor added and ctors are used" + ( "module A where\ntype SynA = Int\ndata AB = A SynA | B Int\n" + , "module A where\ntype SynA = String\ndata AB = A SynA | B Int | C\n" + -- use type and other constructor + , "module B where\nimport A (AB(..))\ntype B = AB\nb = B\n" + ) + + -- Value operator change. recompile2 it "value op changed" ( "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" , "module A where\ndata T a = T Int a\ninfixl 3 T as :+:\n" , "module B where\nimport A\nt = 1 :+: \"1\" " ) + -- Value operator indirect change. recompile2 it "value op dependency changed" ( "module A where\ndata T a = T a String\ninfixl 2 T as :+:\n" , "module A where\ndata T a = T Int a\ninfixl 2 T as :+:\n" @@ -334,20 +517,21 @@ spec = do ) - -- Type operators. + -- Type operator change. recompile2 it "type op changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" , "module A where\ndata T a b = T a b\ninfixl 3 type T as :+:\n" , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" ) + -- Type operator indirect change. recompile2 it "type op dependency changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" , "module A where\ndata T b a = T a b\ninfixl 2 type T as :+:\n" , "module B where\nimport A\nfn :: Int :+: String -> Int\nfn _ = 1" ) - -- Type classes. + -- Type classes changed. Downstream uses type class in signature. recompile2 it "type class changed" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Char\n" @@ -359,6 +543,7 @@ spec = do ] ) + -- Type classes changed. Downstream uses only its member. recompile2 it "type class changed (member affected)" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Char\n" @@ -369,6 +554,7 @@ spec = do ] ) + -- Type class instance added. recompile2 it "type class instance added" ( "module A where\nclass Cls a where m1 :: a -> Int\n" , "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" @@ -380,6 +566,7 @@ spec = do ] ) + -- Type class instance removed. recompileWithFailure2 it "type class instance removed" ( "module A where\nclass Cls a where m1 :: a -> Int\ninstance Cls Int where m1 _ = 1" , "module A where\nclass Cls a where m1 :: a -> Int\n" @@ -390,34 +577,26 @@ spec = do ] ) - test3 it "recompiles downstream if instance added for type" - ( "module A where\nimport B\nnewtype T = T Int\n" - , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module B where\nclass Cls a where m1 :: a -> Int\n" - , T.unlines - [ "module C where" - , "import A" - , "t = T 1" - ] - ) - ["A", "C"] - - test3 it "recompiles downstream if instance added for type" - ( "module A where\nimport B\nnewtype T = T Int\n" - , "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module B where\nclass Cls a where m1 :: a -> Int\n" + -- Type class instance added for a type. We need to recompile downstream + -- modules that use this type, because it can be effected (even if it + -- doesn't use type class as we do not analyze this). + test3 it "recompiles downstream if instance added for a type" + ( "module B where\nimport A\nnewtype T = T Int\n" + , "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module A where\nclass Cls a where m1 :: a -> Int\n" , T.unlines [ "module C where" - , "import A" + , "import B" , "t = T 1" ] ) - ["A", "C"] + ["B", "C"] - testWithFailure3 it "recompiles downstream if instance removed for type" - ( "module A where\nimport B\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" - , "module A where\nimport B\nnewtype T = T Int\n" - , "module B where\nclass Cls a where m1 :: a -> Int\n" + -- Type class instance removed for a type. + testWithFailure3 it "recompiles downstream if type class instance removed for a type" + ( "module B where\nimport A\nnewtype T = T Int\ninstance Cls T where m1 _ = 1" + , "module B where\nimport A\nnewtype T = T Int\n" + , "module A where\nclass Cls a where m1 :: a -> Int\n" , T.unlines [ "module C where" , "import A" @@ -426,9 +605,12 @@ spec = do , "i = m1 (T 1)" ] ) - ["A", "C"] + ["B", "C"] - testN it "doesn't recompile downstream if an instance added for the type and type class changed" + -- Type class instance added for the type and type class in another module + -- it self is modified. We don't need to recompile downstream modules that + -- depend only on type (if they use type class they will be recompiled). + testN it "does not recompile downstream if an instance added for the type and type class changed" [ ( "A" , "module A where\nclass Cls a where m1 :: a -> Char\n" , Just "module A where\nclass Cls a where m1 :: a -> Int\n" @@ -440,100 +622,6 @@ spec = do , ("C", "module C where\nimport B\ntype C = T", Nothing) ] compile ["A", "B"] - it "does not recompile downstream modules when a module is rebuilt but externs have not changed" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] - - mAContent1 = "module A where\nfoo = 0\n" - mAContent2 = "module A (foo) where\nbar = 1\nfoo = 1\n" - mBContent = - T.unlines - [ "module B where" - , "import A (foo)" - , "import C (baz)" - , "bar = foo" - , "qux = baz" - ] - mCContent = "module C where\nbaz = 3\n" - - writeFile mAPath timestampA mAContent1 - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - -- - writeFile mAPath timestampD mAContent2 - threadDelay oneSecond - compile modulePaths `shouldReturn` moduleNames ["A"] - -- compile again to check that it won't try recompile skipped module again - compile modulePaths `shouldReturn` moduleNames [] - - it "does not necessarily recompile modules which were not part of the previous batch" $ do - let mAPath = modulePath "A" - mBPath = modulePath "B" - mCPath = modulePath "C" - modulePaths = [mAPath, mBPath, mCPath] - - batch1 = [mAPath, mBPath] - batch2 = [mAPath, mCPath] - - mAContent = "module A where\nfoo = 0\n" - mBContent = "module B where\nimport A (foo)\nbar = foo\n" - mCContent = "module C where\nbaz = 3\n" - - writeFile mAPath timestampA mAContent - writeFile mBPath timestampB mBContent - writeFile mCPath timestampC mCContent - compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] - - compile batch1 `shouldReturn` moduleNames [] - compile batch2 `shouldReturn` moduleNames [] - - it "recompiles if a module fails to compile" $ do - let mPath = sourcesDir "Module.purs" - moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" - - writeFile mPath timestampA moduleContent - compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] - compileAllowingFailures [mPath] `shouldReturn` moduleNames ["Module"] - - it "recompiles if docs are requested but not up to date" $ do - let mPath = sourcesDir "Module.purs" - - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - - optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } - go opts = compileWithOptions opts [mPath] >>= assertSuccess - - writeFile mPath timestampA moduleContent1 - go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 - -- See Note [Sleeping to avoid flaky tests] - threadDelay oneSecond - go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing docs.json is now outdated, the module should be - -- recompiled. - go optsWithDocs `shouldReturn` moduleNames ["Module"] - - it "recompiles if CoreFn is requested but not up to date" $ do - let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" - optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } - go opts = compileWithOptions opts [mPath] >>= assertSuccess - - writeFile mPath timestampA moduleContent1 - go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 - -- See Note [Sleeping to avoid flaky tests] - threadDelay oneSecond - go P.defaultOptions `shouldReturn` moduleNames ["Module"] - -- Since the existing CoreFn.json is now outdated, the module should be - -- recompiled. - go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - -- Note [Sleeping to avoid flaky tests] -- -- One of the things we want to test here is that all requested output files @@ -595,14 +683,23 @@ assertSuccess (result, recompiled) = Right _ -> pure recompiled +assertFailure :: (Either P.MultipleErrors a, Set P.ModuleName) -> IO (Set P.ModuleName) +assertFailure (result, recompiled) = + case result of + Left _ -> + pure recompiled + Right _ -> + fail "should compile with errors" + -- | Compile, returning the set of modules which were rebuilt, and failing if -- any errors occurred. compile :: [FilePath] -> IO (Set P.ModuleName) compile input = compileWithResult input >>= assertSuccess -compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) -compileAllowingFailures input = fmap snd (compileWithResult input) +compileWithFailure :: [FilePath] -> IO (Set P.ModuleName) +compileWithFailure input = + compileWithResult input >>= assertFailure writeFile :: FilePath -> UTCTime -> T.Text -> IO () writeFile path mtime contents = do @@ -613,4 +710,3 @@ writeFile path mtime contents = do -- from other test results modulesDir :: FilePath modulesDir = ".test_modules" "make" - From d34d0e19f597cd1eea6377a713b7e179dce3a7fa Mon Sep 17 00:00:00 2001 From: Alex Date: Wed, 29 May 2024 22:31:54 +0500 Subject: [PATCH 079/105] Update ExternsDiff.checkUsage, add tests --- src/Language/PureScript/Make/ExternsDiff.hs | 50 ++++++--------- tests/TestMake.hs | 68 +++++++++++++++++---- 2 files changed, 77 insertions(+), 41 deletions(-) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 910fd1a963..5877b2c722 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -241,21 +241,22 @@ checkDiffs (P.Module _ _ _ decls exports) diffs -- Goes though the module and try to find any usage of the refs. -- Takes a set of refs to search in module's declarations, if found returns True. checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool -checkUsage searches decls = foldMap findUsage decls /= mempty +checkUsage searches decls = anyUsages where - findUsage decl = - let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty - in extr mempty decl + -- Two traversals: one to pick up usages of types, one for the rest. + Any anyUsages = + foldMap checkUsageInTypes decls + <> foldMap checkOtherUsages decls - toSearched = (,) <$> P.getQual <*> P.disqualify + -- To check data constructors we remove an origin type from it (see `checkCtor`). + searches' = S.map (map stripCtorType) searches -- To check data constructors we remove an origin type from it. emptyName = P.ProperName "" stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n stripCtorType x = x - searches' = S.map (map stripCtorType) searches - check = Any . flip S.member searches' . toSearched + check q = Any $ S.member (P.getQual q, P.disqualify q) searches' checkType = check . map TypeRef checkTypeOp = check . map TypeOpRef @@ -264,31 +265,21 @@ checkUsage searches decls = foldMap findUsage decls /= mempty checkCtor = check . map (ConstructorRef emptyName) checkClass = check . map TypeClassRef - onTypes = P.everythingOnTypes (<>) $ \case - P.TypeConstructor _ n -> checkType n - P.TypeOp _ n -> checkTypeOp n - P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) - _ -> mempty - - foldCtor f (P.DataConstructorDeclaration _ _ vars) = - foldMap (f . snd) vars + -- A nested traversal: pick up types in the module then traverse the structure of the types + (checkUsageInTypes, _, _, _, _) = + P.accumTypes $ P.everythingOnTypes (<>) $ \case + P.TypeConstructor _ n -> checkType n + P.TypeOp _ n -> checkTypeOp n + P.ConstrainedType _ c _ -> checkClass (P.constraintClass c) + _ -> mempty - constraintTypes = - foldMap (\c -> P.constraintArgs c <> P.constraintKindArgs c) + checkOtherUsages = + let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty + in extr mempty goDecl _ = \case - P.TypeDeclaration t -> onTypes (P.tydeclType t) - P.DataDeclaration _ _ _ _ ctors -> foldMap (foldCtor onTypes) ctors - P.TypeSynonymDeclaration _ _ _ t -> onTypes t - P.KindDeclaration _ _ _ t -> onTypes t - P.FixityDeclaration _ (Right (P.TypeFixity _ tn _)) -> - checkType tn - P.FixityDeclaration _ (Left (P.ValueFixity _ (P.Qualified by val) _)) -> - either (checkValue . P.Qualified by) (checkCtor . P.Qualified by) val - P.TypeClassDeclaration _ _ _ cs _ _ -> - foldMap onTypes (constraintTypes cs) - P.TypeInstanceDeclaration _ _ _ _ _ cs tc sts _ -> - foldMap onTypes (constraintTypes cs <> sts) <> checkClass tc + P.TypeInstanceDeclaration _ _ _ _ _ _ tc _ _ -> + checkClass tc _ -> mempty isLocal scope ident = P.LocalIdent ident `S.member` scope @@ -298,7 +289,6 @@ checkUsage searches decls = foldMap findUsage decls /= mempty | otherwise -> checkValue n P.Constructor _ n -> checkCtor n P.Op _ n -> checkValueOp n - P.TypedValue _ _ t -> onTypes t _ -> mempty goBinder _ binder = case binder of diff --git a/tests/TestMake.hs b/tests/TestMake.hs index c5d51f44c8..cf3e422c6f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -9,7 +9,7 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad (guard, void, forM_) +import Control.Monad (guard, void, forM_, when) import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) @@ -19,11 +19,13 @@ import Data.Text qualified as T import Data.Set (Set) import Data.Set qualified as Set import Data.Map qualified as M +import Data.Version (showVersion) +import Paths_purescript qualified as Paths import System.FilePath (()) import System.Directory (createDirectory, removeDirectoryRecursive, removeFile, setModificationTime) import System.IO.Error (isDoesNotExistError) -import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) +import System.IO.UTF8 (readUTF8FilesT, readUTF8FileT, writeUTF8FileT) import Test.Hspec (Spec, before_, it, shouldReturn) @@ -55,6 +57,9 @@ spec = do forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do writeFile (modulePath mn) (timestamp idx) content + -- Write a fake foreign module to bypass compiler's check. + when (T.isInfixOf "\nforeign import" content) $ + writeFile (foreignJsPath mn) (timestamp idx) content compile paths `shouldReturn` moduleNames names @@ -189,15 +194,15 @@ spec = do it "recompiles if docs are requested but not up to date" $ do let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + mContent1 = "module Module where\nx :: Int\nx = 1" + mContent2 = mContent1 <> "\ny :: Int\ny = 1" optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFile mPath timestampA moduleContent1 + writeFile mPath timestampA mContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 + writeFile mPath timestampB mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -207,14 +212,14 @@ spec = do it "recompiles if CoreFn is requested but not up to date" $ do let mPath = sourcesDir "Module.purs" - moduleContent1 = "module Module where\nx :: Int\nx = 1" - moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + mContent1 = "module Module where\nx :: Int\nx = 1" + mContent2 = mContent1 <> "\ny :: Int\ny = 1" optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } go opts = compileWithOptions opts [mPath] >>= assertSuccess - writeFile mPath timestampA moduleContent1 + writeFile mPath timestampA mContent1 go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] - writeFile mPath timestampB moduleContent2 + writeFile mPath timestampB mContent2 -- See Note [Sleeping to avoid flaky tests] threadDelay oneSecond go P.defaultOptions `shouldReturn` moduleNames ["Module"] @@ -222,6 +227,27 @@ spec = do -- recompiled. go optsCoreFnOnly `shouldReturn` moduleNames ["Module"] + it "recompiles if cache-db version differs from the current" $ do + let mPath = sourcesDir "Module.purs" + mContent = "module Module where\nfoo :: Int\nfoo = 1\n" + + writeFile mPath timestampA mContent + compile [mPath] `shouldReturn` moduleNames ["Module"] + + -- Replace version with illegal in cache-db file. + let cacheDbFilePath = P.cacheDbFile modulesDir + versionText ver = "\"version\":\"" <> ver <> "\"" + + cacheContent <- readUTF8FileT cacheDbFilePath + + let currentVer = T.pack (showVersion Paths.version) + let newContent = + T.replace (versionText currentVer) (versionText "0.0.0") cacheContent + + writeUTF8FileT cacheDbFilePath newContent + + compile [mPath] `shouldReturn` moduleNames ["Module"] + -- Cut off rebuild tests. -- If a module is compiled with effective changes for downstream they should @@ -433,6 +459,13 @@ spec = do ) ["A"] + -- Type synonym in foreign import. + recompile2 it "type synonym changed in foreign import" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nforeign import a :: A.SynA\n" + ) + -- Type synonym change. recompile2 it "type synonym changed" ( "module A where\ntype SynA = Int\n" @@ -440,6 +473,20 @@ spec = do , "module B where\nimport A as A\ntype SynB = Array A.SynA\n" ) + -- Type synonym change in value. + recompile2 it "type synonym changed in value" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nvalue = ([] :: Array A.SynA)\n" + ) + + -- Type synonym change in pattern. + recompile2 it "type synonym changed in pattern" + ( "module A where\ntype SynA = Int\n" + , "module A where\ntype SynA = String\n" + , "module B where\nimport A as A\nfn = \\(_ :: Array A.SynA) -> 0\n" + ) + -- Type synonym indirect change. recompile2 it "type synonym dependency changed" ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n" @@ -516,7 +563,6 @@ spec = do , "module B where\nimport A\nt = 1 :+: \"1\" " ) - -- Type operator change. recompile2 it "type op changed" ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n" From f58f5f0ebceb0b91710660e100b12d90489f20fc Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Sat, 30 Nov 2024 15:53:26 +0000 Subject: [PATCH 080/105] ExternsDiff: normalize type --- src/Language/PureScript/Make/ExternsDiff.hs | 47 ++++++++++++++++++++- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 5877b2c722..e00fb6400f 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -21,6 +21,7 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P +import Language.PureScript.Roles qualified as P -- Refs structure appropriate for storing and checking externs diffs. data Ref @@ -474,15 +475,57 @@ stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration stripDeclaration = \case P.EDType n t (P.DataType dt args _) -> -- Remove the notion of data constructors, we only compare type's left side. - P.EDType n t (P.DataType dt args []) + P.EDType n (normalizeType t) (P.DataType dt (normalizeDataTypeArgs args) []) + -- + P.EDTypeSynonym n args t -> + P.EDTypeSynonym n (normalizeTypeArgs args) (normalizeType t) -- P.EDInstance cn n fa ks ts cs ch chi ns ss -> - P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss + -- Normalize instance parameters and strip chain source positions + P.EDInstance cn n fa + (map normalizeType ks) + (map normalizeType ts) + cs + (map stripChain ch) + chi ns ss + -- + P.EDDataConstructor n o tc t f -> P.EDDataConstructor n o tc (normalizeType t) f -- + P.EDValue n t -> P.EDValue n (normalizeType t) + -- decl -> decl where emptySP = P.SourcePos 0 0 stripChain (ChainId (n, _)) = ChainId (n, emptySP) + -- Normalize type parameters to t0, t1, etc and strip source positions + normalizeType :: P.SourceType -> P.SourceType + normalizeType = P.everywhereOnTypes go + where + -- Strip source positions from annotations + stripAnn (ss, _) = (ss { P.spanStart = emptySP, P.spanEnd = emptySP }, []) + go (P.TypeVar ann name) = P.TypeVar (stripAnn ann) $ "t" <> show name + go (P.TypeConstructor ann n) = P.TypeConstructor (stripAnn ann) n + go (P.TypeOp ann n) = P.TypeOp (stripAnn ann) n + go (P.TypeApp ann t1 t2) = P.TypeApp (stripAnn ann) (normalizeType t1) (normalizeType t2) + go (P.KindApp ann t1 t2) = P.KindApp (stripAnn ann) (normalizeType t1) (normalizeType t2) + go (P.ForAll ann tv n t1 t2 s) = P.ForAll (stripAnn ann) tv n (fmap normalizeType t1) (normalizeType t2) s + go (P.ConstrainedType ann c t) = P.ConstrainedType (stripAnn ann) c (normalizeType t) + go (P.REmpty ann) = P.REmpty (stripAnn ann) + go (P.RCons ann n t r) = P.RCons (stripAnn ann) n (normalizeType t) r + go (P.KindedType ann t k) = P.KindedType (stripAnn ann) (normalizeType t) k + go (P.BinaryNoParensType ann op t1 t2) = P.BinaryNoParensType (stripAnn ann) op (normalizeType t1) (normalizeType t2) + go (P.ParensInType ann t) = P.ParensInType (stripAnn ann) (normalizeType t) + go other = other + + -- Normalize data type arguments + normalizeDataTypeArgs :: [(Text, Maybe P.SourceType, P.Role)] -> [(Text, Maybe P.SourceType, P.Role)] + normalizeDataTypeArgs = zipWith (\i (_, mt, r) -> ("t" <> show (i :: Int) , fmap normalizeType mt, r)) [0..] + + -- Normalize type arguments + normalizeTypeArgs :: [(Text, Maybe P.SourceType)] -> [(Text, Maybe P.SourceType)] + normalizeTypeArgs = zipWith (\i (_, mt) -> ("t" <> show (i :: Int), fmap normalizeType mt)) [0..] + + isPrimModule :: ModuleName -> Bool isPrimModule = flip S.member (S.fromList primModules) From 6be0c529f05142a1cec357c12727ad64e871f24c Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 2 Dec 2024 10:14:53 +0000 Subject: [PATCH 081/105] Normalize SourceSpan path in Externs --- src/Language/PureScript/Externs.hs | 20 ++++++++++++++------ src/Language/PureScript/Make.hs | 11 ++++++----- 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a949aacae6..8c777ceef6 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -22,7 +22,7 @@ import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Monad (join) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import Data.List (foldl', find) +import Data.List (foldl', find, isPrefixOf) import Data.Foldable (fold) import Data.Text (Text) import Data.Text qualified as T @@ -31,7 +31,7 @@ import Data.Map qualified as M import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) -import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan, pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) +import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan (spanName), pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType, Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), dictTypeName, makeTypeClassData) @@ -208,9 +208,9 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar -- happens in the CoreFn, not the original module AST, so it needs to be -- applied to the exported names here also. (The appropriate map is returned by -- `L.P.Renamer.renameInModule`.) -moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile -moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" -moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} +moduleToExternsFile :: FilePath -> Module -> Environment -> M.Map Ident Ident -> ExternsFile +moduleToExternsFile _ (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile currentDir (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where efVersion = T.pack currentVersion efModuleName = mn @@ -219,7 +219,15 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds efDeclarations = concatMap toExternsDeclaration exps - efSourceSpan = ss + efSourceSpan = ensureFullPath ss + + ensureFullPath :: SourceSpan -> SourceSpan + ensureFullPath s = s { spanName = makeAbsolute (spanName s) } + + makeAbsolute :: String -> String + makeAbsolute path + | "/" `isPrefixOf` path = path + | otherwise = currentDir <> "/" <> path fixityDecl :: Declaration -> Maybe ExternsFixity fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 55a17d3468..77cbf68e46 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -70,14 +70,14 @@ import Language.PureScript.Make.Monad as Monad getCurrentTime, copyFile ) import Language.PureScript.CoreFn qualified as CF -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (replaceExtension) -- | Rebuild a single module. -- rebuildModule :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) => MakeActions m -> [ExternsFile] -> Module @@ -88,7 +88,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) => MakeActions m -> Env -> [ExternsFile] @@ -98,7 +98,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) => MakeActions m -> Env -> [ExternsFile] @@ -111,6 +111,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ withPrim = importPrim m lint withPrim + pwd <- liftBase getCurrentDirectory ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' @@ -134,7 +135,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ corefn = CF.moduleToCoreFn env' mod' (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized - exts = moduleToExternsFile mod' env' renamedIdents + exts = moduleToExternsFile pwd mod' env' renamedIdents ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, From 4b697beb553d627554486b820eaa987271fe4ebf Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 2 Dec 2024 15:25:39 +0000 Subject: [PATCH 082/105] Revert "Normalize SourceSpan path in Externs" This reverts commit 6be0c529f05142a1cec357c12727ad64e871f24c. --- src/Language/PureScript/Externs.hs | 20 ++++++-------------- src/Language/PureScript/Make.hs | 11 +++++------ 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 8c777ceef6..a949aacae6 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -22,7 +22,7 @@ import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Monad (join) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) -import Data.List (foldl', find, isPrefixOf) +import Data.List (foldl', find) import Data.Foldable (fold) import Data.Text (Text) import Data.Text qualified as T @@ -31,7 +31,7 @@ import Data.Map qualified as M import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) -import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan (spanName), pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) +import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan, pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType, Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), dictTypeName, makeTypeClassData) @@ -208,9 +208,9 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar -- happens in the CoreFn, not the original module AST, so it needs to be -- applied to the exported names here also. (The appropriate map is returned by -- `L.P.Renamer.renameInModule`.) -moduleToExternsFile :: FilePath -> Module -> Environment -> M.Map Ident Ident -> ExternsFile -moduleToExternsFile _ (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" -moduleToExternsFile currentDir (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} +moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile +moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where efVersion = T.pack currentVersion efModuleName = mn @@ -219,15 +219,7 @@ moduleToExternsFile currentDir (Module ss _ mn ds (Just exps)) env renamedIdents efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds efDeclarations = concatMap toExternsDeclaration exps - efSourceSpan = ensureFullPath ss - - ensureFullPath :: SourceSpan -> SourceSpan - ensureFullPath s = s { spanName = makeAbsolute (spanName s) } - - makeAbsolute :: String -> String - makeAbsolute path - | "/" `isPrefixOf` path = path - | otherwise = currentDir <> "/" <> path + efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 77cbf68e46..55a17d3468 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -70,14 +70,14 @@ import Language.PureScript.Make.Monad as Monad getCurrentTime, copyFile ) import Language.PureScript.CoreFn qualified as CF -import System.Directory (doesFileExist, getCurrentDirectory) +import System.Directory (doesFileExist) import System.FilePath (replaceExtension) -- | Rebuild a single module. -- rebuildModule :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -88,7 +88,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -98,7 +98,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadBase IO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -111,7 +111,6 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ withPrim = importPrim m lint withPrim - pwd <- liftBase getCurrentDirectory ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' @@ -135,7 +134,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ corefn = CF.moduleToCoreFn env' mod' (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized - exts = moduleToExternsFile pwd mod' env' renamedIdents + exts = moduleToExternsFile mod' env' renamedIdents ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, From 6a96456fd0d79bf666b5a396f8538b7290f37c34 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 2 Dec 2024 16:14:08 +0000 Subject: [PATCH 083/105] Make relative path to actualFile --- src/Language/PureScript/Ide/Rebuild.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339eb..91419c265a 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -26,6 +26,7 @@ import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExtern import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), ModuleMap, Success(..)) import Language.PureScript.Ide.Util (ideReadFile) import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) -- | Given a filepath performs the following steps: -- @@ -54,6 +55,7 @@ rebuildFile -- ^ A runner for the second build with open exports -> m Success rebuildFile file actualFile codegenTargets runOpenBuild = do + currentDir <- liftIO getCurrentDirectory (fp, input) <- case List.stripPrefix "data:" file of Just source -> pure ("", Text.pack source) @@ -88,7 +90,8 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do Left errors -> throwError (RebuildError [(fp', input)] errors) Right newExterns -> do - insertModule (fromMaybe file actualFile, m) + let actualFile' = maybe file (makeRelative currentDir) actualFile + insertModule (actualFile', m) insertExterns newExterns void populateVolatileState _ <- updateCacheTimestamp From c9f69442f0d55363b67769225c84cc4673b18342 Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 2 Dec 2024 16:15:44 +0000 Subject: [PATCH 084/105] Revert 1 commits f58f5f0 'ExternsDiff: normalize type' --- src/Language/PureScript/Make/ExternsDiff.hs | 47 +-------------------- 1 file changed, 2 insertions(+), 45 deletions(-) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index e00fb6400f..5877b2c722 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -21,7 +21,6 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Names (ModuleName) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P -import Language.PureScript.Roles qualified as P -- Refs structure appropriate for storing and checking externs diffs. data Ref @@ -475,57 +474,15 @@ stripDeclaration :: P.ExternsDeclaration -> P.ExternsDeclaration stripDeclaration = \case P.EDType n t (P.DataType dt args _) -> -- Remove the notion of data constructors, we only compare type's left side. - P.EDType n (normalizeType t) (P.DataType dt (normalizeDataTypeArgs args) []) - -- - P.EDTypeSynonym n args t -> - P.EDTypeSynonym n (normalizeTypeArgs args) (normalizeType t) + P.EDType n t (P.DataType dt args []) -- P.EDInstance cn n fa ks ts cs ch chi ns ss -> - -- Normalize instance parameters and strip chain source positions - P.EDInstance cn n fa - (map normalizeType ks) - (map normalizeType ts) - cs - (map stripChain ch) - chi ns ss - -- - P.EDDataConstructor n o tc t f -> P.EDDataConstructor n o tc (normalizeType t) f + P.EDInstance cn n fa ks ts cs (map stripChain ch) chi ns ss -- - P.EDValue n t -> P.EDValue n (normalizeType t) - -- decl -> decl where emptySP = P.SourcePos 0 0 stripChain (ChainId (n, _)) = ChainId (n, emptySP) - -- Normalize type parameters to t0, t1, etc and strip source positions - normalizeType :: P.SourceType -> P.SourceType - normalizeType = P.everywhereOnTypes go - where - -- Strip source positions from annotations - stripAnn (ss, _) = (ss { P.spanStart = emptySP, P.spanEnd = emptySP }, []) - go (P.TypeVar ann name) = P.TypeVar (stripAnn ann) $ "t" <> show name - go (P.TypeConstructor ann n) = P.TypeConstructor (stripAnn ann) n - go (P.TypeOp ann n) = P.TypeOp (stripAnn ann) n - go (P.TypeApp ann t1 t2) = P.TypeApp (stripAnn ann) (normalizeType t1) (normalizeType t2) - go (P.KindApp ann t1 t2) = P.KindApp (stripAnn ann) (normalizeType t1) (normalizeType t2) - go (P.ForAll ann tv n t1 t2 s) = P.ForAll (stripAnn ann) tv n (fmap normalizeType t1) (normalizeType t2) s - go (P.ConstrainedType ann c t) = P.ConstrainedType (stripAnn ann) c (normalizeType t) - go (P.REmpty ann) = P.REmpty (stripAnn ann) - go (P.RCons ann n t r) = P.RCons (stripAnn ann) n (normalizeType t) r - go (P.KindedType ann t k) = P.KindedType (stripAnn ann) (normalizeType t) k - go (P.BinaryNoParensType ann op t1 t2) = P.BinaryNoParensType (stripAnn ann) op (normalizeType t1) (normalizeType t2) - go (P.ParensInType ann t) = P.ParensInType (stripAnn ann) (normalizeType t) - go other = other - - -- Normalize data type arguments - normalizeDataTypeArgs :: [(Text, Maybe P.SourceType, P.Role)] -> [(Text, Maybe P.SourceType, P.Role)] - normalizeDataTypeArgs = zipWith (\i (_, mt, r) -> ("t" <> show (i :: Int) , fmap normalizeType mt, r)) [0..] - - -- Normalize type arguments - normalizeTypeArgs :: [(Text, Maybe P.SourceType)] -> [(Text, Maybe P.SourceType)] - normalizeTypeArgs = zipWith (\i (_, mt) -> ("t" <> show (i :: Int), fmap normalizeType mt)) [0..] - - isPrimModule :: ModuleName -> Bool isPrimModule = flip S.member (S.fromList primModules) From 48be80d01d904bd3b2cf575ef0e61057c640ea22 Mon Sep 17 00:00:00 2001 From: Adrian Sieber <36796532+ad-si@users.noreply.github.com> Date: Thu, 10 Apr 2025 10:37:23 +0000 Subject: [PATCH 085/105] Upgrade to GHC 9.6.6 (#4568) * Upgrade CI * Back to the previous haskell image * Use new spavo * Upgrade node to latest supported lts * Upgrade to GHC 9.6.6 - Switch from `ansi-wl-pprint` to `prettyprinter` - Add several `extra-deps` * Upgrade CI to use GHC 9.6.6 * Upgrade GitHub Actions * CI: Upgrade to macos-15, specify exact version of Ubuntu * CI: Upgrade Stack from 2.15.1 to 3.3.1 * CI: Include stack.yaml.lock file and use it for the cache's file hashes * CI: Also include `purescript.cabal` in cache's file hashes * Update documentation * CI: Remove obsolete directory ownership changes * CI: Add safe.directory configuration for Ubuntu 24.04 * CI: Fix container ownership issues in workflow configuration * CI: Simplify container configuration and fix working directory ownership for Ubuntu 24.04 * Update version ranges of dependencies * Update Cabal version range and allow newer dependencies in stack configuration * Update Cabal version to 3.10.3.0 in stack configuration * Enable allow-newer option in stack configuration * Update dependency versions in purescript.cabal and stack.yaml * Update weeder installation and streamline CI workflow * Fix wrapping of run commands * Remove obsolete quotes * Add missing `--name` flag to `spago init` * Add Adrian Sieber to contributors * Add changelog entry for GHC upgrade * Use new weeder.toml config file format * Install missing `jq` dependency * CI: Use `-y` flag for all `apt-get install` runs * Vendor pattern-arrows * Run haskell container on ubuntu-latest, use macos-13 and macos-14 * CI: Use strings instead of arrays for matrix.os * Fix Hlint warnings * Add arm64 Linux to testing matrix * Correctly match only self-hosted Linux runner * Don't use self-hosted runners anymore, as GitHub runners cover all cases * Mention glibc bump from `2.28` to `2.31` in changelog * Upgrade to latest version of aeson-better-errors from Hackage * Remove obsolete `allow-newer` section, delete .stack-work on make clean * Re-add `allow-newer` block, improve dependency bounds * Downgrade haskeline to 0.8.2 to avoid libtinfo issues * Update aeson-better-errors and use cheapskate fork * Fix build errors in stack These errors are present in the Cabal build and seem to be caused by Cabal and Stack using different versions of mtl, with 2.3.x notably changing re-exports for certain modules. --------- Co-authored-by: Fabrizio Ferrai Co-authored-by: Justin Garcia --- .github/workflows/ci.yml | 121 +++++++----------- .gitignore | 1 - CHANGELOG.d/internal_upgrade_to_ghc_9.6.md | 2 + CONTRIBUTORS.md | 1 + INSTALL.md | 5 +- LICENSE | 24 ---- Makefile | 5 + app/Command/Docs.hs | 15 ++- app/Main.hs | 9 +- cabal.project | 5 + ci/build-package-set.sh | 16 +-- purescript.cabal | 47 +++---- src/Control/Monad/Supply/Class.hs | 2 + src/Control/PatternArrows.hs | 118 +++++++++++++++++ src/Language/PureScript/CodeGen/JS.hs | 1 - .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../Docs/RenderedCode/RenderType.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 1 - src/Language/PureScript/Pretty/Types.hs | 4 +- .../PureScript/Sugar/BindingGroups.hs | 6 +- src/Language/PureScript/TypeChecker/Monad.hs | 1 + .../PureScript/TypeChecker/Synonyms.hs | 1 + stack.yaml | 30 ++--- stack.yaml.lock | 58 +++++++++ update-changelog.hs | 3 +- weeder.dhall | 41 ------ weeder.toml | 40 ++++++ 27 files changed, 347 insertions(+), 216 deletions(-) create mode 100644 CHANGELOG.d/internal_upgrade_to_ghc_9.6.md create mode 100644 src/Control/PatternArrows.hs create mode 100644 stack.yaml.lock delete mode 100644 weeder.dhall create mode 100644 weeder.toml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2cd314dbf1..3557db1a6f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,6 +20,7 @@ on: - purescript.cabal - Setup.hs - stack.yaml + - stack.yaml.lock - update-changelog.hs - weeder.dhall release: @@ -32,7 +33,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.15.1" + STACK_VERSION: "3.3.1" concurrency: # We never want two prereleases building at the same time, since they would @@ -53,16 +54,18 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: include: - - # If upgrading the Haskell image, also upgrade it in the lint job below - os: ["ubuntu-latest"] - image: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb - - os: ["macOS-14"] - - os: ["windows-2019"] - - os: ["self-hosted", "macos", "ARM64"] - - os: ["self-hosted", "Linux", "ARM64"] + - image: haskell:9.6.6 # Also upgrade version in the lint job below + os: ubuntu-latest # Exact version is not important, as it's only the container host) + + - image: haskell:9.6.6 + os: ubuntu-24.04-arm # Exact version is not important, as it's only the container host + + - os: macos-13 # x64 + - os: macos-14 # arm64 + - os: windows-2019 # x64 runs-on: "${{ matrix.os }}" - container: "${{ matrix.image }}" + container: "${{ matrix.image }}" outputs: do-not-prerelease: "${{ steps.build.outputs.do-not-prerelease }}" @@ -71,43 +74,40 @@ jobs: steps: - # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. name: "(Linux only) Install gh" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') run: | curl -fsSL https://cli.github.com/packages/githubcli-archive-keyring.gpg | dd of=/usr/share/keyrings/githubcli-archive-keyring.gpg chmod go+r /usr/share/keyrings/githubcli-archive-keyring.gpg echo "deb [arch=$(dpkg --print-architecture) signed-by=/usr/share/keyrings/githubcli-archive-keyring.gpg] https://cli.github.com/packages stable main" | tee /etc/apt/sources.list.d/github-cli.list > /dev/null apt-get update - apt-get install gh + apt-get install -y gh - - uses: "actions/checkout@v2" - - uses: "actions/setup-node@v2" + - uses: "actions/checkout@v4" + - uses: "actions/setup-node@v4" with: - node-version: "16" + node-version: "22" - id: "haskell" name: "(Non-Linux only) Install Haskell" - # Note: here we exclude the self-hosted runners because this action does not work on ARM - # and their Haskell environment is instead provided by a nix-shell - # See https://github.com/purescript/purescript/pulls/4455 - if: "!contains(matrix.os, 'ubuntu-latest') && !contains(matrix.os, 'self-hosted')" + if: startsWith(matrix.os, 'macos') || startsWith(matrix.os, 'windows') uses: "haskell-actions/setup@v2" with: + ghc-version: "9.6.6" enable-stack: true stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true - - name: "(Linux only) Check Stack version and fix working directory ownership" - if: "contains(matrix.os, 'ubuntu-latest')" + - name: "(Linux only) Fix working directory ownership" + if: startsWith(matrix.image, 'haskell') run: | - [ "$(stack --numeric-version)" = "$STACK_VERSION" ] chown root:root . - - uses: "actions/cache@v2" + - uses: "actions/cache@v4" with: path: | /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml') }}" + key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -122,16 +122,16 @@ jobs: run: "ci/fix-home ci/build.sh" - name: "(Linux only) Glob tests" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') working-directory: "sdist-test" # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual glob checks happen in a temporary directory. run: | - apt-get install tree + apt-get install -y tree ../ci/fix-home stack exec bash ../glob-test.sh - name: "(Linux only) Build the entire package set" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual package-set building happens in a # temporary directory. @@ -144,11 +144,11 @@ jobs: # Moreover, npm has a hook issue that will cause spago to fail to install # We upgrade npm to fix this run: | - npm i -g npm@8.8.0 + apt-get install -y jq ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary - if: "runner.os == 'Linux'" + if: runner.os == 'Linux' working-directory: "sdist-test" run: | if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then @@ -157,17 +157,6 @@ jobs: exit 1 fi - - name: "(Self-hosted Linux ARM64 only) Patch the binary to work on non-Nix systems" - if: "runner.os == 'Linux' && runner.arch == 'ARM64'" - working-directory: "sdist-test" - # The self-hosted build happens inside a nix-shell that provides a working stack binary - # on ARM systems, and while the macOS binary is fine - because macOS binaries are almost - # statically linked), the linux ones are all pointing at the nix store. - # So here we first point the binary to the right linker that should work on a generic linux, - # and then fix the RUNPATH with the right location to load the shared libraries from - run: | - patchelf --set-interpreter /usr/lib/ld-linux-aarch64.so.1 --set-rpath /usr/lib/aarch64-linux-gnu $(stack path --local-doc-root)/../bin/purs - - name: "(Release/prerelease only) Create bundle" if: "${{ env.CI_RELEASE == 'true' || env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" run: | @@ -199,7 +188,7 @@ jobs: - name: "(Prerelease only) Upload bundle" if: "${{ env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" - uses: "actions/upload-artifact@v3" + uses: "actions/upload-artifact@v4.6.0" with: name: "${{ runner.os }}-${{ runner.arch }}-bundle" path: | @@ -208,59 +197,39 @@ jobs: - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" - # This requires the gh command line tool to be installed on our - # self-hosted runners env: GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}" run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" lint: - runs-on: "ubuntu-latest" - # At the moment, this is a different image from the image used for - # compilation, though the GHC versions match. This is because the - # compilation image uses an old version of glibc, which we want because it - # means our published binaries will work on the widest number of platforms. - # But the HLint binary downloaded by this job requires a newer glibc - # version. - container: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb + container: haskell:9.6.6 + runs-on: ubuntu-latest # Exact version is not important, as it's only the container host steps: - - uses: "actions/checkout@v2" + - uses: "actions/checkout@v4" - name: "Fix working directory ownership" run: | chown root:root . - - uses: "actions/cache@v2" + - uses: "actions/cache@v4" with: path: | /root/.stack - key: "lint-${{ hashFiles('stack.yaml') }}" + key: "lint-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" - run: "ci/fix-home ci/run-hlint.sh --git" env: VERSION: "3.5" - # Note: the weeder version will need to be updated when we next update our version - # of GHC. - # - # weeder-2.2.0 has somewhat strange version deps. It doesn't appear to - # support the exact versions of dhall and generic-lens in LTS-18. - # However, forcing it to use the versions of dhall and generic-lens in - # LTS-18 doesn't cause any problems when building, so the following - # commands build weeder while ignoring version constraints. - name: Install weeder run: | - # The `stack.yaml` file is copied to a separate file so that - # adding `allow-newer: true` doesn't affect any subsequant - # calls to `stack`. - cp stack.yaml stack-weeder.yaml - # `allow-newer: true` is needed so that weeder-2.2.0 can be - # installed with the dependencies present in LTS-18. - echo 'allow-newer: true' >> stack-weeder.yaml - ci/fix-home stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.4.0 + ci/fix-home stack --no-terminal --jobs=2 \ + build --copy-compiler-tool weeder-2.8.0 - - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" + - run: | + ci/fix-home stack --no-terminal --jobs=2 \ + build --fast --ghc-options -fwrite-ide-info - run: "ci/fix-home stack exec weeder" @@ -268,26 +237,28 @@ jobs: # reference from our test suite to count in the above check; the fact # that a function is tested is not evidence that it's needed. But we also # don't want to leave weeds lying around in our test suite either. - - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" + - run: | + ci/fix-home stack --no-terminal --jobs=2 \ + build --fast --test --no-run-tests --ghc-options -fwrite-ide-info - run: "ci/fix-home stack exec weeder" make-prerelease: - runs-on: "ubuntu-latest" + runs-on: ubuntu-latest needs: - "build" - "lint" if: "${{ github.event_name == 'push' && needs.build.outputs.do-not-prerelease != 'true' }}" steps: - - uses: "actions/download-artifact@v3" + - uses: "actions/download-artifact@v4" - uses: "ncipollo/release-action@v1.10.0" with: tag: "v${{ needs.build.outputs.version }}" artifacts: "*-bundle/*" prerelease: true body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." - - uses: "actions/checkout@v3" - - uses: "actions/setup-node@v3" + - uses: "actions/checkout@v4" + - uses: "actions/setup-node@v4" with: node-version: "16.x" registry-url: "https://registry.npmjs.org" diff --git a/.gitignore b/.gitignore index 0454beffcb..73b2b4678f 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,6 @@ bin dist cabal-dev .cabal-sandbox -stack.yaml.lock cabal.sandbox.config dist-newstyle/ cabal.project.local* diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md new file mode 100644 index 0000000000..6622b6baed --- /dev/null +++ b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md @@ -0,0 +1,2 @@ +* 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/CONTRIBUTORS.md b/CONTRIBUTORS.md index aa5ddefd3f..cfbb98e362 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -16,6 +16,7 @@ If you would prefer to use different terms, please use the section below instead | :------- | :--- | :------ | | [@5outh](https://github.com/5outh) | Benjamin Kovach | [MIT license] | | [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license] | +| [@ad-si](https://github.com/ad-si) | Adrian Sieber | [MIT license] | | [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license] | | [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license] | | [@andreypopp](https://github.com/andreypopp) | Andrey Popp | [MIT license] | diff --git a/INSTALL.md b/INSTALL.md index 0bccc516c7..03f7748636 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,13 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.2.8, and should be able to run on any operating system supported by GHC 9.2.8. In particular: +The PureScript compiler is built using GHC 9.6.6, and should be able to run on any operating system supported by GHC 9.6.6. +In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.8 supports. +See also for more details about the operating systems which GHC 9.6.6 supports. ## Official prebuilt binaries diff --git a/LICENSE b/LICENSE index 490ff3651c..713d3371a3 100644 --- a/LICENSE +++ b/LICENSE @@ -107,7 +107,6 @@ PureScript uses the following Haskell library packages. Their license files foll optparse-applicative parallel parsec - pattern-arrows pretty primitive process @@ -3186,29 +3185,6 @@ parsec LICENSE file: negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. -pattern-arrows LICENSE file: - - The MIT License (MIT) - - Copyright (c) 2013 Phil Freeman - - Permission is hereby granted, free of charge, to any person obtaining a copy of - this software and associated documentation files (the "Software"), to deal in - the Software without restriction, including without limitation the rights to - use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of - the Software, and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS - FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR - COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - pretty LICENSE file: This library (libraries/pretty) is derived from code from diff --git a/Makefile b/Makefile index 53da1f3710..91235d9c8f 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,7 @@ package = purescript exe_target = purs stack_yaml = STACK_YAML="stack.yaml" stack = $(stack_yaml) stack +stack_dir = .stack-work .DEFAULT_GOAL := help @@ -14,6 +15,10 @@ $(bin_dir)/hlint: ci/install-hlint.sh clean: ## Remove build artifacts rm -fr $(bin_dir) rm -fr $(build_dir) + rm -fr $(stack_dir) + rm -fr dist-newstyle + rm -fr .psci_modules + rm -fr .test_modules help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 987023c98c..22bd6bdd3f 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -15,7 +15,8 @@ import Language.PureScript.Docs qualified as D import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import Language.PureScript.Glob (PSCGlobs(..), toInputGlobs, warnFileTypeNotFound) import Options.Applicative qualified as Opts -import Text.PrettyPrint.ANSI.Leijen qualified as PP +import Prettyprinter qualified as PP +import Prettyprinter.Render.Terminal (AnsiStyle) import SharedCLI qualified import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) import System.Exit (exitFailure) @@ -113,10 +114,10 @@ defaultOutputForFormat fmt = Ctags -> "tags" pscDocsOptions :: Opts.Parser PSCDocsOptions -pscDocsOptions = - PSCDocsOptions <$> format - <*> output - <*> compileOutputDir +pscDocsOptions = + PSCDocsOptions <$> format + <*> output + <*> compileOutputDir <*> many SharedCLI.inputFile <*> SharedCLI.globInputFile <*> many SharedCLI.excludeFiles @@ -150,9 +151,9 @@ infoModList :: Opts.InfoMod a infoModList = Opts.fullDesc <> footerInfo where footerInfo = Opts.footerDoc $ Just examples -examples :: PP.Doc +examples :: PP.Doc AnsiStyle examples = - PP.vcat $ map PP.text + PP.vcat [ "Examples:" , " write documentation for all modules to ./generated-docs:" , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" diff --git a/app/Main.hs b/app/Main.hs index c925a4a313..ff4e04ab6d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,9 +13,10 @@ import Command.REPL qualified as REPL import Control.Monad (join) import Data.Foldable (fold) import Options.Applicative qualified as Opts +import Prettyprinter qualified as Doc +import Prettyprinter.Render.Terminal (AnsiStyle) import System.Environment (getArgs) import System.IO qualified as IO -import Text.PrettyPrint.ANSI.Leijen qualified as Doc import Version (versionString) @@ -39,11 +40,11 @@ main = do "For example, `purs compile --help` displays options specific to the `compile` command." , Doc.hardline , Doc.hardline - , Doc.text $ "purs " ++ versionString + , Doc.pretty $ "purs " ++ versionString ] - para :: String -> Doc.Doc - para = foldr (Doc.) Doc.empty . map Doc.text . words + para :: String -> Doc.Doc AnsiStyle + para = foldr (\x y -> x <> Doc.softline <> y) mempty . map Doc.pretty . words -- | Displays full command help when invoked with no arguments. execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a diff --git a/cabal.project b/cabal.project index 51c7ecb87d..61c5c9bd35 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,7 @@ packages: purescript.cabal + +source-repository-package + type: git + location: https://github.com/purescript/cheapskate.git + tag: 8bfaf4beeb108e97a274ed51303f278905979e87 diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index 12a6fcb34c..f11b556871 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -5,7 +5,7 @@ shopt -s nullglob psroot=$(dirname "$(dirname "$(realpath "$0")")") -if [[ "${CI:-}" && "$(echo $psroot/CHANGELOG.d/breaking_*)" ]]; then +if [[ "${CI:-}" && "$(echo "$psroot"/CHANGELOG.d/breaking_*)" ]]; then echo "Skipping package-set build due to unreleased breaking changes" exit 0 fi @@ -16,23 +16,17 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago@0.20.8 +which spago || npm install spago@0.93.43 echo ::endgroup:: echo ::group::Create dummy project -echo 'let upstream = https://github.com/purescript/package-sets/releases/download/XXX/packages.dhall in upstream' > packages.dhall -echo '{ name = "my-project", dependencies = [] : List Text, packages = ./packages.dhall, sources = [] : List Text }' > spago.dhall -spago upgrade-set -# Override the `metadata` package's version to match `purs` version -# so that `spago build` actually works -sed -i'' "\$c in upstream with metadata.version = \"v$(purs --version | { read v z && echo $v; })\"" packages.dhall -spago install $(spago ls packages | while read name z; do if [[ $name != metadata ]]; then echo $name; fi; done) +spago init --name purescript-dummy echo ::endgroup:: echo ::group::Compile package set -spago build +spago ls packages --json | jq -r 'keys[]' | xargs spago install echo ::endgroup:: echo ::group::Document package set -spago docs --no-search +spago docs echo ::endgroup:: diff --git a/purescript.cabal b/purescript.cabal index 0d32ce4814..93b02ebbc9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -153,18 +153,17 @@ common defaults -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single -- specific version. - aeson >=2.0.3.0 && <2.1, - aeson-better-errors >=0.9.1.1 && <0.10, - ansi-terminal >=0.11.3 && <0.12, + aeson >=2.0.3.0 && <2.2, + aeson-better-errors >=0.9.1.3 && <0.10, + ansi-terminal >=0.11.3 && <1.1, array >=0.5.4.0 && <0.6, - base >=4.16.2.0 && <4.17, + base >=4.16.2.0 && <4.19, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, bytestring >=0.11.3.1 && <0.12, - Cabal >=3.6.3.0 && <3.7, + Cabal >=3.10.3.0 && <3.11, cborg >=0.2.7.0 && <0.3, - serialise >=0.2.5.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, @@ -177,38 +176,38 @@ common defaults file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, Glob >=0.10.2 && <0.11, - haskeline >=0.8.2 && <0.9, + haskeline ==0.8.2, language-javascript ==0.7.0.0, - lens >=5.1.1 && <5.2, + lens >=5.1.1 && <5.3, lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.17.0 && <0.18, + memory >=0.17.0 && <0.19, monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, monoidal-containers >=0.6.2.0 && <0.7, - mtl >=2.2.2 && <2.3, + mtl >=2.2.2 && <2.4, parallel >=3.2.2.0 && <3.3, parsec >=3.1.15.0 && <3.2, - pattern-arrows >=0.0.2 && <0.1, - process ==1.6.13.1, + process >=1.6.19.0 && <1.7, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, + semialign >=1.2.0.1 && <1.4, semigroups ==0.20.*, - semialign >=1.2.0.1 && <1.3, + serialise >=0.2.5.0 && <0.3, sourcemap >=0.1.7 && <0.2, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - template-haskell >=2.18.0.0 && <2.19, - text >=1.2.5.0 && <1.3, - these >=1.1.1.1 && <1.2, - time >=1.11.1.1 && <1.12, - transformers >=0.5.6.2 && <0.6, + template-haskell >=2.18.0.0 && <2.21, + text >=1.2.5.0 && <2.1, + these >=1.1.1.1 && <1.3, + time >=1.11.1.1 && <1.13, + transformers >=0.5.6.2 && <0.7, transformers-base >=0.4.6 && <0.5, utf8-string >=1.0.2 && <1.1, - vector >=0.12.3.1 && <0.13, - witherable >=0.4.2 && <0.5 + vector >=0.12.3.1 && <0.14, + witherable >=0.4.2 && <0.5, library import: defaults @@ -217,6 +216,7 @@ library Control.Monad.Logger Control.Monad.Supply Control.Monad.Supply.Class + Control.PatternArrows Language.PureScript Language.PureScript.AST Language.PureScript.AST.Binders @@ -403,10 +403,11 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: - ansi-wl-pprint >=0.6.9 && <0.7, + prettyprinter >=1.6 && <1.8, + prettyprinter-ansi-terminal >=1.1.1 && <1.2, exceptions >=0.10.4 && <0.11, network >=3.1.2.7 && <3.2, - optparse-applicative >=0.17.0.0 && <0.18, + optparse-applicative >=0.17.0.0 && <0.19, purescript if flag(release) cpp-options: -DRELEASE @@ -440,7 +441,7 @@ test-suite tests build-depends: purescript, generic-random >=1.5.0.1 && <1.6, - hspec >= 2.10.7 && < 3, + hspec >= 2.11.10 && < 3, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, QuickCheck >=2.14.2 && <2.15, diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index e8656f0c69..b10b42d549 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + -- | -- A class for monads supporting a supply of fresh names -- diff --git a/src/Control/PatternArrows.hs b/src/Control/PatternArrows.hs new file mode 100644 index 0000000000..b01d1cccdc --- /dev/null +++ b/src/Control/PatternArrows.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.PatternArrows +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- Arrows for Pretty Printing +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} + +module Control.PatternArrows where + +import Prelude + +import Control.Arrow ((***), (<+>)) +import Control.Arrow qualified as A +import Control.Category ((>>>)) +import Control.Category qualified as C +import Control.Monad.State +import Control.Monad.Fix (fix) + +-- | +-- A first-order pattern match +-- +-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state. +-- +newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (A.Arrow, A.ArrowZero, A.ArrowPlus) + +instance C.Category (Pattern u) where + id = Pattern C.id + Pattern p1 . Pattern p2 = Pattern (p1 C.. p2) + +instance Functor (Pattern u a) where + fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p + +-- | +-- Run a pattern with an input and initial user state +-- +-- Returns Nothing if the pattern fails to match +-- +pattern_ :: Pattern u a b -> u -> a -> Maybe b +pattern_ p u = flip evalStateT u . A.runKleisli (runPattern p) + +-- | +-- Construct a pattern from a function +-- +mkPattern :: (a -> Maybe b) -> Pattern u a b +mkPattern f = Pattern $ A.Kleisli (lift . f) + +-- | +-- Construct a pattern from a stateful function +-- +mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b +mkPattern' = Pattern . A.Kleisli + +-- | +-- Construct a pattern which recursively matches on the left-hand-side +-- +chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r +chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which recursively matches on the right-hand side +-- +chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r +chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which recursively matches on one-side of a tuple +-- +wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r +wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which matches a part of a tuple +-- +split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r +split s f = s >>> A.arr (uncurry f) + +-- | +-- A table of operators +-- +data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] } + +-- | +-- An operator: +-- +-- [@AssocL@] A left-associative operator +-- +-- [@AssocR@] A right-associative operator +-- +-- [@Wrap@] A prefix-like or postfix-like operator +-- +-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand +-- +data Operator u a r where + AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r + AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r + Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r + Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r + +-- | +-- Build a pretty printer from an operator table and an indecomposable pattern +-- +buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r +buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \case + AssocL pat g -> chainl pat g p' + AssocR pat g -> chainr pat g p' + Wrap pat g -> wrap pat g p' + Split pat g -> split pat g + ) <+> p') p $ runOperatorTable table diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 14d122a37d..3a4e371187 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,6 @@ module Language.PureScript.CodeGen.JS import Prelude import Protolude (ordNub) -import Control.Applicative (liftA2) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 34746ae3db..a1d4a47c2b 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -3,7 +3,7 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude -import Control.Applicative (empty, liftA2) +import Control.Applicative (empty) import Control.Monad (guard) import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index a082b4b833..c6a985b09b 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -233,7 +233,7 @@ renderTypeWithRole = \case renderType' :: PrettyPrintType -> RenderedCode renderType' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchType () + . PA.pattern_ matchType () renderTypeVars :: [(TypeVarVisibility, Text, Maybe PrettyPrintType)] -> RenderedCode renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars) @@ -252,4 +252,4 @@ renderTypeAtom = renderTypeAtom' . convertPrettyPrintType maxBound renderTypeAtom' :: PrettyPrintType -> RenderedCode renderTypeAtom' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchTypeAtom () + . PA.pattern_ matchTypeAtom () diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 697fefe8a0..eb03da41e0 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -11,7 +11,6 @@ module Language.PureScript.Linter.Exhaustive import Prelude import Protolude (ordNub) -import Control.Applicative (Applicative(..)) import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class (MonadWriter(..)) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20de0ed9e2..9b3be46937 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -238,7 +238,7 @@ forall_ = mkPattern match typeAtomAsBox' :: PrettyPrintType -> Box typeAtomAsBox' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchTypeAtom defaultOptions) () + . PA.pattern_ (matchTypeAtom defaultOptions) () typeAtomAsBox :: Int -> Type a -> Box typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth @@ -280,7 +280,7 @@ unicodeOptions = TypeRenderOptions False True False typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box typeAsBoxImpl tro = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchType tro) () + . PA.pattern_ (matchType tro) () -- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Int -> Type a -> String diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..835e775f81 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -114,8 +114,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueDeclarationInfo = M.fromList $ swap <$> valueDeclarationKeys findDeclarationInfo i = (M.findWithDefault False i valueDeclarationInfo, i) - computeValueDependencies = (`intersect` valueDeclarationKeys) . fmap findDeclarationInfo . usedIdents moduleName - + computeValueDependencies = (`intersect` valueDeclarationKeys) . fmap findDeclarationInfo . usedIdents moduleName + makeValueDeclarationVert = (,,) <$> id <*> makeValueDeclarationKey <*> computeValueDependencies valueDeclarationVerts = makeValueDeclarationVert <$> values @@ -267,7 +267,7 @@ toDataBindingGroup -> m Declaration toDataBindingGroup (AcyclicSCC (d, _, _)) = return d toDataBindingGroup (CyclicSCC ds') - | Just kds@((ss, _):|_) <- nonEmpty $ concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds + | Just kds@((ss, _) :| _) <- nonEmpty $ concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds | not (null typeSynonymCycles) = throwError . MultipleErrors diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..b33127200d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} -- | -- Monads for type checking and type inference and associated data types diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 567ae415ef..8d2cf7886c 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} -- | -- Functions for replacing fully applied type synonyms diff --git a/stack.yaml b/stack.yaml index 88b27b1a46..afbac89bca 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-20.26 +resolver: lts-22.43 pvp-bounds: both packages: - '.' @@ -13,20 +13,14 @@ extra-deps: # `async` to be used as an object key: # https://github.com/erikd/language-javascript/issues/131 - language-javascript-0.7.0.0 -# Fix issue with libtinfo. -# See https://github.com/purescript/purescript/issues/4253 -- process-1.6.13.1 -# The Cabal library is not in Stackage -- Cabal-3.6.3.0 -# hspec versions 2.9.3 to 2.10.6 depend on ghc -# ghc depends on terminfo by default, but that can be ignored -# if one uses the '-terminfo' flag. -# Unfortunately, hspec doesn't expose a similar flag. -# -# Using hspec >= 2.10.7 addresses this. -- hspec-2.10.9 -- hspec-core-2.10.9 -- hspec-discover-2.10.9 +- bower-json-1.1.0.0 +- haskeline-0.8.2 +- these-1.2.1 +- aeson-better-errors-0.9.1.3 + +- github: purescript/cheapskate + commit: 8bfaf4beeb108e97a274ed51303f278905979e87 + nix: packages: - zlib @@ -37,8 +31,10 @@ nix: flags: aeson-pretty: lib-only: true - these: - assoc: false haskeline: # Avoids a libtinfo dynamic library dependency terminfo: false + +allow-newer: true +allow-newer-deps: +- haskeline diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000000..0af2cebb41 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,58 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: +- completed: + hackage: language-javascript-0.7.0.0@sha256:3eab0262b8ac5621936a4beab6a0f97d0e00a63455a8b0e3ac1547b4088dae7d,3898 + pantry-tree: + sha256: b0f28d836cb3fbde203fd7318a896c3a20acd8653a905e1950ae2d9a64bccebf + size: 2244 + original: + hackage: language-javascript-0.7.0.0 +- completed: + hackage: bower-json-1.1.0.0@sha256:a136aaca67bf0d15c336f5864f7e9d40ebe046ca2cb4b25bc4895617ea35f9f6,1864 + pantry-tree: + sha256: 3acd48e7012f246ad44c7c17cd6340362b1dc448c1d93156280814e76d9e0589 + size: 419 + original: + hackage: bower-json-1.1.0.0 +- completed: + hackage: haskeline-0.8.2@sha256:3b4b594095d64f5fa199b07bdca7d6b790313ed7f380a1b061845507e6563880,6005 + pantry-tree: + sha256: 17ee6b093c5135399b8e6bc3a63d9c6a4b0bc2100b495d2d974bc1464769de39 + size: 2955 + original: + hackage: haskeline-0.8.2 +- completed: + hackage: these-1.2.1@sha256:35c57aede96c15ea1fed559ac287b1168eb2b2869d79e62ed8c845780b7ea136,2294 + pantry-tree: + sha256: dc6366ac715dfdf5338a615f71b9ed0542c403a6afcbedcddbc879e947aea6b3 + size: 351 + original: + hackage: these-1.2.1 +- completed: + hackage: aeson-better-errors-0.9.1.3@sha256:1bfdda3982368cafc7317b9f0c1f7267a6b0bbac9515ae1fad37f2b19178f567,2071 + pantry-tree: + sha256: 1c14247866dfb8052506c179e4725b8a7ce1472a4fb227d61576d862d9494551 + size: 492 + original: + hackage: aeson-better-errors-0.9.1.3 +- completed: + name: cheapskate + pantry-tree: + sha256: a2253619f50d26f0137a802e51e5e7103ee52b1f71bc060d93a0979dcbefa2c8 + size: 12069 + sha256: 959fc7a6ca7e0a743b06b0c287aa4a1c3ec7fc740e5830a4a841d43e925a6d73 + size: 62502 + url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + version: 0.1.1.2 + original: + url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz +snapshots: +- completed: + sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146 + size: 720271 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml + original: lts-22.43 diff --git a/update-changelog.hs b/update-changelog.hs index b9296440d4..291160ceca 100755 --- a/update-changelog.hs +++ b/update-changelog.hs @@ -25,7 +25,8 @@ , RecordWildCards , TupleSections , ViewPatterns -#-} + #-} -- Hlint requires this leading space + -- | -- This script updates CHANGELOG.md with the contents of CHANGELOG.d, and -- empties CHANGELOG.d. It takes care of: diff --git a/weeder.dhall b/weeder.dhall deleted file mode 100644 index 95686c45e8..0000000000 --- a/weeder.dhall +++ /dev/null @@ -1,41 +0,0 @@ -{ roots = - [ "^Main\\.main$" - , "^PscIdeSpec\\.main$" - - -- These declarations are used in Pursuit. (The Types declarations are - -- reexported in the L.P.Docs module, and referenced from there, but Weeder - -- isn't that smart.) - , "^Language\\.PureScript\\.Docs\\.AsHtml\\.packageAsHtml$" - , "^Language\\.PureScript\\.Docs\\.Types\\.asUploadedPackage$" - , "^Language\\.PureScript\\.Docs\\.Types\\.getLink$" - , "^Language\\.PureScript\\.Docs\\.Types\\.getLinksContext$" - , "^Language\\.PureScript\\.Docs\\.Types\\.packageName$" - , "^Language\\.PureScript\\.Docs\\.Types\\.verifyPackage$" - - -- These declarations are believed to be used in other projects that we want - -- to continue to support. - , "^Language\\.PureScript\\.CoreFn\\.FromJSON\\.moduleFromJSON$" - , "^Language\\.PureScript\\.CST\\.Print\\.printModule$" - - -- These declarations are there to be used during development or testing. - , "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$" - , "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug" - - -- These declarations are used by Template Haskell code. - , "^Language\\.PureScript\\.Constants\\.TH\\." - - -- These declarations are produced by Template Haskell when generating - -- pattern synonyms; this confuses Weeder. - , "^Language\\.PureScript\\.Constants\\..*\\.\\$[bm]" - - -- These declarations are unprincipled exceptions that we don't mind - -- supporting just in case they're used now or in the future. - , "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$" - - -- These declarations are generated by tools; it doesn't matter if they're - -- unused because we can't do anything about them. - , "^Language\\.PureScript\\.CST\\.Parser\\.happy" - , "^Paths_purescript?\\." - ] -, type-class-roots = True -} diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 0000000000..1a8249a2e2 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,40 @@ +roots = [ + "^Main\\.main$", + "^PscIdeSpec\\.main$", + + # These declarations are used in Pursuit. (The Types declarations are + # reexported in the L.P.Docs module, and referenced from there, but Weeder + # isn't that smart.) + "^Language\\.PureScript\\.Docs\\.AsHtml\\.packageAsHtml$", + "^Language\\.PureScript\\.Docs\\.Types\\.asUploadedPackage$", + "^Language\\.PureScript\\.Docs\\.Types\\.getLink$", + "^Language\\.PureScript\\.Docs\\.Types\\.getLinksContext$", + "^Language\\.PureScript\\.Docs\\.Types\\.packageName$", + "^Language\\.PureScript\\.Docs\\.Types\\.verifyPackage$", + + # These declarations are believed to be used in other projects that we want + # to continue to support. + "^Language\\.PureScript\\.CoreFn\\.FromJSON\\.moduleFromJSON$", + "^Language\\.PureScript\\.CST\\.Print\\.printModule$", + + # These declarations are there to be used during development or testing. + "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$", + "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug", + + # These declarations are used by Template Haskell code. + "^Language\\.PureScript\\.Constants\\.TH\\.", + + # These declarations are produced by Template Haskell when generating + # pattern synonyms; this confuses Weeder. + "^Language\\.PureScript\\.Constants\\..*\\.\\$[bm]", + + # These declarations are unprincipled exceptions that we don't mind + # supporting just in case they're used now or in the future. + "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$", + + # These declarations are generated by tools; it doesn't matter if they're + # unused because we can't do anything about them. + "^Language\\.PureScript\\.CST\\.Parser\\.happy", + "^Paths_purescript?\\.", +] +type-class-roots = true From ce98272aeb44fcfa4a2db0a57e3847e10f401bff Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 7 May 2025 19:55:28 +0000 Subject: [PATCH 086/105] Logger and Supply improvements --- src/Control/Monad/Logger.hs | 63 +++++++++++++++-------- src/Control/Monad/Supply.hs | 11 ++-- src/Control/Monad/Supply/Class.hs | 9 ++-- src/Language/PureScript/Names.hs | 3 +- src/Language/PureScript/Sugar/Accessor.hs | 2 + 5 files changed, 56 insertions(+), 32 deletions(-) diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index a3ed57b0da..183e9dc041 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -13,44 +13,63 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) --- | A replacement for WriterT IO which uses mutable references. -newtype Logger w a = Logger { runLogger :: IORef w -> IO a } +-- | Logger monad, using IORef for mutable log accumulation. +data Logger w a + = LoggerPure a + | LoggerIO (IORef w -> IO a) + +-- | Run a Logger computation given an existing IORef. +runLogger :: Logger w a -> IORef w -> IO a +runLogger (LoggerPure a) _ = return a +runLogger (LoggerIO f) r = f r -- | Run a Logger computation, starting with an empty log. -runLogger' :: (Monoid w) => Logger w a -> IO (a, w) +runLogger' :: Monoid w => Logger w a -> IO (a, w) runLogger' l = do - r <- newIORef mempty - a <- runLogger l r - w <- readIORef r + ref <- newIORef mempty + a <- runLogger l ref + w <- readIORef ref return (a, w) +-- Functor instance Functor (Logger w) where - fmap f (Logger l) = Logger $ \r -> fmap f (l r) + fmap f (LoggerPure a) = LoggerPure (f a) + fmap f (LoggerIO m) = LoggerIO $ \r -> fmap f (m r) -instance (Monoid w) => Applicative (Logger w) where - pure = Logger . const . pure +-- Applicative +instance Monoid w => Applicative (Logger w) where + pure = LoggerPure (<*>) = ap -instance (Monoid w) => Monad (Logger w) where +-- Monad +instance Monoid w => Monad (Logger w) where return = pure - Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r + LoggerPure a >>= f = f a + LoggerIO m >>= f = LoggerIO $ \r -> do + a <- m r + runLogger (f a) r -instance (Monoid w) => MonadIO (Logger w) where - liftIO = Logger . const +-- MonadIO +instance Monoid w => MonadIO (Logger w) where + liftIO = LoggerIO . const -instance (Monoid w) => MonadWriter w (Logger w) where - tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ()) - listen l = Logger $ \r -> do - (a, w) <- liftIO (runLogger' l) +-- MonadWriter +instance Monoid w => MonadWriter w (Logger w) where + tell w = LoggerIO $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ()) + listen m = LoggerIO $ \r -> do + (a, w) <- runLogger' m atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w)) - pass l = Logger $ \r -> do - ((a, f), w) <- liftIO (runLogger' l) + pass m = LoggerIO $ \r -> do + ((a, f), w) <- runLogger' m atomicModifyIORef' r $ \w' -> (mappend w' (f w), a) -instance (Monoid w) => MonadBase IO (Logger w) where +-- MonadBase +instance Monoid w => MonadBase IO (Logger w) where liftBase = liftIO -instance (Monoid w) => MonadBaseControl IO (Logger w) where +-- MonadBaseControl +instance Monoid w => MonadBaseControl IO (Logger w) where type StM (Logger w) a = a - liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r) + liftBaseWith f = LoggerIO $ \r -> liftBaseWith $ \runInBase -> + f (\m -> runInBase (runLogger m r)) restoreM = return diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index dd447a9c39..32f0eade9f 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -9,21 +9,22 @@ import Control.Applicative (Alternative) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, MonadTrans) import Control.Monad (MonadPlus) -import Control.Monad.State (StateT(..)) +import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Writer (MonadWriter) +import Data.Int (Int64) import Data.Functor.Identity (Identity(..)) -newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } +newtype SupplyT m a = SupplyT { unSupplyT :: StateT Int64 m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) -runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) +runSupplyT :: Int64 -> SupplyT m a -> m (a, Int64) runSupplyT n = flip runStateT n . unSupplyT -evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a +evalSupplyT :: (Functor m) => Int64 -> SupplyT m a -> m a evalSupplyT n = fmap fst . runSupplyT n type Supply = SupplyT Identity -runSupply :: Integer -> Supply a -> (a, Integer) +runSupply :: Int64 -> Supply a -> (a, Int64) runSupply n = runIdentity . runSupplyT n diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index e8656f0c69..c62fa827d3 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -11,13 +11,14 @@ import Control.Monad.State (StateT) import Control.Monad.Supply (SupplyT(..)) import Control.Monad.Writer (WriterT) import Data.Text (Text, pack) +import Data.Int (Int64) class Monad m => MonadSupply m where - fresh :: m Integer - peek :: m Integer - default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer + fresh :: m Int64 + peek :: m Int64 + default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Int64 fresh = lift fresh - default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer + default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Int64 peek = lift peek instance Monad m => MonadSupply (SupplyT m) where diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index e5df3610bf..094ae5773d 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -19,6 +19,7 @@ import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), import Data.Aeson.TH (deriveJSON) import Data.Text (Text) import Data.Text qualified as T +import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) @@ -86,7 +87,7 @@ data Ident -- | -- A generated name for an identifier -- - | GenIdent (Maybe Text) Integer + | GenIdent (Maybe Text) Int64 -- | -- A generated name used only for type-checking -- diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 02c3d6c991..5715cf120f 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -5,6 +5,8 @@ module Language.PureScript.Sugar.Accessor import Prelude +import Data.Monoid (Any(..)) + import Control.Monad.Writer import Language.PureScript.AST From 7b26d488e8683fcbcca1c56a9423253e0ee3804d Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 7 May 2025 20:59:14 +0000 Subject: [PATCH 087/105] Not needed in this compiler version --- src/Language/PureScript/Sugar/Accessor.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 5715cf120f..02c3d6c991 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -5,8 +5,6 @@ module Language.PureScript.Sugar.Accessor import Prelude -import Data.Monoid (Any(..)) - import Control.Monad.Writer import Language.PureScript.AST From 2f017add16b857b524e24b235db64833b9dbe60f Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Thu, 8 May 2025 21:10:45 +0000 Subject: [PATCH 088/105] Specialize logger to errors --- cabal.project | 1 + purescript.cabal | 2 ++ src/Control/Monad/Logger.hs | 34 +++++++++++++++++++--------------- 3 files changed, 22 insertions(+), 15 deletions(-) diff --git a/cabal.project b/cabal.project index 51c7ecb87d..cc11fc519b 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,3 @@ packages: purescript.cabal +with-compiler: ghc-9.2.8 diff --git a/purescript.cabal b/purescript.cabal index 7957251ac8..fa732780fc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -168,6 +168,8 @@ common defaults cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, + unordered-containers, + hashable, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 183e9dc041..4c0d96be2b 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -12,37 +12,38 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Language.PureScript.Errors (MultipleErrors (MultipleErrors)) -- | Logger monad, using IORef for mutable log accumulation. -data Logger w a +data Logger a = LoggerPure a - | LoggerIO (IORef w -> IO a) + | LoggerIO (IORef MultipleErrors -> IO a) -- | Run a Logger computation given an existing IORef. -runLogger :: Logger w a -> IORef w -> IO a +runLogger :: Logger a -> IORef MultipleErrors -> IO a runLogger (LoggerPure a) _ = return a runLogger (LoggerIO f) r = f r -- | Run a Logger computation, starting with an empty log. -runLogger' :: Monoid w => Logger w a -> IO (a, w) +runLogger' :: Logger a -> IO (a, MultipleErrors) runLogger' l = do ref <- newIORef mempty a <- runLogger l ref - w <- readIORef ref - return (a, w) + (MultipleErrors list) <- readIORef ref + return (a, MultipleErrors $ reverse list) -- Functor -instance Functor (Logger w) where +instance Functor Logger where fmap f (LoggerPure a) = LoggerPure (f a) fmap f (LoggerIO m) = LoggerIO $ \r -> fmap f (m r) -- Applicative -instance Monoid w => Applicative (Logger w) where +instance Applicative Logger where pure = LoggerPure (<*>) = ap -- Monad -instance Monoid w => Monad (Logger w) where +instance Monad Logger where return = pure LoggerPure a >>= f = f a LoggerIO m >>= f = LoggerIO $ \r -> do @@ -50,12 +51,15 @@ instance Monoid w => Monad (Logger w) where runLogger (f a) r -- MonadIO -instance Monoid w => MonadIO (Logger w) where +instance MonadIO Logger where liftIO = LoggerIO . const -- MonadWriter -instance Monoid w => MonadWriter w (Logger w) where - tell w = LoggerIO $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ()) +instance MonadWriter MultipleErrors Logger where + tell w = LoggerIO $ \r -> + atomicModifyIORef' r $ \(MultipleErrors acc) -> + let MultipleErrors new = w + in (MultipleErrors (new ++ acc), ()) listen m = LoggerIO $ \r -> do (a, w) <- runLogger' m atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w)) @@ -64,12 +68,12 @@ instance Monoid w => MonadWriter w (Logger w) where atomicModifyIORef' r $ \w' -> (mappend w' (f w), a) -- MonadBase -instance Monoid w => MonadBase IO (Logger w) where +instance MonadBase IO Logger where liftBase = liftIO -- MonadBaseControl -instance Monoid w => MonadBaseControl IO (Logger w) where - type StM (Logger w) a = a +instance MonadBaseControl IO Logger where + type StM Logger a = a liftBaseWith f = LoggerIO $ \r -> liftBaseWith $ \runInBase -> f (\m -> runInBase (runLogger m r)) restoreM = return From 79596a94e0d8e313e5d46f8f72f9d5b880604eae Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Thu, 8 May 2025 21:28:42 +0000 Subject: [PATCH 089/105] A working version --- purescript.cabal | 4 ++-- src/Language/PureScript/Make/Monad.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index fa732780fc..e5823202a6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -168,8 +168,8 @@ common defaults cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - unordered-containers, - hashable, + -- unordered-containers, + -- hashable, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index ed553cf28f..d1aff7630e 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -54,7 +54,7 @@ import System.IO.UTF8 (readUTF8FileT) -- | A monad for running make actions newtype Make a = Make - { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a + { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger )) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) instance MonadBase IO Make where From 59960541543bfc42df88a7f965d551e6b2be3f15 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Thu, 8 May 2025 21:33:40 +0000 Subject: [PATCH 090/105] IntMap Lazy --- src/Language/PureScript/Errors.hs | 6 +++--- src/Language/PureScript/Make/Monad.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 7 ++++--- src/Language/PureScript/TypeChecker/Kinds.hs | 9 +++++---- src/Language/PureScript/TypeChecker/Monad.hs | 21 ++++++++++---------- src/Language/PureScript/TypeChecker/Unify.hs | 14 ++++++------- 6 files changed, 31 insertions(+), 28 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..309a4e9ba9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -28,7 +28,7 @@ import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons) import Data.List.NonEmpty qualified as NEL import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe) -import Data.Map qualified as M +import Data.IntMap.Strict qualified as M import Data.Ord (Down(..)) import Data.Set qualified as S import Data.Text qualified as T @@ -418,9 +418,9 @@ addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hi -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap - { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + { umSkolemMap :: M.IntMap (String, Int, Maybe SourceSpan) -- ^ a map from skolems to their new names, including source and naming info - , umUnknownMap :: M.Map Int Int + , umUnknownMap :: M.IntMap Int -- ^ a map from unification variables to their new names , umNextIndex :: Int -- ^ unknowns and skolems share a source of names during renaming, to diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index d1aff7630e..58a03d8973 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -54,7 +54,7 @@ import System.IO.UTF8 (readUTF8FileT) -- | A monad for running make actions newtype Make a = Make - { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger )) a + { unMake :: ReaderT Options (ExceptT MultipleErrors Logger) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) instance MonadBase IO Make where diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..7f37c00dd8 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -24,6 +24,7 @@ import Data.Either (partitionEithers) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Set qualified as S import Data.Text qualified as T @@ -458,11 +459,11 @@ typeCheckAll moduleName = traverse go typeModule (KindedType _ t1 _) = typeModule t1 typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" - modulesByTypeIndex :: M.Map Int (Maybe ModuleName) - modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) + modulesByTypeIndex :: IM.IntMap (Maybe ModuleName) + modulesByTypeIndex = IM.fromList (zip [0 ..] (typeModule <$> tys')) lookupModule :: Int -> S.Set ModuleName - lookupModule idx = case M.lookup idx modulesByTypeIndex of + lookupModule idx = case IM.lookup idx modulesByTypeIndex of Just ms -> S.fromList (toList ms) Nothing -> internalError "Unknown type index in findNonOrphanModules" diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5be87c0057..5ef0621472 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -42,6 +42,7 @@ import Data.Functor (($>)) import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -93,7 +94,7 @@ apply ty = flip substituteType ty <$> gets checkSubstitution substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes $ \case TUnknown ann u -> - case M.lookup u (substType sub) of + case IM.lookup u (substType sub) of Nothing -> TUnknown ann u Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 Just t -> substituteType sub t @@ -122,14 +123,14 @@ addUnsolved lvl unk kind = modify $ \st -> do Nothing -> pure unk Just (UnkLevel lvl') -> lvl' <> pure unk subs = checkSubstitution st - uns = M.insert unk (newLvl, kind) $ substUnsolved subs + uns = IM.insert unk (newLvl, kind) $ substUnsolved subs st { checkSubstitution = subs { substUnsolved = uns } } solve :: (MonadState CheckState m) => Unknown -> SourceType -> m () solve unk solution = modify $ \st -> do let subs = checkSubstitution st - tys = M.insert unk solution $ substType subs + tys = IM.insert unk solution $ substType subs st { checkSubstitution = subs { substType = tys } } lookupUnsolved @@ -138,7 +139,7 @@ lookupUnsolved -> m (UnkLevel, SourceType) lookupUnsolved u = do uns <- gets (substUnsolved . checkSubstitution) - case M.lookup u uns of + case IM.lookup u uns of Nothing -> internalCompilerError $ "Unsolved unification variable ?" <> T.pack (show u) <> " is not bound" Just res -> return res diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..2b0df8b294 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -14,6 +14,7 @@ import Control.Monad (forM_, guard, join, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe (fromMaybe) +import Data.IntMap.Lazy qualified as IM import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text, isPrefixOf, unpack) @@ -46,11 +47,11 @@ instance Ord UnkLevel where -- | A substitution of unification variables for types. data Substitution = Substitution - { substType :: M.Map Int SourceType + { substType :: IM.IntMap SourceType -- ^ Type substitution - , substUnsolved :: M.Map Int (UnkLevel, SourceType) + , substUnsolved :: IM.IntMap (UnkLevel, SourceType) -- ^ Unsolved unification variables with their level (scope ordering) and kind - , substNames :: M.Map Int Text + , substNames :: IM.IntMap Text -- ^ The original names of unknowns } @@ -59,17 +60,17 @@ insertUnkName u t = do modify (\s -> s { checkSubstitution = (checkSubstitution s) { substNames = - M.insert u t $ substNames $ checkSubstitution s + IM.insert u t $ substNames $ checkSubstitution s } } ) lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text) -lookupUnkName u = gets $ M.lookup u . substNames . checkSubstitution +lookupUnkName u = gets $ IM.lookup u . substNames . checkSubstitution -- | An empty substitution emptySubstitution :: Substitution -emptySubstitution = Substitution M.empty M.empty M.empty +emptySubstitution = Substitution IM.empty IM.empty IM.empty -- | State required for type checking data CheckState = CheckState @@ -467,13 +468,13 @@ debugValue = init . render . prettyPrintValue 100 debugSubstitution :: Substitution -> [String] debugSubstitution (Substitution solved unsolved names) = concat - [ fmap go1 (M.toList solved) - , fmap go2 (M.toList unsolved') - , fmap go3 (M.toList names) + [ fmap go1 (IM.toList solved) + , fmap go2 (IM.toList unsolved') + , fmap go3 (IM.toList names) ] where unsolved' = - M.filterWithKey (\k _ -> M.notMember k solved) unsolved + IM.filterWithKey (\k _ -> IM.notMember k solved) unsolved go1 (u, ty) = "?" <> show u <> " = " <> debugType ty diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e4f1040ebf..a87a656871 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -23,7 +23,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) -import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Text qualified as T import Language.PureScript.Crash (internalError) @@ -41,8 +41,8 @@ freshType = state $ \st -> do t = checkNextType st st' = st { checkNextType = t + 2 , checkSubstitution = - (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), E.kindType) - . M.insert (t + 1) (UnkLevel (pure (t + 1)), srcTUnknown t) + (checkSubstitution st) { substUnsolved = IM.insert t (UnkLevel (pure t), E.kindType) + . IM.insert (t + 1) (UnkLevel (pure (t + 1)), srcTUnknown t) . substUnsolved $ checkSubstitution st } @@ -56,7 +56,7 @@ freshTypeWithKind kind = state $ \st -> do t = checkNextType st st' = st { checkNextType = t + 1 , checkSubstitution = - (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), kind) (substUnsolved (checkSubstitution st)) } + (checkSubstitution st) { substUnsolved = IM.insert t (UnkLevel (pure t), kind) (substUnsolved (checkSubstitution st)) } } (srcTUnknown t, st') @@ -70,11 +70,11 @@ solveType u t = rethrow (onErrorMessages withoutPosition) $ do occursCheck u t k1 <- elaborateKind t subst <- gets checkSubstitution - k2 <- maybe (internalCompilerError ("No kind for unification variable ?" <> T.pack (show u))) (pure . substituteType subst . snd) . M.lookup u . substUnsolved $ subst + k2 <- maybe (internalCompilerError ("No kind for unification variable ?" <> T.pack (show u))) (pure . substituteType subst . snd) . IM.lookup u . substUnsolved $ subst t' <- instantiateKind (t, k1) k2 modify $ \cs -> cs { checkSubstitution = (checkSubstitution cs) { substType = - M.insert u t' $ substType $ checkSubstitution cs + IM.insert u t' $ substType $ checkSubstitution cs } } @@ -83,7 +83,7 @@ substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes go where go (TUnknown ann u) = - case M.lookup u (substType sub) of + case IM.lookup u (substType sub) of Nothing -> TUnknown ann u Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 Just t -> substituteType sub t From 2bd2e98222bd6c5541d4a6963f8ebbab411bddac Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Fri, 9 May 2025 05:51:36 +0000 Subject: [PATCH 091/105] Hacky specialization of TypeCheckM --- hie.yaml | 2 + src/Control/Monad/Supply.hs | 11 +- src/Control/Monad/Supply/Class.hs | 7 + src/Language/PureScript/Interactive.hs | 4 +- src/Language/PureScript/Make.hs | 15 +- src/Language/PureScript/TypeChecker.hs | 106 ++++----- .../PureScript/TypeChecker/Deriving.hs | 132 ++++------- .../PureScript/TypeChecker/Entailment.hs | 45 ++-- .../TypeChecker/Entailment/Coercible.hs | 137 +++++------ src/Language/PureScript/TypeChecker/Kinds.hs | 217 +++++++++--------- src/Language/PureScript/TypeChecker/Monad.hs | 153 ++++++------ .../PureScript/TypeChecker/Subsumption.hs | 13 +- .../PureScript/TypeChecker/Synonyms.hs | 5 +- .../PureScript/TypeChecker/TypeSearch.hs | 25 +- src/Language/PureScript/TypeChecker/Types.hs | 117 +++++----- src/Language/PureScript/TypeChecker/Unify.hs | 28 +-- 16 files changed, 475 insertions(+), 542 deletions(-) create mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000000..86de29471c --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + stack: {} diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index dd447a9c39..98ff166a4d 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} -- | -- Fresh variable supply -- @@ -9,13 +10,15 @@ import Control.Applicative (Alternative) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, MonadTrans) import Control.Monad (MonadPlus) -import Control.Monad.State (StateT(..)) +import Control.Monad.State (StateT(..), MonadState(..)) import Control.Monad.Writer (MonadWriter) import Data.Functor.Identity (Identity(..)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans (lift) newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } - deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) + deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus, MonadIO) runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) runSupplyT n = flip runStateT n . unSupplyT @@ -27,3 +30,7 @@ type Supply = SupplyT Identity runSupply :: Integer -> Supply a -> (a, Integer) runSupply n = runIdentity . runSupplyT n + +instance MonadState s m => MonadState s (SupplyT m) where + get = lift get + put = lift . put diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index e8656f0c69..92054a77e2 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -15,10 +15,13 @@ import Data.Text (Text, pack) class Monad m => MonadSupply m where fresh :: m Integer peek :: m Integer + consumeUpTo :: Integer -> m () default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer fresh = lift fresh default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer peek = lift peek + default consumeUpTo :: (MonadTrans t, MonadSupply n, m ~ t n) => Integer -> m () + consumeUpTo n = lift (consumeUpTo n) instance Monad m => MonadSupply (SupplyT m) where fresh = SupplyT $ do @@ -26,6 +29,9 @@ instance Monad m => MonadSupply (SupplyT m) where put (n + 1) return n peek = SupplyT get + consumeUpTo n = SupplyT $ do + m <- get + put $ max n m instance MonadSupply m => MonadSupply (StateT s m) instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) @@ -33,3 +39,4 @@ instance (Monoid w, MonadSupply m) => MonadSupply (RWST r w s m) freshName :: MonadSupply m => m Text freshName = fmap (("$" <> ) . pack . show) fresh + diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 5f88b079c3..3c0ae0ed21 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DoAndIfThenElse #-} +{-# OPTIONS_GHC -Wwarn #-} + module Language.PureScript.Interactive ( handleCommand , module Interactive @@ -294,7 +296,7 @@ handleKindOf print' typ = do case M.lookup (P.Qualified (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } - k = check (snd <$> P.kindOf typ') chk + k = undefined -- TODO: check (snd <$> P.kindOf typ') chk check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) check sew = fst . runWriter . runExceptT . runStateT sew diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 55a17d3468..a8f22ee0f4 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -72,12 +72,13 @@ import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +import Language.PureScript.TypeChecker.Monad (liftTypeCheckM) -- | Rebuild a single module. -- rebuildModule :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) => MakeActions m -> [ExternsFile] -> Module @@ -88,7 +89,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) => MakeActions m -> Env -> [ExternsFile] @@ -98,7 +99,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) => MakeActions m -> Env -> [ExternsFile] @@ -114,7 +115,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ ((Module ss coms _ elaborated exps, env'), nextVar) <- 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 + (checked, CheckState{..}) <- runStateT (liftTypeCheckM $ 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 @@ -165,7 +166,7 @@ data MakeOptions = MakeOptions -- again. -- -- It collects and returns externs for all modules passed. -make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] @@ -175,13 +176,13 @@ make = make' (MakeOptions {moCollectAllExterns = True}) -- and an @externs.cbor@ file. -- -- This version of make returns nothing. -make_ :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make_ :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m () make_ ma ms = void $ make' (MakeOptions {moCollectAllExterns = False}) ma ms -make' :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make' :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeOptions -> MakeActions m -> [CST.PartialResult Module] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..7277f7b156 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -13,9 +13,8 @@ import Protolude (headMay, maybeToLeft, ordNub) import Control.Lens ((^..), _2) import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..), modify, gets) -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Writer.Class (MonadWriter, tell) +import Control.Monad.State.Class (modify, gets) +import Control.Monad.Writer.Class (tell) import Data.Foldable (for_, traverse_, toList) import Data.List (nubBy, (\\), sort, group) @@ -32,7 +31,7 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), isDictTypeName, kindArity, makeTypeClassData, nominalRolesForKind, tyFunction) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow) +import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow, MultipleErrors) import Language.PureScript.Linter (checkExhaustiveExpr) import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures) import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified) @@ -48,14 +47,13 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes) addDataType - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> DataDeclType -> ProperName 'TypeName -> [(Text, Maybe SourceType, Role)] -> [(DataConstructorDeclaration, SourceType)] -> SourceType - -> m () + -> TypeCheckM () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) @@ -69,14 +67,13 @@ addDataType moduleName dtype name args dctors ctorKind = do addDataConstructor moduleName dtype name dctor fields polyType addDataConstructor - :: (MonadState CheckState m, MonadError MultipleErrors m) - => ModuleName + :: ModuleName -> DataDeclType -> ProperName 'TypeName -> ProperName 'ConstructorName -> [(Ident, SourceType)] -> SourceType - -> m () + -> TypeCheckM () addDataConstructor moduleName dtype name dctor dctorArgs polyType = do let fields = fst <$> dctorArgs env <- getEnv @@ -84,10 +81,9 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do putEnv $ env { dataConstructors = M.insert (Qualified (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } checkRoleDeclaration - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> RoleDeclarationData - -> m () + -> TypeCheckM () checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) = do warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do env <- getEnv @@ -104,13 +100,12 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) _ -> internalError "Unsupported role declaration" addTypeSynonym - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> ProperName 'TypeName -> [(Text, Maybe SourceType)] -> SourceType -> SourceType - -> m () + -> TypeCheckM () addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty @@ -122,10 +117,9 @@ addTypeSynonym moduleName name args ty kind = do , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) } valueIsNotDefined - :: (MonadState CheckState m, MonadError MultipleErrors m) - => ModuleName + :: ModuleName -> Ident - -> m () + -> TypeCheckM () valueIsNotDefined moduleName name = do env <- getEnv case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of @@ -133,27 +127,24 @@ valueIsNotDefined moduleName name = do Nothing -> return () addValue - :: (MonadState CheckState m) - => ModuleName + :: ModuleName -> Ident -> SourceType -> NameKind - -> m () + -> TypeCheckM () addValue moduleName name ty nameKind = do env <- getEnv putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass - :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> Qualified (ProperName 'ClassName) -> [(Text, Maybe SourceType)] -> [SourceConstraint] -> [FunctionalDependency] -> [Declaration] -> SourceType - -> m () + -> TypeCheckM () addTypeClass _ qualifiedClassName args implies dependencies ds kind = do env <- getEnv newClass <- mkNewClass @@ -167,7 +158,7 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do classMembers :: [(Ident, SourceType)] classMembers = map toPair ds - mkNewClass :: m TypeClassData + mkNewClass :: TypeCheckM TypeClassData mkNewClass = do env <- getEnv implies' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms implies @@ -182,18 +173,16 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do toPair _ = internalError "Invalid declaration in TypeClassDeclaration" addTypeClassDictionaries - :: (MonadState CheckState m) - => QualifiedBy + :: QualifiedBy -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) - -> m () + -> TypeCheckM () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith (M.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st) checkDuplicateTypeArguments - :: (MonadState CheckState m, MonadError MultipleErrors m) - => [Text] - -> m () + :: [Text] + -> TypeCheckM () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where @@ -201,11 +190,10 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup -> firstDup = listToMaybe $ args \\ ordNub args checkTypeClassInstance - :: (MonadState CheckState m, MonadError MultipleErrors m) - => TypeClassData + :: TypeClassData -> Int -- ^ index of type class argument -> SourceType - -> m () + -> TypeCheckM () checkTypeClassInstance cls i = check where -- If the argument is determined via fundeps then we are less restrictive in -- what type is allowed. This is because the type cannot be used to influence @@ -228,9 +216,8 @@ checkTypeClassInstance cls i = check where -- Check that type synonyms are fully-applied in a type -- checkTypeSynonyms - :: (MonadState CheckState m, MonadError MultipleErrors m) - => SourceType - -> m () + :: SourceType + -> TypeCheckM () checkTypeSynonyms = void . replaceAllTypeSynonyms -- | @@ -249,14 +236,12 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- * Process module imports -- typeCheckAll - :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> [Declaration] - -> m [Declaration] + -> TypeCheckM [Declaration] typeCheckAll moduleName = traverse go where - go :: Declaration -> m Declaration + go :: Declaration -> TypeCheckM Declaration go (DataDeclaration sa@(ss, _) dtype name args dctors) = do warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ void $ checkNewtype name dctors @@ -413,14 +398,14 @@ typeCheckAll moduleName = traverse go addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d - checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m () + checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> TypeCheckM () checkInstanceArity dictName className typeClass tys = do let typeClassArity = length (typeClassArguments typeClass) instanceArity = length tys when (typeClassArity /= instanceArity) $ throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity - checkInstanceMembers :: [Declaration] -> m [Declaration] + checkInstanceMembers :: [Declaration] -> TypeCheckM [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls for_ (firstDuplicate idents) $ \ident -> @@ -489,7 +474,7 @@ typeCheckAll moduleName = traverse go -> TypeClassData -> [SourceType] -> S.Set ModuleName - -> m () + -> TypeCheckM () checkOverlappingInstance ss ch dictName vars className typeClass tys' nonOrphanModules = do for_ nonOrphanModules $ \m -> do dicts <- M.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className @@ -534,7 +519,7 @@ typeCheckAll moduleName = traverse go -> Qualified (ProperName 'ClassName) -> [SourceType] -> S.Set ModuleName - -> m () + -> TypeCheckM () checkOrphanInstance dictName className tys' nonOrphanModules | moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' @@ -552,7 +537,7 @@ typeCheckAll moduleName = traverse go withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)] withRoles = zipWith $ \(v, k) r -> (v, k, r) - replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration + replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> TypeCheckM DataConstructorDeclaration replaceTypeSynonymsInDataConstructor DataConstructorDeclaration{..} = do dataCtorFields' <- traverse (traverse replaceAllTypeSynonyms) dataCtorFields return DataConstructorDeclaration @@ -565,8 +550,7 @@ typeCheckAll moduleName = traverse go -- data constructor declaration and the single field, as a 'proof' that the -- newtype was indeed a valid newtype. checkNewtype - :: forall m - . MonadError MultipleErrors m + :: MonadError MultipleErrors m => ProperName 'TypeName -> [DataConstructorDeclaration] -> m (DataConstructorDeclaration, (Ident, SourceType)) @@ -578,11 +562,9 @@ checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- required by exported members are also exported. -- typeCheckModule - :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => M.Map ModuleName Exports + :: M.Map ModuleName Exports -> Module - -> m Module + -> TypeCheckM Module typeCheckModule _ (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated before typeCheckModule" typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = @@ -662,7 +644,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = untilSame :: Eq a => (a -> a) -> a -> a untilSame f a = let a' = f a in if a == a' then a else untilSame f a' - checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m () + checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> TypeCheckM () checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do @@ -686,7 +668,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = :: (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName))) -> (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName))) -> DeclarationRef - -> m () + -> TypeCheckM () checkSuperClassExport superClassesFor transitiveSuperClassesFor dr@(TypeClassRef drss className) = do let superClasses = superClassesFor (qualify' className) -- thanks to laziness, the computation of the transitive @@ -703,7 +685,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = checkSuperClassExport _ _ _ = return () - checkExport :: DeclarationRef -> [DeclarationRef] -> m () + checkExport :: DeclarationRef -> [DeclarationRef] -> TypeCheckM () checkExport dr drs = case filter (not . exported) drs of [] -> return () hidden -> throwError . errorMessage' (declRefSourceSpan dr) $ TransitiveExportError dr (nubBy nubEq hidden) @@ -721,7 +703,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = -- Check that all the type constructors defined in the current module that appear in member types -- have also been exported from the module - checkTypesAreExported :: DeclarationRef -> m () + checkTypesAreExported :: DeclarationRef -> TypeCheckM () checkTypesAreExported ref = checkMemberExport findTcons ref where findTcons :: SourceType -> [DeclarationRef] @@ -733,7 +715,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module - checkClassesAreExported :: DeclarationRef -> m () + checkClassesAreExported :: DeclarationRef -> TypeCheckM () checkClassesAreExported ref = checkMemberExport findClasses ref where findClasses :: SourceType -> [DeclarationRef] @@ -745,7 +727,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = extractCurrentModuleClass (Qualified (ByModuleName mn') name) | mn == mn' = [name] extractCurrentModuleClass _ = [] - checkClassMembersAreExported :: DeclarationRef -> m () + checkClassMembersAreExported :: DeclarationRef -> TypeCheckM () checkClassMembersAreExported dr@(TypeClassRef ss' name) = do let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps @@ -762,7 +744,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = -- If a type is exported without data constructors, we warn on `Generic` or `Newtype` instances. -- On the other hand if any data constructors are exported, we require all of them to be exported. - checkDataConstructorsAreExported :: DeclarationRef -> m () + checkDataConstructorsAreExported :: DeclarationRef -> TypeCheckM () checkDataConstructorsAreExported dr@(TypeRef ss' name (fromMaybe [] -> exportedDataConstructorsNames)) | null exportedDataConstructorsNames = for_ [ Libs.Generic diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 8d5dcde9b6..502a3dc05d 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -15,20 +15,19 @@ import Data.List (init, last, zipWith3, (!!)) import Data.Map qualified as M import Data.These (These(..), mergeTheseWith, these) -import Control.Monad.Supply.Class (MonadSupply) import Language.PureScript.AST (Binder(..), CaseAlternative(..), ErrorMessageHint(..), Expr(..), InstanceDerivationStrategy(..), Literal(..), SourceSpan, nullSourceSpan) import Language.PureScript.AST.Utils (UnwrappedTypeConstructor(..), lam, lamCase, lamCase2, mkBinder, mkCtor, mkCtorBinder, mkLit, mkRef, mkVar, unguarded, unwrapTypeConstructor, utcQTyCon) import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) +import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) -import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule) +import Language.PureScript.TypeChecker.Monad (getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule, TypeCheckM) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables) @@ -46,15 +45,10 @@ extractNewtypeName mn . (unwrapTypeConstructor <=< lastMay) deriveInstance - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => MonadWriter MultipleErrors m - => SourceType + :: SourceType -> Qualified (ProperName 'ClassName) -> InstanceDerivationStrategy - -> m Expr + -> TypeCheckM Expr deriveInstance instType className strategy = do mn <- unsafeCheckCurrentModule env <- getEnv @@ -67,7 +61,7 @@ deriveInstance instType className strategy = do case strategy of KnownClassStrategy -> let - unaryClass :: (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr + unaryClass :: (UnwrappedTypeConstructor -> TypeCheckM [(PSString, Expr)]) -> TypeCheckM Expr unaryClass f = case tys of [ty] -> case unwrapTypeConstructor ty of Just utc | mn == utcModuleName utc -> do @@ -107,14 +101,10 @@ deriveInstance instType className strategy = do _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys deriveNewtypeInstance - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadWriter MultipleErrors m - => Qualified (ProperName 'ClassName) + :: Qualified (ProperName 'ClassName) -> [SourceType] -> UnwrappedTypeConstructor - -> m Expr + -> TypeCheckM Expr deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs dargs) = do verifySuperclasses (dtype, tyKindNames, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm @@ -149,7 +139,7 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs | arg == arg' = stripRight args t stripRight _ _ = Nothing - verifySuperclasses :: m () + verifySuperclasses :: TypeCheckM () verifySuperclasses = do env <- getEnv for_ (M.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> @@ -195,29 +185,22 @@ data TypeInfo = TypeInfo } lookupTypeInfo - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => UnwrappedTypeConstructor - -> m TypeInfo + :: UnwrappedTypeConstructor + -> TypeCheckM TypeInfo lookupTypeInfo UnwrappedTypeConstructor{..} = do (_, kindParams, map fst -> tiTypeParams, tiCtors) <- lookupTypeDecl utcModuleName utcTyCon let tiArgSubst = zip tiTypeParams utcArgs <> zip kindParams utcKindArgs pure TypeInfo{..} deriveEq - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => UnwrappedTypeConstructor - -> m [(PSString, Expr)] + :: UnwrappedTypeConstructor + -> TypeCheckM [(PSString, Expr)] deriveEq utc = do TypeInfo{..} <- lookupTypeInfo utc eqFun <- mkEqFunction tiCtors pure [(Libs.S_eq, eqFun)] where - mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr + mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> TypeCheckM Expr mkEqFunction ctors = do x <- freshIdent "x" y <- freshIdent "y" @@ -239,7 +222,7 @@ deriveEq utc = do where catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (mkLit (BooleanLiteral False))) - mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative + mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> TypeCheckM CaseAlternative mkCtorClause (ctorName, tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") @@ -267,18 +250,14 @@ deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)] deriveEq1 = pure [(Libs.S_eq1, mkRef Libs.I_eq)] deriveOrd - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => UnwrappedTypeConstructor - -> m [(PSString, Expr)] + :: UnwrappedTypeConstructor + -> TypeCheckM [(PSString, Expr)] deriveOrd utc = do TypeInfo{..} <- lookupTypeInfo utc compareFun <- mkCompareFunction tiCtors pure [(Libs.S_compare, compareFun)] where - mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr + mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> TypeCheckM Expr mkCompareFunction ctors = do x <- freshIdent "x" y <- freshIdent "y" @@ -311,7 +290,7 @@ deriveOrd utc = do ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (mkRef Libs.I_compare1) - mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] + mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> TypeCheckM [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") @@ -354,12 +333,9 @@ deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)] deriveOrd1 = pure [(Libs.S_compare1, mkRef Libs.I_compare)] lookupTypeDecl - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => ModuleName + :: ModuleName -> ProperName 'TypeName - -> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)], [(ProperName 'ConstructorName, [SourceType])]) + -> TypeCheckM (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)], [(ProperName 'ConstructorName, [SourceType])]) lookupTypeDecl mn typeName = do env <- getEnv note (errorMessage $ CannotFindDerivingType typeName) $ do @@ -436,15 +412,13 @@ filterThese :: forall a. (a -> Bool) -> These a a -> Maybe (These a a) filterThese p = uncurry align . over both (mfilter p) . unalign . Just validateParamsInTypeConstructors - :: forall c m - . MonadError MultipleErrors m - => MonadState CheckState m - => Qualified (ProperName 'ClassName) + :: forall c + . Qualified (ProperName 'ClassName) -> UnwrappedTypeConstructor -> Bool -> CovariantClasses -> Maybe (ContravarianceSupport c) - -> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] + -> TypeCheckM [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} contravarianceSupport = do TypeInfo{..} <- lookupTypeInfo utc (mbLParam, param) <- liftEither . first (errorMessage . flip KindsDoNotUnify kindType . (kindType -:>)) $ @@ -548,7 +522,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) ty -> internalError $ "headOfType missing a case: " <> show (void ty) -usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr +usingLamIdent :: (Expr -> TypeCheckM Expr) -> TypeCheckM Expr usingLamIdent cb = do ident <- freshIdent "v" lam ident <$> cb (mkVar ident) @@ -562,14 +536,12 @@ unnestRecords f = fix $ \go -> \case usage -> f usage mkCasesForTraversal - :: forall c f m - . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals - => MonadSupply m + :: Applicative f => ModuleName -> (ParamUsage c -> Expr -> f Expr) -- how to handle constructor arguments - -> (f Expr -> m Expr) -- resolve the applicative effect into an expression + -> (f Expr -> TypeCheckM Expr) -- resolve the applicative effect into an expression -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] - -> m Expr + -> TypeCheckM Expr mkCasesForTraversal mn handleArg extractExpr ctors = do m <- freshIdent "m" fmap (lamCase m) . for ctors $ \(ctorName, ctorUsages) -> do @@ -605,15 +577,13 @@ data TraversalOps m = forall f. Applicative f => TraversalOps } mkTraversal - :: forall c m - . MonadSupply m - => ModuleName + :: forall c. ModuleName -> Bool -> TraversalExprs -> (c -> ContraversalExprs) - -> TraversalOps m + -> TraversalOps TypeCheckM -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] - -> m Expr + -> TypeCheckM Expr mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ @f visitExpr extractExpr) ctors = do f <- freshIdent "f" g <- if isBi then freshIdent "g" else pure f @@ -621,7 +591,7 @@ mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ handleValue :: ParamUsage c -> Expr -> f Expr handleValue = unnestRecords $ \usage inputExpr -> visitExpr $ flip App inputExpr <$> mkFnExprForValue usage - mkFnExprForValue :: ParamUsage c -> m Expr + mkFnExprForValue :: ParamUsage c -> TypeCheckM Expr mkFnExprForValue = \case IsParam -> pure $ mkVar g @@ -644,16 +614,12 @@ mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ lam f . applyWhen isBi (lam g) <$> mkCasesForTraversal mn handleValue extractExpr ctors deriveFunctor - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => Maybe Bool -- does left parameter exist, and is it contravariant? + :: Maybe Bool -- does left parameter exist, and is it contravariant? -> Bool -- is the (right) parameter contravariant? -> PSString -- name of the map function for this functor type -> Qualified (ProperName 'ClassName) -> UnwrappedTypeConstructor - -> m [(PSString, Expr)] + -> TypeCheckM [(PSString, Expr)] deriveFunctor mbLParamIsContravariant paramIsContravariant mapName nm utc = do ctors <- validateParamsInTypeConstructors nm utc isBi functorClasses $ Just $ ContravarianceSupport { contravarianceWitness = () @@ -690,14 +656,10 @@ applyWhen :: forall a. Bool -> (a -> a) -> a -> a applyWhen cond f = if cond then f else identity deriveFoldable - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => Bool -- is there a left parameter (are we deriving Bifoldable)? + :: Bool -- is there a left parameter (are we deriving Bifoldable)? -> Qualified (ProperName 'ClassName) -> UnwrappedTypeConstructor - -> m [(PSString, Expr)] + -> TypeCheckM [(PSString, Expr)] deriveFoldable isBi nm utc = do ctors <- validateParamsInTypeConstructors nm utc isBi foldableClasses Nothing foldlFun <- mkAsymmetricFoldFunction False foldlExprs ctors @@ -737,7 +699,7 @@ deriveFoldable isBi nm utc = do identityVar = mkRef Libs.I_identity memptyVar = mkRef Libs.I_mempty - mkAsymmetricFoldFunction :: Bool -> TraversalExprs -> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])] -> m Expr + mkAsymmetricFoldFunction :: Bool -> TraversalExprs -> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])] -> TypeCheckM Expr mkAsymmetricFoldFunction isRightFold te@TraversalExprs{..} ctors = do f <- freshIdent "f" g <- if isBi then freshIdent "g" else pure f @@ -746,13 +708,13 @@ deriveFoldable isBi nm utc = do appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr appCombiner (isFlipped, fn) = applyWhen (isFlipped == isRightFold) flip $ App . App fn - mkCombinerExpr :: ParamUsage Void -> m Expr + mkCombinerExpr :: ParamUsage Void -> TypeCheckM Expr mkCombinerExpr = fmap (uncurry $ \isFlipped -> applyWhen isFlipped $ App flipVar) . getCombiner - handleValue :: ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr + handleValue :: ParamUsage Void -> Expr -> Const [TypeCheckM (Expr -> Expr)] Expr handleValue = unnestRecords $ \usage inputExpr -> toConst $ flip appCombiner inputExpr <$> getCombiner usage - getCombiner :: ParamUsage Void -> m (Bool, Expr) + getCombiner :: ParamUsage Void -> TypeCheckM (Bool, Expr) getCombiner = \case IsParam -> pure (False, mkVar g) @@ -770,7 +732,7 @@ deriveFoldable isBi nm utc = do then flip extractExprStartingWith $ foldFieldsOf lVar else extractExprStartingWith lVar . foldFieldsOf - extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr + extractExprStartingWith :: Expr -> Const [TypeCheckM (Expr -> Expr)] Expr -> TypeCheckM Expr extractExprStartingWith = consumeConst . if isRightFold then foldr ($) else foldl' (&) lam f . applyWhen isBi (lam g) . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors @@ -787,14 +749,10 @@ foldMapOps = TraversalOps { visitExpr = toConst, .. } exprs -> foldr1 (App . App appendVar) exprs deriveTraversable - :: forall m - . MonadError MultipleErrors m - => MonadState CheckState m - => MonadSupply m - => Bool -- is there a left parameter (are we deriving Bitraversable)? + :: Bool -- is there a left parameter (are we deriving Bitraversable)? -> Qualified (ProperName 'ClassName) -> UnwrappedTypeConstructor - -> m [(PSString, Expr)] + -> TypeCheckM [(PSString, Expr)] deriveTraversable isBi nm utc = do ctors <- validateParamsInTypeConstructors nm utc isBi traversableClasses Nothing traverseFun <- mkTraversal (utcModuleName utc) isBi traverseExprs absurd traverseOps ctors @@ -815,19 +773,19 @@ deriveTraversable isBi nm utc = do bitraverseVar = mkRef Libs.I_bitraverse identityVar = mkRef Libs.I_identity -traverseOps :: forall m. MonadSupply m => TraversalOps m +traverseOps :: TraversalOps TypeCheckM traverseOps = TraversalOps { .. } where pureVar = mkRef Libs.I_pure mapVar = mkRef Libs.I_map applyVar = mkRef Libs.I_apply - visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr + visitExpr :: TypeCheckM Expr -> WriterT [(Ident, TypeCheckM Expr)] TypeCheckM Expr visitExpr traversedExpr = do ident <- freshIdent "v" tell [(ident, traversedExpr)] $> mkVar ident - extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr + extractExpr :: WriterT [(Ident, TypeCheckM Expr)] TypeCheckM Expr -> TypeCheckM Expr extractExpr = runWriterT >=> \(result, unzip -> (ctx, args)) -> flip mkApps (foldr lam result ctx) <$> sequenceA args mkApps :: [Expr] -> Expr -> Expr diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 85bdfee4aa..7895e541b1 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -17,7 +17,6 @@ import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, gets, modify) import Control.Monad (foldM, guard, join, zipWithM, zipWithM_, (<=<)) -import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Data.Monoid (Any(..)) @@ -39,12 +38,12 @@ import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Lite import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) +import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint) +import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName) @@ -112,11 +111,10 @@ combineContexts = M.unionWith (M.unionWith (M.unionWith (<>))) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries - :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) - => Bool + :: + Bool -> Expr - -> m (Expr, [(Ident, InstanceContext, SourceConstraint)]) + -> TypeCheckM (Expr, [(Ident, InstanceContext, SourceConstraint)]) replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do -- Loop, deferring any unsolved constraints, until there are no more -- constraints which can be solved, then make a generalization pass. @@ -128,18 +126,18 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d loop expr >>= generalizePass where -- This pass solves constraints where possible, deferring constraints if not. - deferPass :: Expr -> StateT InstanceContext m (Expr, Any) + deferPass :: Expr -> StateT InstanceContext TypeCheckM (Expr, Any) deferPass = fmap (second fst) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr (_, f, _) = everywhereOnValuesTopDownM return (go True) return -- This pass generalizes any remaining constraints - generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, SourceConstraint)]) + generalizePass :: Expr -> StateT InstanceContext TypeCheckM (Expr, [(Ident, InstanceContext, SourceConstraint)]) generalizePass = fmap (second snd) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr (_, f, _) = everywhereOnValuesTopDownM return (go False) return - go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr go deferErrors (TypeClassDictionary constraint context hints) = rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints go _ other = return other @@ -180,9 +178,8 @@ instance Monoid t => Monoid (Matched t) where -- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. entails - :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) - => SolverOptions + :: + SolverOptions -- ^ Solver options -> SourceConstraint -- ^ The constraint to solve @@ -190,11 +187,11 @@ entails -- ^ The contexts in which to solve the constraint -> [ErrorMessageHint] -- ^ Error message hints to apply to any instance errors - -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr entails SolverOptions{..} constraint context hints = overConstraintArgsAll (lift . lift . traverse replaceAllTypeSynonyms) constraint >>= solve where - forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] + forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> TypeCheckM [TypeClassDict] forClassNameM env ctx cn@C.Coercible kinds args = fromMaybe (forClassName env ctx cn kinds args) <$> solveCoercible env ctx kinds args @@ -234,10 +231,10 @@ entails SolverOptions{..} constraint context hints = valUndefined :: Expr valUndefined = Var nullSourceSpan C.I_undefined - solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr solve = go 0 hints where - go :: Int -> [ErrorMessageHint] -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + go :: Int -> [ErrorMessageHint] -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) Expr go work _ (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work hints' con@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to @@ -343,7 +340,7 @@ entails SolverOptions{..} constraint context hints = withFreshTypes :: TypeClassDict -> Matching SourceType - -> m (Matching SourceType) + -> TypeCheckM (Matching SourceType) withFreshTypes TypeClassDictionaryInScope{..} initSubst = do subst <- foldM withFreshType initSubst $ filter (flip M.notMember initSubst . fst) tcdForAll for_ (M.toList initSubst) $ unifySubstKind subst @@ -361,7 +358,7 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> UnknownsHint -> m (EntailsResult a) + unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> UnknownsHint -> TypeCheckM (EntailsResult a) unique kindArgs tyArgs ambiguous [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want @@ -401,7 +398,7 @@ entails SolverOptions{..} constraint context hints = -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: Matching SourceType -> ErrorMessageHint -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) (Maybe [Expr]) + solveSubgoals :: Matching SourceType -> ErrorMessageHint -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext TypeCheckM) (Maybe [Expr]) solveSubgoals _ _ Nothing = return Nothing solveSubgoals subst hint (Just subgoals) = Just <$> traverse (rethrow (addHint hint) . go (work + 1) (hints' <> [hint]) . mapConstraintArgsAll (map (replaceAllTypeVars (M.toList subst)))) subgoals @@ -412,7 +409,7 @@ entails SolverOptions{..} constraint context hints = useEmptyDict args = Unused (foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args)) -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Evidence -> Maybe [Expr] -> m Expr + mkDictionary :: Evidence -> Maybe [Expr] -> TypeCheckM Expr mkDictionary (NamedInstance n) args = return $ foldl App (Var nullSourceSpan n) (fold args) mkDictionary EmptyClassInstance args = return (useEmptyDict args) mkDictionary (WarnInstance msg) args = do @@ -470,7 +467,7 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) + solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> TypeCheckM (Maybe [TypeClassDict]) solveCoercible env ctx kinds [a, b] = do let coercibleDictsInScope = findDicts ctx C.Coercible ByNullSourcePos givens = flip mapMaybe coercibleDictsInScope $ \case diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 8abaac31ca..18826f3a40 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -18,12 +18,12 @@ import Prelude hiding (interact) import Control.Applicative ((<|>), empty) import Control.Arrow ((&&&)) import Control.Monad ((<=<), guard, unless, when) -import Control.Monad.Error.Class (MonadError, catchError, throwError) -import Control.Monad.State (MonadState, StateT, get, gets, modify, put) +import Control.Monad.Error.Class (catchError, throwError) +import Control.Monad.State (StateT, get, gets, modify, put) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell) +import Control.Monad.Writer (Writer, execWriter, runWriter, runWriterT, tell, WriterT) import Data.Either (partitionEithers) import Data.Foldable (fold, foldl', for_, toList) import Data.Functor (($>)) @@ -40,7 +40,7 @@ import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeK import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad (CheckState(..)) +import Language.PureScript.TypeChecker.Monad (CheckState(..), TypeCheckM) import Language.PureScript.TypeChecker.Roles (lookupRoles) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType) @@ -118,10 +118,8 @@ initialGivenSolverState = -- 3c. Otherwise canonicalization can succeed with derived constraints which we -- add to the unsolved queue and then go back to 1. solveGivens - :: MonadError MultipleErrors m - => MonadState CheckState m - => Environment - -> StateT GivenSolverState m () + :: Environment + -> StateT GivenSolverState TypeCheckM () solveGivens env = go (0 :: Int) where go n = do when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance @@ -206,18 +204,15 @@ initialWantedSolverState givens a b = -- interact the latter with the former, we would report an insoluble -- @Coercible Boolean Char@. solveWanteds - :: MonadError MultipleErrors m - => MonadWriter [ErrorMessageHint] m - => MonadState CheckState m - => Environment - -> StateT WantedSolverState m () + :: Environment + -> StateT WantedSolverState CanonM () solveWanteds env = go (0 :: Int) where go n = do when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance gets unsolvedWanteds >>= \case [] -> pure () wanted : unsolved -> do - (k, a, b) <- lift $ unify wanted + (k, a, b) <- lift $ lift $ unify wanted WantedSolverState{..} <- get lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case Irreducible -> case interact env (a, b) inertGivens of @@ -271,10 +266,8 @@ solveWanteds env = go (0 :: Int) where -- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by -- reflexivity instead of having to saturate the type constructors. unify - :: MonadError MultipleErrors m - => MonadState CheckState m - => (SourceType, SourceType) - -> m (SourceType, SourceType, SourceType) + :: (SourceType, SourceType) + -> TypeCheckM (SourceType, SourceType, SourceType) unify (a, b) = do let kindOf = sequence . (id &&& elaborateKind) <=< replaceAllTypeSynonyms (a', kind) <- kindOf a @@ -475,18 +468,17 @@ data Canonicalized -- necessarily an error, we may make further progress by interacting with -- inerts. +type CanonM = WriterT [ErrorMessageHint] TypeCheckM + -- | Canonicalization takes a wanted constraint and try to reduce it to a set of -- simpler constraints whose satisfaction will imply the goal. canon - :: MonadError MultipleErrors m - => MonadWriter [ErrorMessageHint] m - => MonadState CheckState m - => Environment + :: Environment -> Maybe [(SourceType, SourceType, SourceType)] -> SourceType -> SourceType -> SourceType - -> m Canonicalized + -> CanonM Canonicalized canon env givens k a b = maybe (throwError $ insoluble k a b) pure <=< runMaybeT $ canonRefl a b @@ -538,10 +530,9 @@ insoluble k a b = -- are the same. Since we currently don't support higher-rank arguments in -- instance heads, term equality is a sufficient notion of "the same". canonRefl - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonRefl a b = guard (a == b) $> Canonicalized mempty @@ -550,12 +541,10 @@ canonRefl a b = -- @Coercible (T1 a_0 .. a_n c_0 .. c_m) (T2 b_0 .. b_n c_0 .. c_m)@, where both -- arguments are fully saturated with the same unknowns and have kind @Type@. canonUnsaturatedHigherKindedType - :: MonadError MultipleErrors m - => MonadState CheckState m - => Environment + :: Environment -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonUnsaturatedHigherKindedType env a b | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env) @@ -564,10 +553,10 @@ canonUnsaturatedHigherKindedType env a b ak' <- lift $ do let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps - unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs + unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> lift (freshKindWithKind ss k)) $ drop (length akapps) kvs pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak' let (aks', _) = unapplyKinds ak' - tys <- traverse freshTypeWithKind $ drop (length axs) aks' + tys <- traverse (lift . lift . freshTypeWithKind) $ drop (length axs) aks' let a' = foldl' srcTypeApp a tys b' = foldl' srcTypeApp b tys pure . Canonicalized $ S.singleton (a', b') @@ -578,11 +567,9 @@ canonUnsaturatedHigherKindedType env a b -- yield a constraint @Coercible r s@ and constraints on the types for each -- label in both rows. Labels exclusive to one row yield a failure. canonRow - :: MonadError MultipleErrors m - => MonadState CheckState m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonRow a b | RCons{} <- a = case alignRowsWith (const (,)) a b of @@ -591,10 +578,10 @@ canonRow a b -- and the unification error thrown when the rows are misaligned should -- not mention unknowns. (_, (([], u@TUnknown{}), rl2)) -> do - k <- elaborateKind u + k <- lift $ lift $ elaborateKind u throwError $ insoluble k u (rowFromList rl2) (_, (rl1, ([], u@TUnknown{}))) -> do - k <- elaborateKind u + k <- lift $ lift $ elaborateKind u throwError $ insoluble k (rowFromList rl1) u (deriveds, (([], tail1), ([], tail2))) -> do pure . Canonicalized . S.fromList $ (tail1, tail2) : deriveds @@ -628,11 +615,9 @@ data UnwrapNewtypeError -- | Unwraps a newtype and yields its underlying type with the newtype arguments -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@). unwrapNewtype - :: MonadState CheckState m - => MonadWriter [ErrorMessageHint] m - => Environment + :: Environment -> SourceType - -> m (Either UnwrapNewtypeError SourceType) + -> CanonM (Either UnwrapNewtypeError SourceType) unwrapNewtype env = go (0 :: Int) where go n ty = runExceptT $ do when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain @@ -712,14 +697,12 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali -- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint -- @Coercible a b@ if unwrapping the newtype yields @a@. canonNewtypeLeft - :: MonadState CheckState m - => MonadWriter [ErrorMessageHint] m - => Environment + :: Environment -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonNewtypeLeft env a b = - unwrapNewtype env a >>= \case + lift (unwrapNewtype env a) >>= \case Left CannotUnwrapInfiniteNewtypeChain -> empty Left CannotUnwrapConstructor -> empty Right a' -> pure . Canonicalized $ S.singleton (a', b) @@ -727,12 +710,10 @@ canonNewtypeLeft env a b = -- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint -- @Coercible a b@ if unwrapping the newtype yields @b@. canonNewtypeRight - :: MonadState CheckState m - => MonadWriter [ErrorMessageHint] m - => Environment + :: Environment -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonNewtypeRight env = flip $ canonNewtypeLeft env @@ -750,12 +731,11 @@ canonNewtypeRight env = -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but -- decomposing @Coercible (D a c d) (D b c d)@ would fail. decompose - :: MonadError MultipleErrors m - => Environment + :: Environment -> Qualified (ProperName 'TypeName) -> [SourceType] -> [SourceType] - -> m Canonicalized + -> TypeCheckM Canonicalized decompose env tyName axs bxs = do let roles = lookupRoles env tyName f role ax bx = case role of @@ -779,29 +759,27 @@ decompose env tyName axs bxs = do -- | Constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@, where -- @D@ is not a newtype, yield constraints on their arguments. canonDecomposition - :: MonadError MultipleErrors m - => Environment + :: Environment -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonDecomposition env a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b , aTyName == bTyName , Nothing <- lookupNewtypeConstructor env aTyName [] = - decompose env aTyName axs bxs + lift $ lift $ decompose env aTyName axs bxs | otherwise = empty -- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where -- @D1@ and @D2@ are different type constructors and neither of them are -- newtypes, are insoluble. canonDecompositionFailure - :: MonadError MultipleErrors m - => Environment + :: Environment -> SourceType -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonDecompositionFailure env k a b | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b @@ -845,12 +823,11 @@ canonDecompositionFailure env k a b -- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able -- to discharge it with the given. canonNewtypeDecomposition - :: MonadError MultipleErrors m - => Environment + :: Environment -> Maybe [(SourceType, SourceType, SourceType)] -> SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonNewtypeDecomposition env (Just givens) a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b @@ -858,17 +835,16 @@ canonNewtypeDecomposition env (Just givens) a b , Just _ <- lookupNewtypeConstructor env aTyName [] = do let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens guard $ not givensCanDischarge - decompose env aTyName axs bxs + lift $ lift $ decompose env aTyName axs bxs canonNewtypeDecomposition _ _ _ _ = empty -- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where -- @N1@ and @N2@ are different type constructors and either of them is a -- newtype whose constructor is out of scope, are irreducible. canonNewtypeDecompositionFailure - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonNewtypeDecompositionFailure a b | (TypeConstructor{}, _, _) <- unapplyTypes a , (TypeConstructor{}, _, _) <- unapplyTypes b @@ -890,10 +866,9 @@ canonNewtypeDecompositionFailure a b -- repeatedly kick each other out the inert set whereas reordering the latter to -- @Coercible a b@ makes it redundant and let us discharge it. canonTypeVars - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonTypeVars a b | Skolem _ tv1 _ _ _ <- a , Skolem _ tv2 _ _ _ <- b @@ -905,10 +880,9 @@ canonTypeVars a b -- | Constraints of the form @Coercible tv ty@ are irreducibles. canonTypeVarLeft - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonTypeVarLeft a _ | Skolem{} <- a = pure Irreducible | otherwise = empty @@ -917,30 +891,27 @@ canonTypeVarLeft a _ -- @Coercible tv ty@ to satisfy the canonicality requirement of having the type -- variable on the left. canonTypeVarRight - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonTypeVarRight a b | Skolem{} <- b = pure . Canonicalized $ S.singleton (b, a) | otherwise = empty -- | Constraints of the form @Coercible (f a_0 .. a_n) b@ are irreducibles. canonApplicationLeft - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonApplicationLeft a _ | TypeApp{} <- a = pure Irreducible | otherwise = empty -- | Constraints of the form @Coercible a (f b_0 .. b_n) b@ are irreducibles. canonApplicationRight - :: Monad m - => SourceType + :: SourceType -> SourceType - -> MaybeT m Canonicalized + -> MaybeT CanonM Canonicalized canonApplicationRight _ b | TypeApp{} <- b = pure Irreducible | otherwise = empty diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5be87c0057..629ad68773 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -31,7 +31,7 @@ import Control.Arrow ((***)) import Control.Lens ((^.), _1, _2, _3) import Control.Monad (join, unless, void, when, (<=<)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState, gets, modify) +import Control.Monad.State (gets, modify) import Control.Monad.Supply.Class (MonadSupply(..)) import Data.Bifunctor (first, second) @@ -51,7 +51,7 @@ import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified) -import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution) +import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.Types @@ -87,7 +87,7 @@ unknownVarNames used unks = vars :: [Text] vars = fmap (("k" <>) . T.pack . show) ([1..] :: [Int]) -apply :: (MonadState CheckState m) => SourceType -> m SourceType +apply :: SourceType -> TypeCheckM SourceType apply ty = flip substituteType ty <$> gets checkSubstitution substituteType :: Substitution -> SourceType -> SourceType @@ -100,22 +100,22 @@ substituteType sub = everywhereOnTypes $ \case other -> other -freshUnknown :: (MonadState CheckState m) => m Unknown +freshUnknown :: TypeCheckM Unknown freshUnknown = do k <- gets checkNextType modify $ \st -> st { checkNextType = k + 1 } pure k -freshKind :: (MonadState CheckState m) => SourceSpan -> m SourceType +freshKind :: SourceSpan -> TypeCheckM SourceType freshKind ss = freshKindWithKind ss E.kindType -freshKindWithKind :: (MonadState CheckState m) => SourceSpan -> SourceType -> m SourceType +freshKindWithKind :: SourceSpan -> SourceType -> TypeCheckM SourceType freshKindWithKind ss kind = do u <- freshUnknown addUnsolved Nothing u kind pure $ TUnknown (ss, []) u -addUnsolved :: (MonadState CheckState m) => Maybe UnkLevel -> Unknown -> SourceType -> m () +addUnsolved :: Maybe UnkLevel -> Unknown -> SourceType -> TypeCheckM () addUnsolved lvl unk kind = modify $ \st -> do let newLvl = UnkLevel $ case lvl of @@ -125,7 +125,7 @@ addUnsolved lvl unk kind = modify $ \st -> do uns = M.insert unk (newLvl, kind) $ substUnsolved subs st { checkSubstitution = subs { substUnsolved = uns } } -solve :: (MonadState CheckState m) => Unknown -> SourceType -> m () +solve :: Unknown -> SourceType -> TypeCheckM () solve unk solution = modify $ \st -> do let subs = checkSubstitution st @@ -133,9 +133,9 @@ solve unk solution = modify $ \st -> do st { checkSubstitution = subs { substType = tys } } lookupUnsolved - :: (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack) + :: (HasCallStack) => Unknown - -> m (UnkLevel, SourceType) + -> TypeCheckM (UnkLevel, SourceType) lookupUnsolved u = do uns <- gets (substUnsolved . checkSubstitution) case M.lookup u uns of @@ -143,9 +143,9 @@ lookupUnsolved u = do Just res -> return res unknownsWithKinds - :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack) + :: (HasCallStack) => [Unknown] - -> m [(Unknown, SourceType)] + -> TypeCheckM [(Unknown, SourceType)] unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go where go u = do @@ -154,9 +154,9 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) pure $ (lvl, (u, ty)) : rest inferKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m (SourceType, SourceType) + -> TypeCheckM (SourceType, SourceType) inferKind = \tyToInfer -> withErrorMessageHint (ErrorInferringKind tyToInfer) . rethrowWithPosition (fst $ getAnnForType tyToInfer) @@ -242,11 +242,11 @@ inferKind = \tyToInfer -> internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty inferAppKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceAnn -> (SourceType, SourceType) -> SourceType - -> m (SourceType, SourceType) + -> TypeCheckM (SourceType, SourceType) inferAppKind ann (fn, fnKind) arg = case fnKind of TypeApp _ (TypeApp _ arrKind argKind) resKind | eqType arrKind E.tyFunction -> do expandSynonyms <- requiresSynonymsToExpand fn @@ -275,20 +275,20 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of _ -> pure True cannotApplyTypeToType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m a + -> TypeCheckM a cannotApplyTypeToType fn arg = do argKind <- snd <$> inferKind arg _ <- checkKind fn . srcTypeApp (srcTypeApp E.tyFunction argKind) =<< freshKind nullSourceSpan internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg) cannotApplyKindToType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m a + -> TypeCheckM a cannotApplyKindToType poly arg = do let ann = getAnnForType arg argKind <- snd <$> inferKind arg @@ -296,10 +296,10 @@ cannotApplyKindToType poly arg = do internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg) checkKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m SourceType + -> TypeCheckM SourceType checkKind = checkKind' False -- | `checkIsSaturatedType t` is identical to `checkKind t E.kindType` except @@ -310,17 +310,17 @@ checkKind = checkKind' False -- error. -- checkIsSaturatedType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m SourceType + -> TypeCheckM SourceType checkIsSaturatedType ty = checkKind' True ty E.kindType checkKind' - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => Bool -> SourceType -> SourceType - -> m SourceType + -> TypeCheckM SourceType checkKind' requireSynonymsToExpand ty kind2 = do withErrorMessageHint (ErrorCheckingKind ty kind2) . rethrowWithPosition (fst $ getAnnForType ty) $ do @@ -331,10 +331,10 @@ checkKind' requireSynonymsToExpand ty kind2 = do instantiateKind (ty', kind1') kind2' instantiateKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => (SourceType, SourceType) -> SourceType - -> m SourceType + -> TypeCheckM SourceType instantiateKind (ty, kind1) kind2 = case kind1 of ForAll _ _ a (Just k) t _ | shouldInstantiate kind2 -> do let ann = getAnnForType ty @@ -349,10 +349,10 @@ instantiateKind (ty, kind1) kind2 = case kind1 of _ -> False subsumesKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m () + -> TypeCheckM () subsumesKind = go where go = curry $ \case @@ -380,10 +380,9 @@ subsumesKind = go unifyKinds a b unifyKinds - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) - => SourceType + :: SourceType -> SourceType - -> m () + -> TypeCheckM () unifyKinds = unifyKindsWithFailure $ \w1 w2 -> throwError . errorMessage''' (fst . getAnnForType <$> [w1, w2]) @@ -393,10 +392,10 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 -> -- | local position context. This is useful when invoking kind unification -- | outside of kind checker internals. unifyKinds' - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m () + -> TypeCheckM () unifyKinds' = unifyKindsWithFailure $ \w1 w2 -> throwError . errorMessage @@ -404,19 +403,19 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 -> -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType -> SourceType - -> m () + -> TypeCheckM () checkTypeKind ty kind = unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType unifyKindsWithFailure - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) - => (SourceType -> SourceType -> m ()) + :: (HasCallStack) + => (SourceType -> SourceType -> TypeCheckM ()) -> SourceType -> SourceType - -> m () + -> TypeCheckM () unifyKindsWithFailure onFailure = go where goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ go t1 t2 @@ -464,10 +463,10 @@ unifyKindsWithFailure onFailure = go onFailure (rowFromList w1) (rowFromList w2) solveUnknown - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => Unknown -> SourceType - -> m () + -> TypeCheckM () solveUnknown a' p1 = do p2 <- promoteKind a' p1 w1 <- snd <$> lookupUnsolved a' @@ -475,10 +474,10 @@ solveUnknown a' p1 = do solve a' p2 solveUnknownAsFunction - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceAnn -> Unknown - -> m SourceType + -> TypeCheckM SourceType solveUnknownAsFunction ann u = do lvl <- fst <$> lookupUnsolved u u1 <- freshUnknown @@ -490,10 +489,10 @@ solveUnknownAsFunction ann u = do pure uarr promoteKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => Unknown -> SourceType - -> m SourceType + -> TypeCheckM SourceType promoteKind u2 ty = do lvl2 <- fst <$> lookupUnsolved u2 flip everywhereOnTypesM ty $ \case @@ -512,9 +511,9 @@ promoteKind u2 ty = do pure ty' elaborateKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m SourceType + -> TypeCheckM SourceType elaborateKind = \case TypeLevelString ann _ -> pure $ E.kindSymbol $> ann @@ -572,7 +571,7 @@ elaborateKind = \case ty -> throwError . errorMessage' (fst (getAnnForType ty)) $ UnsupportedTypeInKind ty -checkEscapedSkolems :: MonadError MultipleErrors m => SourceType -> m () +checkEscapedSkolems :: SourceType -> TypeCheckM () checkEscapedSkolems ty = traverse_ (throwError . toSkolemError) . everythingWithContextOnTypes ty [] (<>) go @@ -588,9 +587,9 @@ checkEscapedSkolems ty = errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty' kindOfWithUnknowns - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m (([(Unknown, SourceType)], SourceType), SourceType) + -> TypeCheckM (([(Unknown, SourceType)], SourceType), SourceType) kindOfWithUnknowns ty = do (ty', kind) <- kindOf ty unks <- unknownsWithKinds . IS.toList $ unknowns ty' @@ -598,16 +597,16 @@ kindOfWithUnknowns ty = do -- | Infer the kind of a single type kindOf - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m (SourceType, SourceType) + -> TypeCheckM (SourceType, SourceType) kindOf = fmap (first snd) . kindOfWithScopedVars -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (HasCallStack) => SourceType - -> m (([(Text, SourceType)], SourceType), SourceType) + -> TypeCheckM (([(Text, SourceType)], SourceType), SourceType) kindOfWithScopedVars ty = do (ty', kind) <- bitraverse apply (replaceAllTypeSynonyms <=< apply) =<< inferKind ty let binders = fst . fromJust $ completeBinderList ty' @@ -628,18 +627,18 @@ type DataDeclarationResult = ) kindOfData - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> DataDeclarationArgs - -> m DataDeclarationResult + -> TypeCheckM DataDeclarationResult kindOfData moduleName dataDecl = head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] inferDataDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> DataDeclarationArgs - -> m [(DataConstructorDeclaration, SourceType)] + -> TypeCheckM [(DataConstructorDeclaration, SourceType)] inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind @@ -656,10 +655,10 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor' inferDataConstructor - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => SourceType + :: + SourceType -> DataConstructorDeclaration - -> m (DataConstructorDeclaration, SourceType) + -> TypeCheckM (DataConstructorDeclaration, SourceType) inferDataConstructor tyCtor DataConstructorDeclaration{..} = do dataCtorFields' <- traverse (traverse checkIsSaturatedType) dataCtorFields dataCtor <- flip (foldr ((E.-:>) . snd)) dataCtorFields' <$> checkKind tyCtor E.kindType @@ -680,18 +679,18 @@ type TypeDeclarationResult = ) kindOfTypeSynonym - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> TypeDeclarationArgs - -> m TypeDeclarationResult + -> TypeCheckM TypeDeclarationResult kindOfTypeSynonym moduleName typeDecl = head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] inferTypeSynonym - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> TypeDeclarationArgs - -> m SourceType + -> TypeCheckM SourceType inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind @@ -710,9 +709,9 @@ inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do -- | ill-scoped. We require that users explicitly generalize this kind -- | in such a case. checkQuantification - :: forall m. (MonadError MultipleErrors m) - => SourceType - -> m () + :: + SourceType + -> TypeCheckM () checkQuantification = collectErrors . go [] [] . fst . fromJust . completeBinderList where @@ -737,9 +736,9 @@ checkQuantification = elem karg $ freeTypeVariables k checkVisibleTypeQuantification - :: forall m. (MonadError MultipleErrors m) - => SourceType - -> m () + :: + SourceType + -> TypeCheckM () checkVisibleTypeQuantification = collectErrors . freeTypeVariables where @@ -754,9 +753,9 @@ checkVisibleTypeQuantification = -- | implicitly generalize unknowns, such as on the right-hand-side of -- | a type synonym, or in arguments to data constructors. checkTypeQuantification - :: forall m. (MonadError MultipleErrors m) - => SourceType - -> m () + :: + SourceType + -> TypeCheckM () checkTypeQuantification = collectErrors . everythingWithContextOnTypes True [] (<>) unknownsInKinds where @@ -797,18 +796,18 @@ type ClassDeclarationResult = ) kindOfClass - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> ClassDeclarationArgs - -> m ClassDeclarationResult + -> TypeCheckM ClassDeclarationResult kindOfClass moduleName clsDecl = head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] inferClassDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> ClassDeclarationArgs - -> m ([(Text, SourceType)], [SourceConstraint], [Declaration]) + -> TypeCheckM ([(Text, SourceType)], [SourceConstraint], [Declaration]) inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do clsKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind @@ -821,18 +820,18 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = <*> for decls checkClassMemberDeclaration checkClassMemberDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => Declaration - -> m Declaration + :: + Declaration + -> TypeCheckM Declaration checkClassMemberDeclaration = \case TypeDeclaration (TypeDeclarationData ann ident ty) -> TypeDeclaration . TypeDeclarationData ann ident <$> checkKind ty E.kindType _ -> internalError "Invalid class member declaration" applyClassMemberDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => Declaration - -> m Declaration + :: + Declaration + -> TypeCheckM Declaration applyClassMemberDeclaration = \case TypeDeclaration (TypeDeclarationData ann ident ty) -> TypeDeclaration . TypeDeclarationData ann ident <$> apply ty @@ -846,18 +845,18 @@ mapTypeDeclaration f = \case other checkConstraint - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => SourceConstraint - -> m SourceConstraint + :: + SourceConstraint + -> TypeCheckM SourceConstraint checkConstraint (Constraint ann clsName kinds args dat) = do let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args (_, kinds', args') <- unapplyTypes <$> checkKind ty E.kindConstraint pure $ Constraint ann clsName kinds' args' dat applyConstraint - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => SourceConstraint - -> m SourceConstraint + :: + SourceConstraint + -> TypeCheckM SourceConstraint applyConstraint (Constraint ann clsName kinds args dat) = do let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args (_, kinds', args') <- unapplyTypes <$> apply ty @@ -878,10 +877,10 @@ type InstanceDeclarationResult = ) checkInstanceDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> InstanceDeclarationArgs - -> m InstanceDeclarationResult + -> TypeCheckM InstanceDeclarationResult checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do let ty = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) args tyWithConstraints = foldr srcConstrainedType ty constraints @@ -899,10 +898,10 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do pure (allConstraints, allKinds, allArgs, varKinds) checkKindDeclaration - :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> SourceType - -> m SourceType + -> TypeCheckM SourceType checkKindDeclaration _ ty = do (ty', kind) <- kindOf ty checkTypeKind kind E.kindType @@ -934,11 +933,11 @@ checkKindDeclaration _ ty = do other -> pure other existingSignatureOrFreshKind - :: forall m. MonadState CheckState m - => ModuleName + :: + ModuleName -> SourceSpan -> ProperName 'TypeName - -> m SourceType + -> TypeCheckM SourceType existingSignatureOrFreshKind moduleName ss name = do env <- getEnv case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of @@ -946,12 +945,12 @@ existingSignatureOrFreshKind moduleName ss name = do Just (kind, _) -> pure kind kindsOfAll - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + :: + ModuleName -> [TypeDeclarationArgs] -> [DataDeclarationArgs] -> [ClassDeclarationArgs] - -> m ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) + -> TypeCheckM ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do synDict <- for syns $ \(sa, synName, _, _) -> (synName,) <$> existingSignatureOrFreshKind moduleName (fst sa) synName datDict <- for dats $ \(sa, datName, _, _) -> (datName,) <$> existingSignatureOrFreshKind moduleName (fst sa) datName diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..aa6b61abc1 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -9,7 +9,7 @@ import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState(..), StateT(..), gets, modify) +import Control.Monad.State (MonadState(..), StateT(..), gets, modify, MonadIO (liftIO)) import Control.Monad (forM_, guard, join, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) @@ -28,6 +28,31 @@ import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar) import Text.PrettyPrint.Boxes (render) +import Control.Monad.Supply (SupplyT (unSupplyT)) +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Logger (Logger, runLogger') +import Control.Monad.Supply.Class qualified as Supply + +newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (Logger MultipleErrors))) a } + deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) + +-- | Lift a TypeCheckM computation into another monad that satisfies all its constraints +liftTypeCheckM :: + (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadIO m) => + TypeCheckM a -> m a +liftTypeCheckM (TypeCheckM m) = do + st <- get + freshId <- Supply.peek + (result, errors) <- liftIO $ runLogger' $ runExceptT $ flip runStateT freshId $ unSupplyT $ runStateT m st + tell errors + case result of + Left err -> + throwError err + Right ((a, st'), freshId') -> do + put st' + Supply.consumeUpTo freshId' + return a newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown) deriving (Eq, Show) @@ -116,10 +141,9 @@ type Unknown = Int -- | Temporarily bind a collection of names to values bindNames - :: MonadState CheckState m - => M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) - -> m a - -> m a + :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + -> TypeCheckM a + -> TypeCheckM a bindNames newNames action = do orig <- get modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } } @@ -129,10 +153,9 @@ bindNames newNames action = do -- | Temporarily bind a collection of names to types bindTypes - :: MonadState CheckState m - => M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) - -> m a - -> m a + :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) + -> TypeCheckM a + -> TypeCheckM a bindTypes newNames action = do orig <- get modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } } @@ -142,11 +165,10 @@ bindTypes newNames action = do -- | Temporarily bind a collection of names to types withScopedTypeVars - :: (MonadState CheckState m, MonadWriter MultipleErrors m) - => ModuleName + :: ModuleName -> [(Text, SourceType)] - -> m a - -> m a + -> TypeCheckM a + -> TypeCheckM a withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> @@ -169,29 +191,26 @@ withErrorMessageHint hint action = do -- | These hints are added at the front, so the most nested hint occurs -- at the front, but the simplifier assumes the reverse order. -getHints :: MonadState CheckState m => m [ErrorMessageHint] +getHints :: TypeCheckM [ErrorMessageHint] getHints = gets (reverse . checkHints) rethrowWithPositionTC - :: (MonadState CheckState m, MonadError MultipleErrors m) - => SourceSpan - -> m a - -> m a + :: SourceSpan + -> TypeCheckM a + -> TypeCheckM a rethrowWithPositionTC pos = withErrorMessageHint (positionedError pos) warnAndRethrowWithPositionTC - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => SourceSpan - -> m a - -> m a + :: SourceSpan + -> TypeCheckM a + -> TypeCheckM a warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos -- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries - :: MonadState CheckState m - => [NamedDict] - -> m a - -> m a + :: [NamedDict] + -> TypeCheckM a + -> TypeCheckM a withTypeClassDictionaries entries action = do orig <- get @@ -209,54 +228,49 @@ withTypeClassDictionaries entries action = do -- | Get the currently available map of type class dictionaries getTypeClassDictionaries - :: (MonadState CheckState m) - => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) + :: TypeCheckM (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries - :: (MonadState CheckState m) - => QualifiedBy - -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + :: QualifiedBy + -> TypeCheckM (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass - :: (MonadState CheckState m) - => QualifiedBy + :: QualifiedBy -> Qualified (ProperName 'ClassName) - -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) + -> TypeCheckM (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn -- | Temporarily bind a collection of names to local variables bindLocalVariables - :: (MonadState CheckState m) - => [(SourceSpan, Ident, SourceType, NameVisibility)] - -> m a - -> m a + :: [(SourceSpan, Ident, SourceType, NameVisibility)] + -> TypeCheckM a + -> TypeCheckM a bindLocalVariables bindings = bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables - :: (MonadState CheckState m) - => ModuleName + :: ModuleName -> [(ProperName 'TypeName, SourceType)] - -> m a - -> m a + -> TypeCheckM a + -> TypeCheckM a bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined -makeBindingGroupVisible :: (MonadState CheckState m) => m () +makeBindingGroupVisible :: TypeCheckM () makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } -- | Update the visibility of all names to Defined in the scope of the provided action -withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a +withBindingGroupVisible :: TypeCheckM a -> TypeCheckM a withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action -- | Perform an action while preserving the names from the @Environment@. -preservingNames :: (MonadState CheckState m) => m a -> m a +preservingNames :: TypeCheckM a -> TypeCheckM a preservingNames action = do orig <- gets (names . checkEnv) a <- action @@ -265,9 +279,8 @@ preservingNames action = do -- | Lookup the type of a value by name in the @Environment@ lookupVariable - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => Qualified Ident - -> m SourceType + :: Qualified Ident + -> TypeCheckM SourceType lookupVariable qual = do env <- getEnv case M.lookup qual (names env) of @@ -276,9 +289,8 @@ lookupVariable qual = do -- | Lookup the visibility of a value by name in the @Environment@ getVisibility - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => Qualified Ident - -> m NameVisibility + :: Qualified Ident + -> TypeCheckM NameVisibility getVisibility qual = do env <- getEnv case M.lookup qual (names env) of @@ -287,9 +299,8 @@ getVisibility qual = do -- | Assert that a name is visible checkVisibility - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => Qualified Ident - -> m () + :: Qualified Ident + -> TypeCheckM () checkVisibility name@(Qualified _ var) = do vis <- getVisibility name case vis of @@ -298,10 +309,9 @@ checkVisibility name@(Qualified _ var) = do -- | Lookup the kind of a type by name in the @Environment@ lookupTypeVariable - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => ModuleName + :: ModuleName -> Qualified (ProperName 'TypeName) - -> m SourceType + -> TypeCheckM SourceType lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv case M.lookup (Qualified qb' name) (types env) of @@ -313,46 +323,44 @@ lookupTypeVariable currentModule (Qualified qb name) = do BySourcePos _ -> currentModule -- | Get the current @Environment@ -getEnv :: (MonadState CheckState m) => m Environment +getEnv :: TypeCheckM Environment getEnv = gets checkEnv -- | Get locally-bound names in context, to create an error message. -getLocalContext :: MonadState CheckState m => m Context +getLocalContext :: TypeCheckM Context getLocalContext = do env <- getEnv return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] -- | Update the @Environment@ -putEnv :: (MonadState CheckState m) => Environment -> m () +putEnv :: Environment -> TypeCheckM () putEnv env = modify (\s -> s { checkEnv = env }) -- | Modify the @Environment@ -modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m () +modifyEnv :: (Environment -> Environment) -> TypeCheckM () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. -runCheck :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment) +runCheck :: CheckState -> StateT CheckState TypeCheckM a -> TypeCheckM (a, Environment) runCheck st check = second checkEnv <$> runStateT check st -- | Make an assertion, failing with an error message -guardWith :: (MonadError e m) => e -> Bool -> m () +guardWith :: MonadError MultipleErrors m => MultipleErrors -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e capturingSubstitution - :: MonadState CheckState m - => (a -> Substitution -> b) - -> m a - -> m b + :: (a -> Substitution -> b) + -> TypeCheckM a + -> TypeCheckM b capturingSubstitution f ma = do a <- ma subst <- gets checkSubstitution return (f a subst) withFreshSubstitution - :: MonadState CheckState m - => m a - -> m a + :: TypeCheckM a + -> TypeCheckM a withFreshSubstitution ma = do orig <- get modify $ \st -> st { checkSubstitution = emptySubstitution } @@ -361,9 +369,8 @@ withFreshSubstitution ma = do return a withoutWarnings - :: MonadWriter w m - => m a - -> m (a, w) + :: TypeCheckM a + -> TypeCheckM (a, MultipleErrors) withoutWarnings = censor (const mempty) . listen unsafeCheckCurrentModule diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 26da5e980f..9e360462a9 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -9,7 +9,6 @@ import Prelude import Control.Monad (when) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) import Data.Foldable (for_) import Data.List (uncons) @@ -19,8 +18,8 @@ import Data.Ord (comparing) import Language.PureScript.AST (ErrorMessageHint(..), Expr(..), pattern NullSourceAnn) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (tyFunction, tyRecord) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, internalCompilerError) -import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClassDictionaries, withErrorMessageHint) +import Language.PureScript.Errors (SimpleErrorMessage(..), errorMessage, internalCompilerError) +import Language.PureScript.TypeChecker.Monad (getHints, getTypeClassDictionaries, withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes) import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList) @@ -59,21 +58,21 @@ defaultCoercion SNoElaborate = () -- | Check that one type subsumes another, rethrowing errors to provide a better error message subsumes - :: (MonadError MultipleErrors m, MonadState CheckState m) + :: () => SourceType -> SourceType - -> m (Expr -> Expr) + -> TypeCheckM (Expr -> Expr) subsumes ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' SElaborate ty1 ty2 -- | Check that one type subsumes another subsumes' - :: (MonadError MultipleErrors m, MonadState CheckState m) + :: () => ModeSing mode -> SourceType -> SourceType - -> m (Coercion mode) + -> TypeCheckM (Coercion mode) subsumes' mode (ForAll _ _ ident mbK ty1 _) ty2 = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK let replaced = replaceTypeVars ident u ty1 diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 567ae415ef..9672836d6a 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -12,14 +12,13 @@ module Language.PureScript.TypeChecker.Synonyms import Prelude import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState) import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Text (Text) import Language.PureScript.Environment (Environment(..), TypeKind) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage') import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified) -import Language.PureScript.TypeChecker.Monad (CheckState, getEnv) +import Language.PureScript.TypeChecker.Monad (getEnv, TypeCheckM) import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars) -- | Type synonym information (arguments with kinds, aliased type), indexed by name @@ -56,7 +55,7 @@ replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds -- | Replace fully applied type synonyms -replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType +replaceAllTypeSynonyms :: SourceType -> TypeCheckM SourceType replaceAllTypeSynonyms d = do env <- getEnv either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 6158f48a82..e8812a5439 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -12,10 +12,8 @@ import Language.PureScript.TypeChecker.Monad qualified as TC import Language.PureScript.TypeChecker.Subsumption (subsumes) import Language.PureScript.TypeChecker.Unify as P -import Control.Monad.Supply as P import Language.PureScript.AST as P import Language.PureScript.Environment as P -import Language.PureScript.Errors as P import Language.PureScript.Label (Label) import Language.PureScript.Names as P import Language.PureScript.Pretty.Types as P @@ -26,14 +24,23 @@ import Language.PureScript.Types as P checkInEnvironment :: Environment -> TC.CheckState - -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a + -> TC.TypeCheckM a -> Maybe (a, Environment) -checkInEnvironment env st = - either (const Nothing) Just - . runExcept - . evalWriterT - . P.evalSupplyT 0 - . TC.runCheck (st { TC.checkEnv = env }) +checkInEnvironment _ _ _ = Nothing +-- TODO: bring this back +-- Currently not possible since TypeCheckM contains IO +-- +-- checkInEnvironment +-- :: Environment +-- -> TC.CheckState +-- -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a +-- -> Maybe (a, Environment) +-- checkInEnvironment env st = +-- either (const Nothing) Just +-- . runExcept +-- . evalWriterT +-- . P.evalSupplyT 0 +-- . TC.runCheck (st { TC.checkEnv = env }) evalWriterT :: Monad m => WriterT b m r -> m r evalWriterT m = fmap fst (runWriterT m) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3f758805c6..6fe4cbf117 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,6 +1,7 @@ -- | -- This module implements the type checker -- +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) , typesOf @@ -76,7 +77,7 @@ tvToExpr :: TypedValue' -> Expr tvToExpr (TypedValue' c e t) = TypedValue c e t -- | Lookup data about a type class in the @Environment@ -lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData +lookupTypeClass :: MonadState CheckState TypeCheckM => Qualified (ProperName 'ClassName) -> TypeCheckM TypeClassData lookupTypeClass name = let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name in gets (findClass . typeClasses . checkEnv) @@ -84,11 +85,11 @@ lookupTypeClass name = -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => BindingGroupType -> ModuleName -> [((SourceAnn, Ident), Expr)] - -> m [((SourceAnn, Ident), (Expr, SourceType))] + -> TypeCheckM [((SourceAnn, Ident), (Expr, SourceType))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do (tys, wInfer) <- capturingSubstitution tidyUp $ do (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals @@ -245,10 +246,10 @@ data SplitBindingGroup = SplitBindingGroup -- This function also generates fresh unification variables for the types of -- declarations without type annotations, returned in the 'UntypedData' structure. typeDictionaryForBindingGroup - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Maybe ModuleName -> [((SourceAnn, Ident), Expr)] - -> m SplitBindingGroup + -> TypeCheckM SplitBindingGroup typeDictionaryForBindingGroup moduleName vals = do -- Filter the typed and untyped declarations and make a map of names to typed declarations. -- Replace type wildcards here so that the resulting dictionary of types contains the @@ -282,13 +283,13 @@ typeDictionaryForBindingGroup moduleName vals = do -- | Check the type annotation of a typed value in a binding group. checkTypedBindingGroupElement - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => ModuleName -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, SourceType)) + -> TypeCheckM ((SourceAnn, Ident), (Expr, SourceType)) checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- We replace type synonyms _after_ kind-checking, since we don't want type -- synonym expansion to bring type variables into scope. See #2542. @@ -301,13 +302,13 @@ checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => ((SourceAnn, Ident), (Expr, SourceType)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, SourceType)) + -> TypeCheckM ((SourceAnn, Ident), (Expr, SourceType)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope TypedValue' _ val' ty' <- bindNames dict $ infer val @@ -321,10 +322,10 @@ typeForBindingGroupElement (ident, (val, ty)) dict = do -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. instantiatePolyTypeWithUnknowns - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM) => Expr -> SourceType - -> m (Expr, SourceType) + -> TypeCheckM (Expr, SourceType) instantiatePolyTypeWithUnknowns val (ForAll _ _ ident mbK ty _) = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK insertUnkName' u ident @@ -336,17 +337,17 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do instantiatePolyTypeWithUnknowns val ty = return (val, ty) instantiatePolyTypeWithUnknownsUntilVisible - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM) => Expr -> SourceType - -> m (Expr, SourceType) + -> TypeCheckM (Expr, SourceType) instantiatePolyTypeWithUnknownsUntilVisible val (ForAll _ TypeVarInvisible ident mbK ty _) = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK insertUnkName' u ident instantiatePolyTypeWithUnknownsUntilVisible val $ replaceTypeVars ident u ty instantiatePolyTypeWithUnknownsUntilVisible val ty = return (val, ty) -instantiateConstraint :: MonadState CheckState m => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn) +instantiateConstraint :: MonadState CheckState TypeCheckM => Expr -> Type SourceAnn -> TypeCheckM (Expr, Type SourceAnn) instantiateConstraint val (ConstrainedType _ con ty) = do dicts <- getTypeClassDictionaries hints <- getHints @@ -354,23 +355,21 @@ instantiateConstraint val (ConstrainedType _ con ty) = do instantiateConstraint val ty = pure (val, ty) -- | Match against TUnknown and call insertUnkName, failing otherwise. -insertUnkName' :: (MonadState CheckState m, MonadError MultipleErrors m) => SourceType -> Text -> m () +insertUnkName' :: (MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM) => SourceType -> Text -> TypeCheckM () insertUnkName' (TUnknown _ i) n = insertUnkName i n insertUnkName' _ _ = internalCompilerError "type is not TUnknown" -- | Infer a type for a value, rethrowing any error to provide a more useful error message infer - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Expr - -> m TypedValue' + -> TypeCheckM TypedValue' infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val -- | Infer a type for a value infer' - :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Expr - -> m TypedValue' + :: Expr + -> TypeCheckM TypedValue' infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue' True v tyInt infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue' True v tyNumber infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue' True v tyString @@ -537,25 +536,25 @@ infer' v = internalError $ "Invalid argument to infer: " ++ show v -- | -- Infer the types of named record fields. inferProperties - :: ( MonadSupply m - , MonadState CheckState m - , MonadError MultipleErrors m - , MonadWriter MultipleErrors m + :: ( MonadSupply TypeCheckM + , MonadState CheckState TypeCheckM + , MonadError MultipleErrors TypeCheckM + , MonadWriter MultipleErrors TypeCheckM ) => [(PSString, Expr)] - -> m [(PSString, (Expr, SourceType))] + -> TypeCheckM [(PSString, (Expr, SourceType))] inferProperties = traverse (traverse inferWithinRecord) -- | -- Infer the type of a value when used as a record field. inferWithinRecord - :: ( MonadSupply m - , MonadState CheckState m - , MonadError MultipleErrors m - , MonadWriter MultipleErrors m + :: ( MonadSupply TypeCheckM + , MonadState CheckState TypeCheckM + , MonadError MultipleErrors TypeCheckM + , MonadWriter MultipleErrors TypeCheckM ) => Expr - -> m (Expr, SourceType) + -> TypeCheckM (Expr, SourceType) inferWithinRecord e = do TypedValue' _ v t <- infer e if propertyShouldInstantiate e @@ -574,12 +573,12 @@ propertyShouldInstantiate = \case _ -> False inferLetBinding - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => [Declaration] -> [Declaration] -> Expr - -> (Expr -> m TypedValue') - -> m ([Declaration], TypedValue') + -> (Expr -> TypeCheckM TypedValue') + -> TypeCheckM ([Declaration], TypedValue') inferLetBinding seen [] ret j = (seen, ) <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do moduleName <- unsafeCheckCurrentModule @@ -614,11 +613,9 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | Infer the types of variables brought into scope by a binder inferBinder - :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => SourceType + :: SourceType -> Binder - -> m (M.Map Ident (SourceSpan, SourceType)) + -> TypeCheckM (M.Map Ident (SourceSpan, SourceType)) inferBinder _ NullBinder = return M.empty inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty @@ -652,7 +649,7 @@ inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do unifyTypes val (srcTypeApp tyRecord row) return m1 where - inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> m (M.Map Ident (SourceSpan, SourceType)) + inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> TypeCheckM (M.Map Ident (SourceSpan, SourceType)) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do propTy <- freshTypeWithKind kindType @@ -695,10 +692,10 @@ binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => [Expr] -> [CaseAlternative] - -> m ([Expr], [SourceType]) + -> TypeCheckM ([Expr], [SourceType]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue' _ val' ty <- infer val if inst @@ -712,11 +709,11 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- Check the types of the return values in a set of binders in a case statement -- checkBinders - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => [SourceType] -> SourceType -> [CaseAlternative] - -> m [CaseAlternative] + -> TypeCheckM [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ @@ -728,10 +725,10 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do return $ r : rs checkGuardedRhs - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => GuardedExpr -> SourceType - -> m GuardedExpr + -> TypeCheckM GuardedExpr checkGuardedRhs (GuardedExpr [] rhs) ret = do rhs' <- TypedValue True <$> (tvToExpr <$> check rhs ret) <*> pure ret return $ GuardedExpr [] rhs' @@ -752,21 +749,19 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do -- Check the type of a value, rethrowing errors to provide a better error message -- check - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Expr -> SourceType - -> m TypedValue' + -> TypeCheckM TypedValue' check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ check' val ty -- | -- Check the type of a value -- check' - :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Expr + :: Expr -> SourceType - -> m TypedValue' + -> TypeCheckM TypedValue' check' val (ForAll ann vis ident mbK ty _) = do env <- getEnv mn <- gets checkCurrentModule @@ -918,12 +913,12 @@ check' val ty = do -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- checkProperties - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Expr -> [(PSString, Expr)] -> SourceType -> Bool - -> m [(PSString, Expr)] + -> TypeCheckM [(PSString, Expr)] checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where convert = fmap (fmap tvToExpr) (ts', r') = rowToList row @@ -965,14 +960,14 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where -- * The elaborated expression for the function application (since we might need to -- insert type class dictionaries, etc.) checkFunctionApplication - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Expr -- ^ The function expression -> SourceType -- ^ The type of the function -> Expr -- ^ The argument expression - -> m (SourceType, Expr) + -> TypeCheckM (SourceType, Expr) -- ^ The result type, and the elaborated term checkFunctionApplication fn fnTy arg = withErrorMessageHint' fn (ErrorInApplication fn fnTy arg) $ do subst <- gets checkSubstitution @@ -980,11 +975,11 @@ checkFunctionApplication fn fnTy arg = withErrorMessageHint' fn (ErrorInApplicat -- | Check the type of a function application checkFunctionApplication' - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply TypeCheckM, MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM, MonadWriter MultipleErrors TypeCheckM) => Expr -> SourceType -> Expr - -> m (SourceType, Expr) + -> TypeCheckM (SourceType, Expr) checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do unifyTypes tyFunction' tyFunction arg' <- tvToExpr <$> check arg argTy @@ -1014,7 +1009,7 @@ checkFunctionApplication' fn u arg = do -- | -- Ensure a set of property names and value does not contain duplicate labels -- -ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m () +ensureNoDuplicateProperties :: (MonadError MultipleErrors TypeCheckM) => [(PSString, Expr)] -> TypeCheckM () ensureNoDuplicateProperties ps = let ls = map fst ps in case ls \\ ordNub ls of @@ -1032,9 +1027,9 @@ isInternal = \case -- | Introduce a hint only if the given expression is not internal withErrorMessageHint' - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState TypeCheckM, MonadError MultipleErrors TypeCheckM) => Expr -> ErrorMessageHint - -> m a - -> m a + -> TypeCheckM a + -> TypeCheckM a withErrorMessageHint' expr = if isInternal expr then const id else withErrorMessageHint diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e4f1040ebf..06723b74c4 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -28,14 +28,14 @@ import Data.Text qualified as T import Language.PureScript.Crash (internalError) import Language.PureScript.Environment qualified as E -import Language.PureScript.Errors (ErrorMessageHint(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, internalCompilerError, onErrorMessages, rethrow, warnWithPosition, withoutPosition) +import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), SourceAnn, errorMessage, internalCompilerError, onErrorMessages, rethrow, warnWithPosition, withoutPosition) import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint) +import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. -freshType :: (MonadState CheckState m) => m SourceType +freshType :: TypeCheckM SourceType freshType = state $ \st -> do let t = checkNextType st @@ -50,7 +50,7 @@ freshType = state $ \st -> do (srcTUnknown (t + 1), st') -- | Generate a fresh type variable with a known kind. -freshTypeWithKind :: (MonadState CheckState m) => SourceType -> m SourceType +freshTypeWithKind :: SourceType -> TypeCheckM SourceType freshTypeWithKind kind = state $ \st -> do let t = checkNextType st @@ -61,7 +61,7 @@ freshTypeWithKind kind = state $ \st -> do (srcTUnknown t, st') -- | Update the substitution to solve a type constraint -solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m () +solveType :: Int -> SourceType -> TypeCheckM () solveType u t = rethrow (onErrorMessages withoutPosition) $ do -- We strip the position so that any errors get rethrown with the position of -- the original unification constraint. Otherwise errors may arise from arbitrary @@ -90,7 +90,7 @@ substituteType sub = everywhereOnTypes go go other = other -- | Make sure that an unknown does not occur in a type -occursCheck :: (MonadError MultipleErrors m) => Int -> SourceType -> m () +occursCheck :: Int -> SourceType -> TypeCheckM () occursCheck _ TUnknown{} = return () occursCheck u t = void $ everywhereOnTypesM go t where @@ -106,7 +106,7 @@ unknownsInType t = everythingOnTypes (.) go t [] go _ = id -- | Unify two types, updating the current substitution -unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () +unifyTypes :: SourceType -> SourceType -> TypeCheckM () unifyTypes t1 t2 = do sub <- gets checkSubstitution withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) @@ -160,13 +160,13 @@ unifyTypes t1 t2 = do -- -- Common labels are identified and unified. Remaining labels and types are unified with a -- trailing row unification variable, if appropriate. -unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () +unifyRows :: SourceType -> SourceType -> TypeCheckM () unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2 (matches, rest) = alignRowsWith unifyTypesWithLabel r1 r2 - unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> m () + unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> TypeCheckM () unifyTails ([], TUnknown _ u) (sd, r) = solveType u (rowFromList (sd, r)) unifyTails (sd, r) ([], TUnknown _ u) = solveType u (rowFromList (sd, r)) unifyTails ([], REmptyKinded _ _) ([], REmptyKinded _ _) = return () @@ -184,7 +184,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where -- | -- Replace type wildcards with unknowns -- -replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType +replaceTypeWildcards :: SourceType -> TypeCheckM SourceType replaceTypeWildcards = everywhereOnTypesM replace where replace (TypeWildcard ann wdata) = do @@ -201,22 +201,22 @@ replaceTypeWildcards = everywhereOnTypesM replace -- | -- Replace outermost unsolved unification variables with named type variables -- -varIfUnknown :: forall m. (MonadState CheckState m) => [(Unknown, SourceType)] -> SourceType -> m SourceType +varIfUnknown :: [(Unknown, SourceType)] -> SourceType -> TypeCheckM SourceType varIfUnknown unks ty = do bn' <- traverse toBinding unks ty' <- go ty pure $ mkForAll bn' ty' where - toName :: Unknown -> m T.Text + toName :: Unknown -> TypeCheckM T.Text toName u = (<> T.pack (show u)) . fromMaybe "t" <$> lookupUnkName u - toBinding :: (Unknown, SourceType) -> m (SourceAnn, (T.Text, Maybe SourceType)) + toBinding :: (Unknown, SourceType) -> TypeCheckM (SourceAnn, (T.Text, Maybe SourceType)) toBinding (u, k) = do u' <- toName u k' <- go k pure (getAnnForType ty, (u', Just k')) - go :: SourceType -> m SourceType + go :: SourceType -> TypeCheckM SourceType go = everywhereOnTypesM $ \case (TUnknown ann u) -> TypeVar ann <$> toName u From 3033a4fa262a334fcbb98a7db25db62fce6ddd1c Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Thu, 8 May 2025 21:33:40 +0000 Subject: [PATCH 092/105] IntMap Lazy --- src/Language/PureScript/Errors.hs | 6 +++--- src/Language/PureScript/TypeChecker.hs | 7 ++++--- src/Language/PureScript/TypeChecker/Kinds.hs | 9 +++++---- src/Language/PureScript/TypeChecker/Monad.hs | 21 ++++++++++---------- src/Language/PureScript/TypeChecker/Unify.hs | 14 ++++++------- 5 files changed, 30 insertions(+), 27 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..309a4e9ba9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -28,7 +28,7 @@ import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons) import Data.List.NonEmpty qualified as NEL import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe) -import Data.Map qualified as M +import Data.IntMap.Strict qualified as M import Data.Ord (Down(..)) import Data.Set qualified as S import Data.Text qualified as T @@ -418,9 +418,9 @@ addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hi -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap - { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + { umSkolemMap :: M.IntMap (String, Int, Maybe SourceSpan) -- ^ a map from skolems to their new names, including source and naming info - , umUnknownMap :: M.Map Int Int + , umUnknownMap :: M.IntMap Int -- ^ a map from unification variables to their new names , umNextIndex :: Int -- ^ unknowns and skolems share a source of names during renaming, to diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 7277f7b156..fd4e7c7982 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -23,6 +23,7 @@ import Data.Either (partitionEithers) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Set qualified as S import Data.Text qualified as T @@ -443,11 +444,11 @@ typeCheckAll moduleName = traverse go typeModule (KindedType _ t1 _) = typeModule t1 typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" - modulesByTypeIndex :: M.Map Int (Maybe ModuleName) - modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) + modulesByTypeIndex :: IM.IntMap (Maybe ModuleName) + modulesByTypeIndex = IM.fromList (zip [0 ..] (typeModule <$> tys')) lookupModule :: Int -> S.Set ModuleName - lookupModule idx = case M.lookup idx modulesByTypeIndex of + lookupModule idx = case IM.lookup idx modulesByTypeIndex of Just ms -> S.fromList (toList ms) Nothing -> internalError "Unknown type index in findNonOrphanModules" diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 629ad68773..20076c39bb 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -42,6 +42,7 @@ import Data.Functor (($>)) import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -93,7 +94,7 @@ apply ty = flip substituteType ty <$> gets checkSubstitution substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes $ \case TUnknown ann u -> - case M.lookup u (substType sub) of + case IM.lookup u (substType sub) of Nothing -> TUnknown ann u Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 Just t -> substituteType sub t @@ -122,14 +123,14 @@ addUnsolved lvl unk kind = modify $ \st -> do Nothing -> pure unk Just (UnkLevel lvl') -> lvl' <> pure unk subs = checkSubstitution st - uns = M.insert unk (newLvl, kind) $ substUnsolved subs + uns = IM.insert unk (newLvl, kind) $ substUnsolved subs st { checkSubstitution = subs { substUnsolved = uns } } solve :: Unknown -> SourceType -> TypeCheckM () solve unk solution = modify $ \st -> do let subs = checkSubstitution st - tys = M.insert unk solution $ substType subs + tys = IM.insert unk solution $ substType subs st { checkSubstitution = subs { substType = tys } } lookupUnsolved @@ -138,7 +139,7 @@ lookupUnsolved -> TypeCheckM (UnkLevel, SourceType) lookupUnsolved u = do uns <- gets (substUnsolved . checkSubstitution) - case M.lookup u uns of + case IM.lookup u uns of Nothing -> internalCompilerError $ "Unsolved unification variable ?" <> T.pack (show u) <> " is not bound" Just res -> return res diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index aa6b61abc1..0f7d2b1f5d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -14,6 +14,7 @@ import Control.Monad (forM_, guard, join, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe (fromMaybe) +import Data.IntMap.Lazy qualified as IM import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text, isPrefixOf, unpack) @@ -71,11 +72,11 @@ instance Ord UnkLevel where -- | A substitution of unification variables for types. data Substitution = Substitution - { substType :: M.Map Int SourceType + { substType :: IM.IntMap SourceType -- ^ Type substitution - , substUnsolved :: M.Map Int (UnkLevel, SourceType) + , substUnsolved :: IM.IntMap (UnkLevel, SourceType) -- ^ Unsolved unification variables with their level (scope ordering) and kind - , substNames :: M.Map Int Text + , substNames :: IM.IntMap Text -- ^ The original names of unknowns } @@ -84,17 +85,17 @@ insertUnkName u t = do modify (\s -> s { checkSubstitution = (checkSubstitution s) { substNames = - M.insert u t $ substNames $ checkSubstitution s + IM.insert u t $ substNames $ checkSubstitution s } } ) lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text) -lookupUnkName u = gets $ M.lookup u . substNames . checkSubstitution +lookupUnkName u = gets $ IM.lookup u . substNames . checkSubstitution -- | An empty substitution emptySubstitution :: Substitution -emptySubstitution = Substitution M.empty M.empty M.empty +emptySubstitution = Substitution IM.empty IM.empty IM.empty -- | State required for type checking data CheckState = CheckState @@ -474,13 +475,13 @@ debugValue = init . render . prettyPrintValue 100 debugSubstitution :: Substitution -> [String] debugSubstitution (Substitution solved unsolved names) = concat - [ fmap go1 (M.toList solved) - , fmap go2 (M.toList unsolved') - , fmap go3 (M.toList names) + [ fmap go1 (IM.toList solved) + , fmap go2 (IM.toList unsolved') + , fmap go3 (IM.toList names) ] where unsolved' = - M.filterWithKey (\k _ -> M.notMember k solved) unsolved + IM.filterWithKey (\k _ -> IM.notMember k solved) unsolved go1 (u, ty) = "?" <> show u <> " = " <> debugType ty diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 06723b74c4..3110429184 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -23,7 +23,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) -import Data.Map qualified as M +import Data.IntMap.Lazy qualified as IM import Data.Text qualified as T import Language.PureScript.Crash (internalError) @@ -41,8 +41,8 @@ freshType = state $ \st -> do t = checkNextType st st' = st { checkNextType = t + 2 , checkSubstitution = - (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), E.kindType) - . M.insert (t + 1) (UnkLevel (pure (t + 1)), srcTUnknown t) + (checkSubstitution st) { substUnsolved = IM.insert t (UnkLevel (pure t), E.kindType) + . IM.insert (t + 1) (UnkLevel (pure (t + 1)), srcTUnknown t) . substUnsolved $ checkSubstitution st } @@ -56,7 +56,7 @@ freshTypeWithKind kind = state $ \st -> do t = checkNextType st st' = st { checkNextType = t + 1 , checkSubstitution = - (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), kind) (substUnsolved (checkSubstitution st)) } + (checkSubstitution st) { substUnsolved = IM.insert t (UnkLevel (pure t), kind) (substUnsolved (checkSubstitution st)) } } (srcTUnknown t, st') @@ -70,11 +70,11 @@ solveType u t = rethrow (onErrorMessages withoutPosition) $ do occursCheck u t k1 <- elaborateKind t subst <- gets checkSubstitution - k2 <- maybe (internalCompilerError ("No kind for unification variable ?" <> T.pack (show u))) (pure . substituteType subst . snd) . M.lookup u . substUnsolved $ subst + k2 <- maybe (internalCompilerError ("No kind for unification variable ?" <> T.pack (show u))) (pure . substituteType subst . snd) . IM.lookup u . substUnsolved $ subst t' <- instantiateKind (t, k1) k2 modify $ \cs -> cs { checkSubstitution = (checkSubstitution cs) { substType = - M.insert u t' $ substType $ checkSubstitution cs + IM.insert u t' $ substType $ checkSubstitution cs } } @@ -83,7 +83,7 @@ substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes go where go (TUnknown ann u) = - case M.lookup u (substType sub) of + case IM.lookup u (substType sub) of Nothing -> TUnknown ann u Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 Just t -> substituteType sub t From 22d8db6399fe4fabb9236f963a8a3e6f22ce4c56 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Fri, 9 May 2025 09:26:51 +0000 Subject: [PATCH 093/105] Fix after merging --- src/Control/Monad/Supply.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index a175ff4e22..1aa6c3df89 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -20,7 +20,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans (lift) newtype SupplyT m a = SupplyT { unSupplyT :: StateT Int64 m a } - deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) + deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus, MonadIO) runSupplyT :: Int64 -> SupplyT m a -> m (a, Int64) runSupplyT n = flip runStateT n . unSupplyT diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 0f7d2b1f5d..429b950606 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -10,6 +10,7 @@ import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), StateT(..), gets, modify, MonadIO (liftIO)) +import Control.Monad.State.Strict qualified as StrictState import Control.Monad (forM_, guard, join, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) @@ -35,7 +36,7 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Logger (Logger, runLogger') import Control.Monad.Supply.Class qualified as Supply -newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (Logger MultipleErrors))) a } +newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors Logger)) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) -- | Lift a TypeCheckM computation into another monad that satisfies all its constraints @@ -45,7 +46,7 @@ liftTypeCheckM :: liftTypeCheckM (TypeCheckM m) = do st <- get freshId <- Supply.peek - (result, errors) <- liftIO $ runLogger' $ runExceptT $ flip runStateT freshId $ unSupplyT $ runStateT m st + (result, errors) <- liftIO $ runLogger' $ runExceptT $ flip StrictState.runStateT freshId $ unSupplyT $ runStateT m st tell errors case result of Left err -> From c2f1e65a5a718f9db392aa4c4adbc185e4c44352 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Fri, 9 May 2025 12:14:41 +0000 Subject: [PATCH 094/105] Memoize unifyTypes --- src/Language/PureScript/TypeChecker/Monad.hs | 3 ++- src/Language/PureScript/TypeChecker/Unify.hs | 9 +++++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 2b0df8b294..6d60feffbc 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -106,11 +106,12 @@ data CheckState = CheckState , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. + , unificationCache :: S.Set (SourceType, SourceType) } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty +emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty mempty -- | Unification variables type Unknown = Int diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index a87a656871..d90dcb1f85 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -16,7 +16,7 @@ module Language.PureScript.TypeChecker.Unify import Prelude -import Control.Monad (forM_, void) +import Control.Monad (forM_, void, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify, state) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -33,6 +33,7 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) +import Data.Set qualified as S -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: (MonadState CheckState m) => m SourceType @@ -109,8 +110,12 @@ unknownsInType t = everythingOnTypes (.) go t [] unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution - withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) + withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes'' (substituteType sub t1) (substituteType sub t2) where + unifyTypes'' t1' t2'= do + cache <- gets unificationCache + when (S.notMember (t1', t2') cache) $ + unifyTypes' t1' t2' unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t unifyTypes' t (TUnknown _ u) = solveType u t From a1c4313a1b766cb9ba6f3d1afb1bc5d164f0811e Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Fri, 9 May 2025 12:27:34 +0000 Subject: [PATCH 095/105] Memoize unify types really this time --- src/Language/PureScript/TypeChecker/Unify.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index d90dcb1f85..5c49fcb3a1 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -114,7 +114,8 @@ unifyTypes t1 t2 = do where unifyTypes'' t1' t2'= do cache <- gets unificationCache - when (S.notMember (t1', t2') cache) $ + when (S.notMember (t1', t2') cache) $ do + modify $ \st -> st { unificationCache = S.insert (t1', t2') cache } unifyTypes' t1' t2' unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t From f8a583883c66b67ab24f754868411c0787004122 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 12 May 2025 07:20:32 +0000 Subject: [PATCH 096/105] {-# INLINE #-} annoations on traversals --- src/Language/PureScript/Types.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ef00e21a07..063c1ebc32 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -716,6 +716,7 @@ everywhereOnTypesM f = go where go (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go t1 <*> go t2 <*> go t3) >>= f go (ParensInType ann t) = (ParensInType ann <$> go t) >>= f go other = f other +{-# INLINE everywhereOnTypesM #-} everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where @@ -729,6 +730,7 @@ everywhereOnTypesTopDownM f = go <=< f where go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) go (ParensInType ann t) = ParensInType ann <$> (f t >>= go) go other = pure other +{-# INLINE everywhereOnTypesTopDownM #-} everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where @@ -743,6 +745,7 @@ everythingOnTypes (<+>) f = go where go t@(BinaryNoParensType _ t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 go t@(ParensInType _ t1) = f t <+> go t1 go other = f other +{-# INLINE everythingOnTypes #-} everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type a -> (s, r)) -> Type a -> r everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where @@ -758,6 +761,7 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (BinaryNoParensType _ t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 go s (ParensInType _ t1) = go' s t1 go _ _ = r0 +{-# INLINE everythingWithContextOnTypes #-} annForType :: Lens' (Type a) a annForType k (TUnknown a b) = (\z -> TUnknown z b) <$> k a From 98b1ff0f2791e413c429dd61025b8424ac0966e5 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 12 May 2025 07:42:45 +0000 Subject: [PATCH 097/105] Replace Logger with Writer --- src/Language/PureScript/Interactive.hs | 7 +++--- src/Language/PureScript/TypeChecker/Monad.hs | 15 ++++++------ .../PureScript/TypeChecker/TypeSearch.hs | 24 +++++++------------ 3 files changed, 20 insertions(+), 26 deletions(-) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 3c0ae0ed21..8248b6796a 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -44,6 +44,7 @@ import Language.PureScript.Interactive.Types as Interactive import System.Directory (getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob (glob) +import Language.PureScript.TypeChecker.Monad (liftTypeCheckM) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -296,10 +297,10 @@ handleKindOf print' typ = do case M.lookup (P.Qualified (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } - k = undefined -- TODO: check (snd <$> P.kindOf typ') chk + k = check (snd <$> liftTypeCheckM (P.kindOf typ')) chk - check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) - check sew = fst . runWriter . runExceptT . runStateT sew + check :: P.SupplyT (StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors))) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew = fst . runWriter . runExceptT . runStateT (P.evalSupplyT 0 sew) case k of Left err -> printErrors err Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 831c629d9b..c2f8f0c90f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -9,10 +9,8 @@ import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState(..), StateT(..), gets, modify, MonadIO (liftIO)) +import Control.Monad.State (MonadState(..), StateT(..), gets, modify) import Control.Monad.State.Strict qualified as StrictState -import Control.Monad (forM_, guard, join, when, (<=<)) -import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe (fromMaybe) import Data.IntMap.Lazy qualified as IM @@ -33,20 +31,21 @@ import Text.PrettyPrint.Boxes (render) import Control.Monad.Supply (SupplyT (unSupplyT)) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.Logger (Logger, runLogger') +import Control.Monad.Writer.Strict as SW import Control.Monad.Supply.Class qualified as Supply +import Control.Monad.Identity (Identity(runIdentity)) -newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors Logger)) a } +newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (SW.Writer MultipleErrors))) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) -- | Lift a TypeCheckM computation into another monad that satisfies all its constraints liftTypeCheckM :: - (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadIO m) => + (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => TypeCheckM a -> m a liftTypeCheckM (TypeCheckM m) = do st <- get freshId <- Supply.peek - (result, errors) <- liftIO $ runLogger' $ runExceptT $ flip StrictState.runStateT freshId $ unSupplyT $ runStateT m st + let (result, errors) = runIdentity $ SW.runWriterT $ runExceptT $ flip StrictState.runStateT freshId $ unSupplyT $ runStateT m st tell errors case result of Left err -> @@ -344,7 +343,7 @@ modifyEnv :: (Environment -> Environment) -> TypeCheckM () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. -runCheck :: CheckState -> StateT CheckState TypeCheckM a -> TypeCheckM (a, Environment) +runCheck :: Functor m => CheckState -> StateT CheckState m a -> m (a, Environment) runCheck st check = second checkEnv <$> runStateT check st -- | Make an assertion, failing with an error message diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index e8812a5439..580befa288 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -20,27 +20,21 @@ import Language.PureScript.Pretty.Types as P import Language.PureScript.TypeChecker.Skolems as Skolem import Language.PureScript.TypeChecker.Synonyms as P import Language.PureScript.Types as P +import Control.Monad.Supply qualified as P +import Language.PureScript.TypeChecker.Monad qualified as P checkInEnvironment :: Environment -> TC.CheckState -> TC.TypeCheckM a -> Maybe (a, Environment) -checkInEnvironment _ _ _ = Nothing --- TODO: bring this back --- Currently not possible since TypeCheckM contains IO --- --- checkInEnvironment --- :: Environment --- -> TC.CheckState --- -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a --- -> Maybe (a, Environment) --- checkInEnvironment env st = --- either (const Nothing) Just --- . runExcept --- . evalWriterT --- . P.evalSupplyT 0 --- . TC.runCheck (st { TC.checkEnv = env }) +checkInEnvironment env st = + either (const Nothing) Just + . runExcept + . evalWriterT + . P.evalSupplyT 0 + . TC.runCheck (st { TC.checkEnv = env }) + . P.liftTypeCheckM evalWriterT :: Monad m => WriterT b m r -> m r evalWriterT m = fmap fst (runWriterT m) From a9eb340e10102fa476301ecc7bdded008021ec85 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 12 May 2025 08:04:54 +0000 Subject: [PATCH 098/105] Writer CPS --- src/Language/PureScript/TypeChecker/Monad.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c2f8f0c90f..10afcad82c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Monads for type checking and type inference and associated data types @@ -31,9 +32,16 @@ import Text.PrettyPrint.Boxes (render) import Control.Monad.Supply (SupplyT (unSupplyT)) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.Writer.Strict as SW +import Control.Monad.Trans.Writer.CPS qualified as SW +import Control.Monad.Writer (MonadWriter(..), censor) import Control.Monad.Supply.Class qualified as Supply import Control.Monad.Identity (Identity(runIdentity)) +import Control.Monad (forM_, when, join, (<=<), guard) + +instance (Monad m, Monoid w) => MonadWriter w (SW.WriterT w m) where + tell = SW.tell + listen = SW.listen + pass = SW.pass newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (SW.Writer MultipleErrors))) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) From 35218a6927508da1b60a5a8f2c36d4edc29d685d Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Fri, 9 May 2025 13:09:15 +0200 Subject: [PATCH 099/105] add monoid import --- src/Language/PureScript/Sugar/Accessor.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 02c3d6c991..1aaa010717 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -7,6 +7,7 @@ import Prelude import Control.Monad.Writer +import Data.Monoid (Any(..)) import Language.PureScript.AST import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.Externs From 523bd5f95447ea214229f4038cb1975ecd6238fa Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 12 May 2025 09:01:06 +0000 Subject: [PATCH 100/105] Remove duplicate instance --- src/Language/PureScript/TypeChecker/Monad.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index bb9945b75a..84e0ed1e7b 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE TypeOperators #-} -- | @@ -39,11 +38,6 @@ import Control.Monad.Supply.Class qualified as Supply import Control.Monad.Identity (Identity(runIdentity)) import Control.Monad (forM_, when, join, (<=<), guard) -instance (Monad m, Monoid w) => MonadWriter w (SW.WriterT w m) where - tell = SW.tell - listen = SW.listen - pass = SW.pass - newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (SW.Writer MultipleErrors))) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) From 75126e42aca4ed62fcaed2a935a380bbad291099 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 12 May 2025 09:02:09 +0000 Subject: [PATCH 101/105] Remove redundant constraint --- src/Language/PureScript/Make.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a8f22ee0f4..8da8a90d73 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -78,7 +78,7 @@ import Language.PureScript.TypeChecker.Monad (liftTypeCheckM) -- rebuildModule :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -89,7 +89,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -99,7 +99,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] From c7c6e0f1ac720b94fe8337abd5dbefbd027a484e Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 13 May 2025 06:05:40 +0000 Subject: [PATCH 102/105] Fix hlint warnings --- src/Language/PureScript/TypeChecker/Kinds.hs | 42 +++++++++---------- src/Language/PureScript/TypeChecker/Monad.hs | 1 - .../PureScript/TypeChecker/Synonyms.hs | 1 - 3 files changed, 21 insertions(+), 23 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 20076c39bb..bc1d8f329d 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -134,7 +134,7 @@ solve unk solution = modify $ \st -> do st { checkSubstitution = subs { substType = tys } } lookupUnsolved - :: (HasCallStack) + :: HasCallStack => Unknown -> TypeCheckM (UnkLevel, SourceType) lookupUnsolved u = do @@ -144,7 +144,7 @@ lookupUnsolved u = do Just res -> return res unknownsWithKinds - :: (HasCallStack) + :: HasCallStack => [Unknown] -> TypeCheckM [(Unknown, SourceType)] unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go @@ -155,7 +155,7 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) pure $ (lvl, (u, ty)) : rest inferKind - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM (SourceType, SourceType) inferKind = \tyToInfer -> @@ -243,7 +243,7 @@ inferKind = \tyToInfer -> internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty inferAppKind - :: (HasCallStack) + :: HasCallStack => SourceAnn -> (SourceType, SourceType) -> SourceType @@ -276,7 +276,7 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of _ -> pure True cannotApplyTypeToType - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM a @@ -286,7 +286,7 @@ cannotApplyTypeToType fn arg = do internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg) cannotApplyKindToType - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM a @@ -297,7 +297,7 @@ cannotApplyKindToType poly arg = do internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg) checkKind - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM SourceType @@ -311,13 +311,13 @@ checkKind = checkKind' False -- error. -- checkIsSaturatedType - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM SourceType checkIsSaturatedType ty = checkKind' True ty E.kindType checkKind' - :: (HasCallStack) + :: HasCallStack => Bool -> SourceType -> SourceType @@ -332,7 +332,7 @@ checkKind' requireSynonymsToExpand ty kind2 = do instantiateKind (ty', kind1') kind2' instantiateKind - :: (HasCallStack) + :: HasCallStack => (SourceType, SourceType) -> SourceType -> TypeCheckM SourceType @@ -350,7 +350,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of _ -> False subsumesKind - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM () @@ -393,7 +393,7 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 -> -- | local position context. This is useful when invoking kind unification -- | outside of kind checker internals. unifyKinds' - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM () @@ -404,7 +404,7 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 -> -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind - :: (HasCallStack) + :: HasCallStack => SourceType -> SourceType -> TypeCheckM () @@ -412,7 +412,7 @@ checkTypeKind ty kind = unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType unifyKindsWithFailure - :: (HasCallStack) + :: HasCallStack => (SourceType -> SourceType -> TypeCheckM ()) -> SourceType -> SourceType @@ -464,7 +464,7 @@ unifyKindsWithFailure onFailure = go onFailure (rowFromList w1) (rowFromList w2) solveUnknown - :: (HasCallStack) + :: HasCallStack => Unknown -> SourceType -> TypeCheckM () @@ -475,7 +475,7 @@ solveUnknown a' p1 = do solve a' p2 solveUnknownAsFunction - :: (HasCallStack) + :: HasCallStack => SourceAnn -> Unknown -> TypeCheckM SourceType @@ -490,7 +490,7 @@ solveUnknownAsFunction ann u = do pure uarr promoteKind - :: (HasCallStack) + :: HasCallStack => Unknown -> SourceType -> TypeCheckM SourceType @@ -512,7 +512,7 @@ promoteKind u2 ty = do pure ty' elaborateKind - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM SourceType elaborateKind = \case @@ -588,7 +588,7 @@ checkEscapedSkolems ty = errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty' kindOfWithUnknowns - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM (([(Unknown, SourceType)], SourceType), SourceType) kindOfWithUnknowns ty = do @@ -598,14 +598,14 @@ kindOfWithUnknowns ty = do -- | Infer the kind of a single type kindOf - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM (SourceType, SourceType) kindOf = fmap (first snd) . kindOfWithScopedVars -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars - :: (HasCallStack) + :: HasCallStack => SourceType -> TypeCheckM (([(Text, SourceType)], SourceType), SourceType) kindOfWithScopedVars ty = do diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 84e0ed1e7b..dbcd78087c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -- | -- Monads for type checking and type inference and associated data types diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 684207bf52..9672836d6a 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -- | -- Functions for replacing fully applied type synonyms From c4923852c4078cc52a3302f694f03987974fb9f1 Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Tue, 13 May 2025 07:39:01 +0000 Subject: [PATCH 103/105] Bring back original Logger --- src/Control/Monad/Logger.hs | 73 +++++++++------------------ src/Language/PureScript/Make/Monad.hs | 2 +- 2 files changed, 26 insertions(+), 49 deletions(-) diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 4c0d96be2b..a3ed57b0da 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -12,68 +12,45 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) -import Language.PureScript.Errors (MultipleErrors (MultipleErrors)) --- | Logger monad, using IORef for mutable log accumulation. -data Logger a - = LoggerPure a - | LoggerIO (IORef MultipleErrors -> IO a) - --- | Run a Logger computation given an existing IORef. -runLogger :: Logger a -> IORef MultipleErrors -> IO a -runLogger (LoggerPure a) _ = return a -runLogger (LoggerIO f) r = f r +-- | A replacement for WriterT IO which uses mutable references. +newtype Logger w a = Logger { runLogger :: IORef w -> IO a } -- | Run a Logger computation, starting with an empty log. -runLogger' :: Logger a -> IO (a, MultipleErrors) +runLogger' :: (Monoid w) => Logger w a -> IO (a, w) runLogger' l = do - ref <- newIORef mempty - a <- runLogger l ref - (MultipleErrors list) <- readIORef ref - return (a, MultipleErrors $ reverse list) + r <- newIORef mempty + a <- runLogger l r + w <- readIORef r + return (a, w) --- Functor -instance Functor Logger where - fmap f (LoggerPure a) = LoggerPure (f a) - fmap f (LoggerIO m) = LoggerIO $ \r -> fmap f (m r) +instance Functor (Logger w) where + fmap f (Logger l) = Logger $ \r -> fmap f (l r) --- Applicative -instance Applicative Logger where - pure = LoggerPure +instance (Monoid w) => Applicative (Logger w) where + pure = Logger . const . pure (<*>) = ap --- Monad -instance Monad Logger where +instance (Monoid w) => Monad (Logger w) where return = pure - LoggerPure a >>= f = f a - LoggerIO m >>= f = LoggerIO $ \r -> do - a <- m r - runLogger (f a) r + Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r --- MonadIO -instance MonadIO Logger where - liftIO = LoggerIO . const +instance (Monoid w) => MonadIO (Logger w) where + liftIO = Logger . const --- MonadWriter -instance MonadWriter MultipleErrors Logger where - tell w = LoggerIO $ \r -> - atomicModifyIORef' r $ \(MultipleErrors acc) -> - let MultipleErrors new = w - in (MultipleErrors (new ++ acc), ()) - listen m = LoggerIO $ \r -> do - (a, w) <- runLogger' m +instance (Monoid w) => MonadWriter w (Logger w) where + tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ()) + listen l = Logger $ \r -> do + (a, w) <- liftIO (runLogger' l) atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w)) - pass m = LoggerIO $ \r -> do - ((a, f), w) <- runLogger' m + pass l = Logger $ \r -> do + ((a, f), w) <- liftIO (runLogger' l) atomicModifyIORef' r $ \w' -> (mappend w' (f w), a) --- MonadBase -instance MonadBase IO Logger where +instance (Monoid w) => MonadBase IO (Logger w) where liftBase = liftIO --- MonadBaseControl -instance MonadBaseControl IO Logger where - type StM Logger a = a - liftBaseWith f = LoggerIO $ \r -> liftBaseWith $ \runInBase -> - f (\m -> runInBase (runLogger m r)) +instance (Monoid w) => MonadBaseControl IO (Logger w) where + type StM (Logger w) a = a + liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r) restoreM = return diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 58a03d8973..ed553cf28f 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -54,7 +54,7 @@ import System.IO.UTF8 (readUTF8FileT) -- | A monad for running make actions newtype Make a = Make - { unMake :: ReaderT Options (ExceptT MultipleErrors Logger) a + { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) instance MonadBase IO Make where From 8f9bc92bb8d91a27c9276576d2eda2ca64fc9ade Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Mon, 26 May 2025 11:49:49 +0200 Subject: [PATCH 104/105] ExternsDiff: compute deps of TypeSynonyms properly (#7) Fixes a bug where type synonym changes are incorrectly computed when diffing externs. See https://github.com/zyla/purs-recompilation-repro for a reproducer of the bug. Bug explanation: Externs files can have multiple entries with the same Ref, but the code in ExternsDiff assumed uniqueness. This led to buggy dependency graph construction. The fix is to merge duplicate entries. --- src/Language/PureScript/Make/ExternsDiff.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 5877b2c722..21ef9ab38a 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -354,19 +354,21 @@ isEmpty (ExternsDiff _ refs) type Tuple4 m a = (m a, m a, m a, m a) -- | Returns refs as a tuple of four (added, removed, changed, unchanged). -splitRefs :: Ord r => Eq a => [a] -> [a] -> (a -> Maybe r) -> Tuple4 [] r +splitRefs :: forall ref a deps. Monoid deps => Ord ref => Eq a => [a] -> [a] -> (a -> Maybe (ref, deps)) -> Tuple4 [] (ref, deps) splitRefs new old toRef = M.foldrWithKey go (added, [], [], []) oldMap where - toMap = M.fromList . mapMaybe (((<$>) . flip (,)) <*> toRef) + toMap :: [a] -> Map ref (deps, [a]) + toMap = M.fromListWith (<>) . mapMaybe (\decl -> do (ref, deps) <- toRef decl; pure (ref, (deps, [decl]))) newMap = toMap new oldMap = toMap old - added = M.keys $ M.difference newMap oldMap - go ref decl (a, r, c, u) = case M.lookup ref newMap of - Nothing -> (a, r <> [ref], c, u) - Just newDecl - | decl /= newDecl -> (a, r, ref : c, u) - | otherwise -> (a, r, c, ref : u) + added = fmap (\(ref, (deps, _)) -> (ref, deps)) $ M.toList $ M.difference newMap oldMap + go :: ref -> (deps, [a]) -> Tuple4 [] (ref, deps) -> Tuple4 [] (ref, deps) + go ref (deps, decls) (a, r, c, u) = case M.lookup ref newMap of + Nothing -> (a, r <> [(ref, deps)], c, u) + Just (_, newDecls) + | decls /= newDecls -> (a, r, (ref, deps) : c, u) + | otherwise -> (a, r, c, (ref, deps) : u) -- | Traverses the type and finds all the refs within. typeDeps :: P.Type a -> S.Set (ModuleName, Ref) From 73ba6b89ac880476ca4ec9a6d6cb5fa284064142 Mon Sep 17 00:00:00 2001 From: seastian Date: Tue, 27 May 2025 18:33:43 +0200 Subject: [PATCH 105/105] improve --- profile-admin.txt | 32 ++++++++++++++++---------------- profile.txt | 32 ++++++++++++++++---------------- purescript.cabal | 6 +++--- 3 files changed, 35 insertions(+), 35 deletions(-) diff --git a/profile-admin.txt b/profile-admin.txt index e05582b977..814732e30f 100644 --- a/profile-admin.txt +++ b/profile-admin.txt @@ -1,27 +1,27 @@ 'purs' 'compile' '--source-globs-file' '.spago/sources.txt' +RTS '-N' '-A256m' '-n16m' '-sprofile.txt' - 764,684,334,200 bytes allocated in the heap - 66,592,890,256 bytes copied during GC - 5,965,029,568 bytes maximum residency (7 sample(s)) - 55,635,776 bytes maximum slop - 19931 MiB total memory in use (0 MB lost due to fragmentation) + 615,026,369,264 bytes allocated in the heap + 62,526,339,128 bytes copied during GC + 4,808,133,160 bytes maximum residency (7 sample(s)) + 30,469,184 bytes maximum slop + 16158 MiB total memory in use (0 MiB lost due to fragmentation) Tot time (elapsed) Avg pause Max pause - Gen 0 344 colls, 344 par 109.657s 24.231s 0.0704s 0.9072s - Gen 1 7 colls, 6 par 27.205s 6.308s 0.9011s 2.6484s + Gen 0 239 colls, 239 par 59.390s 7.687s 0.0322s 0.1657s + Gen 1 7 colls, 6 par 17.637s 4.178s 0.5969s 1.2704s - Parallel GC work balance: 87.29% (serial 0%, perfect 100%) + Parallel GC work balance: 91.91% (serial 0%, perfect 100%) - TASKS: 61 (1 bound, 60 peak workers (60 total), using -N10) + TASKS: 67 (1 bound, 65 peak workers (66 total), using -N10) SPARKS: 7516 (7516 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled) - INIT time 0.003s ( 0.153s elapsed) - MUT time 345.596s ( 91.867s elapsed) - GC time 136.862s ( 30.539s elapsed) - EXIT time 0.170s ( 0.001s elapsed) - Total time 482.631s (122.559s elapsed) + INIT time 0.151s ( 0.151s elapsed) + MUT time 304.986s ( 90.340s elapsed) + GC time 77.027s ( 11.865s elapsed) + EXIT time 0.249s ( 0.009s elapsed) + Total time 382.413s (102.365s elapsed) - Alloc rate 2,212,653,609 bytes per MUT second + Alloc rate 2,016,569,461 bytes per MUT second - Productivity 71.6% of total user, 75.0% of total elapsed + Productivity 79.8% of total user, 88.3% of total elapsed diff --git a/profile.txt b/profile.txt index bb86538d5f..d46e022a49 100644 --- a/profile.txt +++ b/profile.txt @@ -1,27 +1,27 @@ 'purs' 'compile' '--source-globs-file' '.spago/sources.txt' +RTS '-N' '-A256m' '-n16m' '-sprofile.txt' -1,514,656,409,184 bytes allocated in the heap - 98,339,524,248 bytes copied during GC - 3,076,113,760 bytes maximum residency (13 sample(s)) - 48,308,232 bytes maximum slop - 11349 MiB total memory in use (0 MB lost due to fragmentation) +1,239,641,572,944 bytes allocated in the heap + 92,117,540,648 bytes copied during GC + 2,525,848,440 bytes maximum residency (16 sample(s)) + 41,515,920 bytes maximum slop + 9680 MiB total memory in use (0 MiB lost due to fragmentation) Tot time (elapsed) Avg pause Max pause - Gen 0 697 colls, 697 par 202.812s 43.916s 0.0630s 0.6948s - Gen 1 13 colls, 12 par 32.681s 4.654s 0.3580s 0.5375s + Gen 0 462 colls, 462 par 98.367s 12.592s 0.0273s 0.1880s + Gen 1 16 colls, 15 par 26.135s 3.701s 0.2313s 0.3772s - Parallel GC work balance: 83.67% (serial 0%, perfect 100%) + Parallel GC work balance: 90.30% (serial 0%, perfect 100%) - TASKS: 69 (1 bound, 66 peak workers (68 total), using -N10) + TASKS: 70 (1 bound, 69 peak workers (69 total), using -N10) SPARKS: 7516 (7516 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled) - INIT time 0.003s ( 0.157s elapsed) - MUT time 702.424s (133.463s elapsed) - GC time 235.493s ( 48.571s elapsed) - EXIT time 0.067s ( 0.008s elapsed) - Total time 937.987s (182.199s elapsed) + INIT time 0.174s ( 0.173s elapsed) + MUT time 612.239s (126.344s elapsed) + GC time 124.502s ( 16.293s elapsed) + EXIT time 0.107s ( 0.009s elapsed) + Total time 737.021s (142.819s elapsed) - Alloc rate 2,156,328,748 bytes per MUT second + Alloc rate 2,024,767,533 bytes per MUT second - Productivity 74.9% of total user, 73.3% of total elapsed + Productivity 83.1% of total user, 88.5% of total elapsed diff --git a/purescript.cabal b/purescript.cabal index 950ba890ba..401775a5e2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -163,7 +163,7 @@ common defaults aeson-better-errors >=0.9.1.3 && <0.10, ansi-terminal >=0.11.3 && <1.1, array >=0.5.4.0 && <0.6, - intern ==0.9.4, + intern, base >=4.16.2.0 && <4.19, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, @@ -206,7 +206,7 @@ common defaults semigroups ==0.20.*, serialise >=0.2.5.0 && <0.3, sourcemap >=0.1.7 && <0.2, - sqlite-simple ==0.4.18.2, + sqlite-simple, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, template-haskell >=2.18.0.0 && <2.21, @@ -416,7 +416,7 @@ executable purs import: defaults hs-source-dirs: app main-is: Main.hs - ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages -eventlog + ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: prettyprinter >=1.6 && <1.8, prettyprinter-ansi-terminal >=1.1.1 && <1.2,