Merge pull request #2 from wclr/make-cutoff

Make cutoff

Author: wclr

app/Command/Compile.hs

@@ -16,12 +16,13 @@ import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors)
 import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound)
-import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
+import Language.PureScript.Make (buildMakeActions, inferForeignModules, progressWithFile, printProgress, runMake)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
 import System.Exit (exitSuccess, exitFailure)
-import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>))
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
 
@@ -68,12 +69,19 @@ compile PSCMakeOptions{..} = do
                              ]
     exitFailure
   moduleFiles <- readUTF8FilesT input
+
+  _ <- createDirectoryIfMissing True pscmOutputDir
+  let logFile = pscmOutputDir </> "compile.log"
+  let cleanFile = True
+
   (makeErrors, makeWarnings) <- runMake pscmOpts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
-    let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+    logProgress <- progressWithFile logFile cleanFile
+    let makeActions = (buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix)
+            { P.progress = (*>) <$> printProgress <*> logProgress }
+    P.make_ makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 

purescript.cabal

@@ -335,6 +335,7 @@ library
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
+    Language.PureScript.Make.ExternsDiff
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names

src/Language/PureScript/AST/Binders.hs

@@ -7,6 +7,7 @@ module Language.PureScript.AST.Binders where
 import Prelude
 
 import Control.DeepSeq (NFData)
+import Codec.Serialise (Serialise)
 import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (SourceSpan)
 import Language.PureScript.AST.Literals (Literal(..))
@@ -64,7 +65,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`

src/Language/PureScript/AST/Declarations.hs

@@ -50,7 +50,7 @@ data TypeSearch
     -- ^ Record fields that are available on the first argument to the typed
     -- hole
     }
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -90,7 +90,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- | Categories of hints
 data HintCategory
@@ -112,7 +112,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -165,7 +165,7 @@ importPrim =
       . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Eq, Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
@@ -323,7 +323,7 @@ data RoleDeclarationData = RoleDeclarationData
   { rdeclSourceAnn :: !SourceAnn
   , rdeclIdent :: !(ProperName 'TypeName)
   , rdeclRoles :: ![Role]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Serialise)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -334,7 +334,7 @@ data TypeDeclarationData = TypeDeclarationData
   { tydeclSourceAnn :: !SourceAnn
   , tydeclIdent :: !Ident
   , tydeclType :: !SourceType
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Serialise)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -356,7 +356,7 @@ data ValueDeclarationData a = ValueDeclarationData
   -- ^ Whether or not this value is exported/visible
   , valdeclBinders :: ![Binder]
   , valdeclExpression :: !a
-  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)
+  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable, Serialise)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -370,7 +370,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
   { dataCtorAnn :: !SourceAnn
   , dataCtorName :: !(ProperName 'ConstructorName)
   , dataCtorFields :: ![(Ident, SourceType)]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Serialise)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
@@ -445,13 +445,13 @@ data Declaration
   -- declaration, while the second @SourceAnn@ serves as the
   -- annotation for the type class and its arguments.
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -462,7 +462,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -472,7 +472,7 @@ data TypeInstanceBody
   -- ^ This is an instance derived from a newtype
   | ExplicitInstance [Declaration]
   -- ^ This is a regular (explicit) instance
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -488,7 +488,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -625,13 +625,13 @@ flattenDecls = concatMap flattenOne
 --
 data Guard = ConditionGuard Expr
            | PatternGuard Binder Expr
-           deriving (Show, Generic, NFData)
+           deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-                 deriving (Show, Generic, NFData)
+                 deriving (Show, Generic, NFData, Serialise)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -762,7 +762,7 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -776,7 +776,7 @@ data WhereProvenance
   -- The let binding was always a let binding
   --
   | FromLet
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- An alternative in a case statement
@@ -790,7 +790,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     --
   , caseAlternativeResult :: [GuardedExpr]
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- A statement in a do-notation block
@@ -812,7 +812,7 @@ data DoNotationElement
   -- A do notation element with source position information
   --
   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 
 -- For a record update such as:
@@ -839,15 +839,16 @@ data DoNotationElement
 --
 
 newtype PathTree t = PathTree (AssocList PSString (PathNode t))
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
-  deriving newtype NFData
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  deriving newtype (NFData, Serialise)
+
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise)
 
 newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
-  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
-  deriving newtype NFData
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
+  deriving newtype (NFData, Serialise)
 
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)

src/Language/PureScript/AST/Declarations/ChainId.hs

@@ -1,5 +1,5 @@
 module Language.PureScript.AST.Declarations.ChainId
-  ( ChainId
+  ( ChainId(..)
   , mkChainId
   ) where
 

src/Language/PureScript/AST/Literals.hs

@@ -5,6 +5,7 @@
 module Language.PureScript.AST.Literals where
 
 import Prelude
+import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
@@ -38,4 +39,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic, NFData, Serialise)

src/Language/PureScript/AST/SourcePos.hs

@@ -116,3 +116,6 @@ widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) =
 
 widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn
 widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, [])
+
+replaceSpanName :: String -> SourceSpan -> SourceSpan
+replaceSpanName name (SourceSpan _ sps spe) = SourceSpan name sps spe

src/Language/PureScript/Bundle.hs

@@ -19,6 +19,7 @@ module Language.PureScript.Bundle
 
 import Prelude
 
+import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
 import Control.Monad.Error.Class (MonadError(..))
 
@@ -46,22 +47,22 @@ data ErrorMessage
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
 -- foreign modules.
 data ModuleType
   = Regular
   | Foreign
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 showModuleType :: ModuleType -> String
 showModuleType Regular = "Regular"
 showModuleType Foreign = "Foreign"
 
 -- | A module is identified by its module name and its type.
 data ModuleIdentifier = ModuleIdentifier String ModuleType
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 instance A.ToJSON ModuleIdentifier where
   toJSON (ModuleIdentifier name mt) =

src/Language/PureScript/CST/Errors.hs

@@ -12,9 +12,10 @@ module Language.PureScript.CST.Errors
 
 import Prelude
 
+import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Text qualified as Text
 import Data.Char (isSpace, toUpper)
+import Data.Text qualified as Text
 import GHC.Generics (Generic)
 import Language.PureScript.CST.Layout (LayoutStack)
 import Language.PureScript.CST.Print (printToken)
@@ -59,22 +60,22 @@ data ParserErrorType
   | ErrConstraintInForeignImportSyntax
   | ErrEof
   | ErrCustom String
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 data ParserWarningType
   = WarnDeprecatedRowSyntax
   | WarnDeprecatedForeignKindSyntax
   | WarnDeprecatedKindImportSyntax
   | WarnDeprecatedKindExportSyntax
   | WarnDeprecatedCaseOfOffsideSyntax
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 data ParserErrorInfo a = ParserErrorInfo
   { errRange :: SourceRange
   , errToks :: [SourceToken]
   , errStack :: LayoutStack
   , errType :: a
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Serialise)
 
 type ParserError = ParserErrorInfo ParserErrorType
 type ParserWarning = ParserErrorInfo ParserWarningType

src/Language/PureScript/CST/Layout.hs

@@ -171,6 +171,7 @@ module Language.PureScript.CST.Layout where
 
 import Prelude
 
+import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
 import Data.DList (snoc)
 import Data.DList qualified as DList
@@ -204,7 +205,7 @@ data LayoutDelim
   | LytOf
   | LytDo
   | LytAdo
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 isIndented :: LayoutDelim -> Bool
 isIndented = \case