packages feed

purescript 0.15.13 → 0.15.14

raw patch · 18 files changed

+141/−80 lines, 18 files

Files

CONTRIBUTORS.md view
@@ -102,6 +102,7 @@ | [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license] | | [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license] | | [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license] |+| [@mjrussell](https://github.com/mjrussell) | Matthew Russell | [MIT license] | | [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license] | | [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license] | | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license] |
purescript.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               purescript-version:            0.15.13+version:            0.15.14 license:            BSD-3-Clause license-file:       LICENSE copyright:
src/Language/PureScript/AST/Binders.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} -- | -- Case binders --@@ -5,6 +6,8 @@  import Prelude +import Control.DeepSeq (NFData)+import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (SourceSpan) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)@@ -61,7 +64,7 @@   -- A binder with a type annotation   --   | TypedBinder SourceType Binder-  deriving (Show)+  deriving (Show, Generic, NFData)  -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
src/Language/PureScript/AST/Declarations.hs view
@@ -50,7 +50,7 @@     -- ^ Record fields that are available on the first argument to the typed     -- hole     }-  deriving Show+  deriving (Show, Generic, NFData)  onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)@@ -90,7 +90,7 @@   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))   | PositionedError (NEL.NonEmpty SourceSpan)   | RelatedPositions (NEL.NonEmpty SourceSpan)-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | Categories of hints data HintCategory@@ -105,14 +105,14 @@  -- | -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented--- an instance from being found, and whether VTAs are required +-- an instance from being found, and whether VTAs are required -- due to type class members not referencing all the type class -- head's type variables. data UnknownsHint   = NoUnknowns   | Unknowns   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | -- A module declaration, consisting of comments about the module, a module name,@@ -306,7 +306,7 @@   -- An import with a list of references to hide: `import M hiding (foo)`   --   | Hiding [DeclarationRef]-  deriving (Eq, Show, Generic, Serialise)+  deriving (Eq, Show, Generic, Serialise, NFData)  isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True@@ -323,7 +323,7 @@   { rdeclSourceAnn :: !SourceAnn   , rdeclIdent :: !(ProperName 'TypeName)   , rdeclRoles :: ![Role]-  } deriving (Show, Eq)+  } deriving (Show, Eq, Generic, NFData)  -- | A type declaration assigns a type to an identifier, eg: --@@ -334,7 +334,7 @@   { tydeclSourceAnn :: !SourceAnn   , tydeclIdent :: !Ident   , tydeclType :: !SourceType-  } deriving (Show, Eq)+  } deriving (Show, Eq, Generic, NFData)  getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d@@ -356,7 +356,7 @@   -- ^ Whether or not this value is exported/visible   , valdeclBinders :: ![Binder]   , valdeclExpression :: !a-  } deriving (Show, Functor, Foldable, Traversable)+  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)  getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d@@ -370,7 +370,7 @@   { dataCtorAnn :: !SourceAnn   , dataCtorName :: !(ProperName 'ConstructorName)   , dataCtorFields :: ![(Ident, SourceType)]-  } deriving (Show, Eq)+  } deriving (Show, Eq, Generic, NFData)  mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }@@ -445,13 +445,13 @@   -- declaration, while the second @SourceAnn@ serves as the   -- annotation for the type class and its arguments.   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody-  deriving (Show)+  deriving (Show, Generic, NFData)  data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic, NFData)  data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic, NFData)  pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))@@ -462,7 +462,7 @@ data InstanceDerivationStrategy   = KnownClassStrategy   | NewtypeStrategy-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | The members of a type class instance declaration data TypeInstanceBody@@ -472,7 +472,7 @@   -- ^ This is an instance derived from a newtype   | ExplicitInstance [Declaration]   -- ^ This is a regular (explicit) instance-  deriving (Show)+  deriving (Show, Generic, NFData)  mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)@@ -488,9 +488,7 @@   | NewtypeSig   | TypeSynonymSig   | ClassSig-  deriving (Eq, Ord, Show, Generic)--instance NFData KindSignatureFor+  deriving (Eq, Ord, Show, Generic, NFData)  declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa@@ -627,13 +625,13 @@ -- data Guard = ConditionGuard Expr            | PatternGuard Binder Expr-           deriving (Show)+           deriving (Show, Generic, NFData)  -- | -- The right hand side of a binder in value declarations -- and case expressions. data GuardedExpr = GuardedExpr [Guard] Expr-                 deriving (Show)+                 deriving (Show, Generic, NFData)  pattern MkUnguarded :: Expr -> GuardedExpr pattern MkUnguarded e = GuardedExpr [] e@@ -764,7 +762,7 @@   -- A value with source position information   --   | PositionedValue SourceSpan [Comment] Expr-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | -- Metadata that tells where a let binding originated@@ -778,7 +776,7 @@   -- The let binding was always a let binding   --   | FromLet-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | -- An alternative in a case statement@@ -792,7 +790,7 @@     -- The result expression or a collect of guarded expressions     --   , caseAlternativeResult :: [GuardedExpr]-  } deriving (Show)+  } deriving (Show, Generic, NFData)  -- | -- A statement in a do-notation block@@ -814,7 +812,7 @@   -- A do notation element with source position information   --   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement-  deriving (Show)+  deriving (Show, Generic, NFData)   -- For a record update such as:@@ -842,12 +840,14 @@  newtype PathTree t = PathTree (AssocList PSString (PathNode t))   deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+  deriving newtype NFData  data PathNode t = Leaf t | Branch (PathTree t)-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)  newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }   deriving (Show, Eq, Ord, Foldable, Functor, Traversable)+  deriving newtype NFData  $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)
src/Language/PureScript/AST/Literals.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE DeriveAnyClass #-} -- | -- The core functional representation for literal values. -- module Language.PureScript.AST.Literals where  import Prelude+import Control.DeepSeq (NFData)+import GHC.Generics (Generic) import Language.PureScript.PSString (PSString)  -- |@@ -35,4 +38,4 @@   -- An object literal   --   | ObjectLiteral [(PSString, a)]-  deriving (Eq, Ord, Show, Functor)+  deriving (Eq, Ord, Show, Functor, Generic, NFData)
src/Language/PureScript/Bundle.hs view
@@ -4,6 +4,7 @@ -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final JavaScript bundle.+{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Bundle   ( ModuleIdentifier(..)   , ModuleType(..)@@ -18,6 +19,7 @@  import Prelude +import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..))  import Data.Aeson ((.=))@@ -27,6 +29,8 @@ import Data.Aeson qualified as A import Data.Text.Lazy qualified as LT +import GHC.Generics (Generic)+ import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText) import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..)) import Language.JavaScript.Process.Minify (minifyJS)@@ -42,21 +46,22 @@   | ErrorInModule ModuleIdentifier ErrorMessage   | MissingEntryPoint String   | MissingMainModule String-  deriving (Show)+  deriving (Show, Generic, NFData)  -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or -- foreign modules. data ModuleType   = Regular   | Foreign-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic, NFData)  showModuleType :: ModuleType -> String showModuleType Regular = "Regular" showModuleType Foreign = "Foreign"  -- | A module is identified by its module name and its type.-data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)+data ModuleIdentifier = ModuleIdentifier String ModuleType+  deriving (Show, Eq, Ord, Generic, NFData)  instance A.ToJSON ModuleIdentifier where   toJSON (ModuleIdentifier name mt) =
src/Language/PureScript/CST/Errors.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.CST.Errors   ( ParserErrorInfo(..)   , ParserErrorType(..)@@ -11,8 +12,10 @@  import Prelude +import Control.DeepSeq (NFData) import Data.Text qualified as Text import Data.Char (isSpace, toUpper)+import GHC.Generics (Generic) import Language.PureScript.CST.Layout (LayoutStack) import Language.PureScript.CST.Print (printToken) import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..))@@ -56,7 +59,7 @@   | ErrConstraintInForeignImportSyntax   | ErrEof   | ErrCustom String-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic, NFData)  data ParserWarningType   = WarnDeprecatedRowSyntax@@ -64,14 +67,14 @@   | WarnDeprecatedKindImportSyntax   | WarnDeprecatedKindExportSyntax   | WarnDeprecatedCaseOfOffsideSyntax-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic, NFData)  data ParserErrorInfo a = ParserErrorInfo   { errRange :: SourceRange   , errToks :: [SourceToken]   , errStack :: LayoutStack   , errType :: a-  } deriving (Show, Eq)+  } deriving (Show, Eq, Generic, NFData)  type ParserError = ParserErrorInfo ParserErrorType type ParserWarning = ParserErrorInfo ParserWarningType
src/Language/PureScript/CST/Layout.hs view
@@ -166,14 +166,17 @@ --    "body of a case of expression" by pushing 'LytOf' onto the layout stack. --    Insert the @of@ token into the stream of tokens. --+{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.CST.Layout where  import Prelude +import Control.DeepSeq (NFData) import Data.DList (snoc) import Data.DList qualified as DList import Data.Foldable (find) import Data.Function ((&))+import GHC.Generics (Generic) import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..))  type LayoutStack = [(SourcePos, LayoutDelim)]@@ -201,7 +204,7 @@   | LytOf   | LytDo   | LytAdo-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic, NFData)  isIndented :: LayoutDelim -> Bool isIndented = \case
src/Language/PureScript/CST/Parser.y view
@@ -722,7 +722,7 @@   : constraints '<=' {%^ revert $ pure ($1, $2) }  classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) }-  : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure (getProperName $1, $2, $3) }+  : properName manyOrEmpty(typeVarBindingPlain) fundeps {%^ revert $ pure (getProperName $1, $2, $3) }  fundeps :: { Maybe (SourceToken, Separated ClassFundep) }   : {- empty -} { Nothing }
src/Language/PureScript/CST/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} -- | This module contains data types for the entire PureScript surface language. Every -- token is represented in the tree, and every token is annotated with -- whitespace and comments (both leading and trailing). This means one can write@@ -9,6 +10,7 @@  import Prelude +import Control.DeepSeq (NFData) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Void (Void)@@ -20,30 +22,30 @@ data SourcePos = SourcePos   { srcLine :: {-# UNPACK #-} !Int   , srcColumn :: {-# UNPACK #-} !Int-  } deriving (Show, Eq, Ord, Generic)+  } deriving (Show, Eq, Ord, Generic, NFData)  data SourceRange = SourceRange   { srcStart :: !SourcePos   , srcEnd :: !SourcePos-  } deriving (Show, Eq, Ord, Generic)+  } deriving (Show, Eq, Ord, Generic, NFData)  data Comment l   = Comment !Text   | Space {-# UNPACK #-} !Int   | Line !l-  deriving (Show, Eq, Ord, Generic, Functor)+  deriving (Show, Eq, Ord, Generic, Functor, NFData)  data LineFeed = LF | CRLF-  deriving (Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic, NFData)  data TokenAnn = TokenAnn   { tokRange :: !SourceRange   , tokLeadingComments :: ![Comment LineFeed]   , tokTrailingComments :: ![Comment Void]-  } deriving (Show, Eq, Ord, Generic)+  } deriving (Show, Eq, Ord, Generic, NFData)  data SourceStyle = ASCII | Unicode-  deriving (Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic, NFData)  data Token   = TokLeftParen@@ -79,12 +81,12 @@   | TokLayoutSep   | TokLayoutEnd   | TokEof-  deriving (Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic, NFData)  data SourceToken = SourceToken   { tokAnn :: !TokenAnn   , tokValue :: !Token-  } deriving (Show, Eq, Ord, Generic)+  } deriving (Show, Eq, Ord, Generic, NFData)  data Ident = Ident   { getIdent :: Text
src/Language/PureScript/CoreFn/CSE.hs view
@@ -12,7 +12,7 @@ import Data.Functor.Compose (Compose(..)) import Data.IntMap.Monoidal qualified as IM import Data.IntSet qualified as IS-import Data.Map qualified as M+import Data.Map.Strict qualified as M import Data.Maybe (fromJust) import Data.Semigroup (Min(..)) import Data.Semigroup.Generic (GenericSemigroupMonoid(..))@@ -216,7 +216,7 @@     if isTopLevel     then env{ _depth = depth', _deepestTopLevelScope = depth' }     else env{ _depth = depth' }-    where +    where     depth' = succ _depth  -- |
src/Language/PureScript/Errors.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Errors   ( module Language.PureScript.AST   , module Language.PureScript.Errors@@ -7,7 +8,7 @@ import Protolude (unsnoc)  import Control.Arrow ((&&&))-import Control.Exception (displayException)+import Control.DeepSeq (NFData) import Control.Lens (both, head1, over) import Control.Monad (forM, unless) import Control.Monad.Error.Class (MonadError(..))@@ -32,6 +33,7 @@ import Data.Text qualified as T import Data.Text (Text) import Data.Traversable (for)+import GHC.Generics (Generic) import GHC.Stack qualified import Language.PureScript.AST import Language.PureScript.Bundle qualified as Bundle@@ -70,7 +72,7 @@   | DeprecatedFFICommonJSModule ModuleName FilePath   | UnsupportedFFICommonJSExports ModuleName [Text]   | UnsupportedFFICommonJSImports ModuleName [Text]-  | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred+  | FileIOError Text Text -- ^ A description of what we were trying to do, and the error which occurred   | InfiniteType SourceType   | InfiniteKind SourceType   | MultipleValueOpFixities (OpName 'ValueOpName)@@ -196,12 +198,12 @@   | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool   | CannotSkipTypeApplication SourceType   | CannotApplyExpressionOfTypeOnType SourceType SourceType-  deriving (Show)+  deriving (Show, Generic, NFData)  data ErrorMessage = ErrorMessage   [ErrorMessageHint]   SimpleErrorMessage-  deriving (Show)+  deriving (Show, Generic, NFData)  newtype ErrorSuggestion = ErrorSuggestion Text @@ -369,7 +371,9 @@ -- | A stack trace for an error newtype MultipleErrors = MultipleErrors   { runMultipleErrors :: [ErrorMessage]-  } deriving (Show, Semigroup, Monoid)+  }+  deriving stock (Show)+  deriving newtype (Semigroup, Monoid, NFData)  -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool@@ -679,7 +683,7 @@             ]     renderSimpleErrorMessage (FileIOError doWhat err) =       paras [ line $ "I/O error while trying to " <> doWhat-            , indent . lineS $ displayException err+            , indent . line $ err             ]     renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =       paras $ [ line "Unable to parse foreign module:"@@ -941,7 +945,7 @@                           <> case argsRequiringVtas of                               [required] ->                                 [ Box.moveRight 2 $ line $ T.intercalate ", " required ]-                              options -> +                              options ->                                 [ Box.moveRight 2 $ line "One of the following sets of type variables:"                                 , Box.moveRight 2 $ paras $                                     map (\set -> Box.moveRight 2 $ line $ T.intercalate ", " set) options
src/Language/PureScript/Externs.hs view
@@ -1,3 +1,4 @@+{-# Language DeriveAnyClass #-} -- | -- This module generates code for \"externs\" files, i.e. files containing only -- foreign import declarations.@@ -17,8 +18,8 @@ import Prelude  import Codec.Serialise (Serialise)+import Control.DeepSeq (NFData) import Control.Monad (join)-import GHC.Generics (Generic) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold)@@ -27,6 +28,7 @@ import Data.Version (showVersion) 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.Declarations.ChainId (ChainId)@@ -59,7 +61,7 @@   -- ^ List of type and value declaration   , efSourceSpan :: SourceSpan   -- ^ Source span for error reporting-  } deriving (Show, Generic)+  } deriving (Show, Generic, NFData)  instance Serialise ExternsFile @@ -72,7 +74,7 @@   , eiImportType :: ImportDeclarationType   -- | The imported-as name, for qualified imports   , eiImportedAs :: Maybe ModuleName-  } deriving (Show, Generic)+  } deriving (Show, Generic, NFData)  instance Serialise ExternsImport @@ -87,7 +89,7 @@   , efOperator :: OpName 'ValueOpName   -- | The value the operator is an alias for   , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))-  } deriving (Show, Generic)+  } deriving (Show, Generic, NFData)  instance Serialise ExternsFixity @@ -102,7 +104,7 @@   , efTypeOperator :: OpName 'TypeOpName   -- | The value the operator is an alias for   , efTypeAlias :: Qualified (ProperName 'TypeName)-  } deriving (Show, Generic)+  } deriving (Show, Generic, NFData)  instance Serialise ExternsTypeFixity @@ -155,7 +157,7 @@       , edInstanceNameSource      :: NameSource       , edInstanceSourceSpan      :: SourceSpan       }-  deriving (Show, Generic)+  deriving (Show, Generic, NFData)  instance Serialise ExternsDeclaration
src/Language/PureScript/Make.hs view
@@ -12,12 +12,14 @@ import Prelude  import Control.Concurrent.Lifted as C-import Control.Exception.Base (onException)-import Control.Monad (foldM, unless, when)+import Control.DeepSeq (force)+import Control.Exception.Lifted (onException, bracket_, evaluate)+import Control.Monad (foldM, unless, when, (<=<))+import Control.Monad.Base (MonadBase(liftBase)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)-import Control.Monad.Trans.Control (MonadBaseControl(..), control)+import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.State (runStateT) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Control.Monad.Writer.Strict (runWriterT)@@ -29,6 +31,7 @@ import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T+import Debug.Trace (traceMarkerIO) import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST@@ -56,7 +59,7 @@ -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule   :: forall m-   . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)   => MakeActions m   -> [ExternsFile]   -> Module@@ -67,7 +70,7 @@  rebuildModule'   :: forall m-   . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)   => MakeActions m   -> Env   -> [ExternsFile]@@ -77,7 +80,7 @@  rebuildModuleWithIndex   :: forall m-   . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)   => MakeActions m   -> Env   -> [ExternsFile]@@ -148,12 +151,21 @@    (buildPlan, newCacheDb) <- BuildPlan.construct 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`.+  -- This is to ensure that modules complete fully before moving on, to avoid+  -- holding excess memory during compilation from modules that were paused+  -- by the Haskell runtime.+  capabilities <- getNumCapabilities+  let concurrency = max 1 capabilities+  lock <- C.newQSem concurrency+   let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted   let totalModuleCount = length toBeRebuilt   for_ toBeRebuilt $ \m -> fork $ do     let moduleName = getModuleName . CST.resPartial $ m     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)-    buildModule buildPlan moduleName totalModuleCount+    buildModule lock buildPlan moduleName totalModuleCount       (spanName . getModuleSourceSpan . CST.resPartial $ m)       (fst $ CST.resFull m)       (fmap importPrim . snd $ CST.resFull m)@@ -161,7 +173,7 @@        -- Prevent hanging on other modules when there is an internal error       -- (the exception is thrown, but other threads waiting on MVars are released)-      `onExceptionLifted` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty)+      `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty)    -- Wait for all threads to complete, and collect results (and errors).   (failures, successes) <-@@ -227,8 +239,8 @@   inOrderOf :: (Ord a) => [a] -> [a] -> [a]   inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys -  buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()-  buildModule buildPlan moduleName cnt fp pwarnings mres deps = do+  buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()+  buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do     result <- flip catchError (return . BuildJobFailed) $ do       let pwarnings' = CST.toMultipleWarnings fp pwarnings       tell pwarnings'@@ -252,14 +264,23 @@           env <- C.readMVar (bpEnv buildPlan)           idx <- C.takeMVar (bpIndex buildPlan)           C.putMVar (bpIndex buildPlan) (idx + 1)-          (exts, warnings) <- listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt))++          -- Bracket all of the per-module work behind the semaphore, including+          -- forcing the result. This is done to limit concurrency and keep+          -- memory usage down; see comments above.+          (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do+            -- Eventlog markers for profiling; see debug/eventlog.js+            liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"+            -- Force the externs and warnings to avoid retaining excess module+            -- data after the module is finished compiling.+            extsAndWarnings <- evaluate . force <=< listen $ do+              rebuildModuleWithIndex ma env externs m (Just (idx, cnt))+            liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"+            return extsAndWarnings           return $ BuildJobSucceeded (pwarnings' <> warnings) exts         Nothing -> return BuildJobSkipped      BuildPlan.markComplete buildPlan moduleName result--  onExceptionLifted :: m a -> m b -> m a-  onExceptionLifted l r = control $ \runInIO -> runInIO l `onException` runInIO r  -- | Infer the module name for a module by looking for the same filename with -- a .js extension.
src/Language/PureScript/Make/Monad.hs view
@@ -23,7 +23,7 @@  import Codec.Serialise (Serialise) import Codec.Serialise qualified as Serialise-import Control.Exception (fromException, tryJust)+import Control.Exception (fromException, tryJust, Exception (displayException)) import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..))@@ -71,7 +71,7 @@ makeIO :: (MonadIO m, MonadError MultipleErrors m) => Text -> IO a -> m a makeIO description io = do   res <- liftIO (tryIOError io)-  either (throwError . singleError . ErrorMessage [] . FileIOError description) pure res+  either (throwError . singleError . ErrorMessage [] . FileIOError description . Text.pack . displayException) pure res  -- | Get a file's modification time in the 'Make' monad, capturing any errors -- using the 'MonadError' instance.
+ tests/purs/failing/4522.out view
@@ -0,0 +1,10 @@+Error found:+at tests/purs/failing/4522.purs:4:11 - 4:12 (line 4, column 11 - line 4, column 12)++  Unable to parse module:+  Unexpected token '@'+++See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information,+or to contribute content related to this error.+
+ tests/purs/failing/4522.purs view
@@ -0,0 +1,4 @@+-- @shouldFailWith ErrorParsingModule+module Main where++class Foo @a
tests/support/package-lock.json view
@@ -17,9 +17,9 @@       "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw=="     },     "node_modules/bower": {-      "version": "1.8.13",-      "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.13.tgz",-      "integrity": "sha512-8eWko16JlCTdaZZG70kddHPed17pHEbH8/IjfP4IFkQsfEqRsyNM09Dc8cDBFkSvtQ/2lTea7A+bMhRggG2a+Q==",+      "version": "1.8.14",+      "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.14.tgz",+      "integrity": "sha512-8Rq058FD91q9Nwthyhw0la9fzpBz0iwZTrt51LWl+w+PnJgZk9J+5wp3nibsJcIUPglMYXr4NRBaR+TUj0OkBQ==",       "bin": {         "bower": "bin/bower"       },@@ -153,9 +153,9 @@       "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw=="     },     "bower": {-      "version": "1.8.13",-      "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.13.tgz",-      "integrity": "sha512-8eWko16JlCTdaZZG70kddHPed17pHEbH8/IjfP4IFkQsfEqRsyNM09Dc8cDBFkSvtQ/2lTea7A+bMhRggG2a+Q=="+      "version": "1.8.14",+      "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.14.tgz",+      "integrity": "sha512-8Rq058FD91q9Nwthyhw0la9fzpBz0iwZTrt51LWl+w+PnJgZk9J+5wp3nibsJcIUPglMYXr4NRBaR+TUj0OkBQ=="     },     "brace-expansion": {       "version": "1.1.11",