wclr · Dec 26, 2023 · Jun 18, 2023 · Dec 26, 2023 · Jul 7, 2023 · Feb 24, 2024
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
@@ -16,12 +16,13 @@ import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors)
 import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound)
-import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
+import Language.PureScript.Make (MakeOptions(..), buildMakeActions, inferForeignModules, progressWithFile, printProgress, runMake)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
 import System.Exit (exitSuccess, exitFailure)
-import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>))
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
 
@@ -30,6 +31,9 @@ data PSCMakeOptions = PSCMakeOptions
   , pscmInputFromFile :: Maybe FilePath
   , pscmExclude      :: [FilePath]
   , pscmOutputDir    :: FilePath
+  , pscmLogFile      :: FilePath
+  , pscmNoDiffCheck  :: Bool
+  , pscmIncWarnings  :: Bool
   , pscmOpts         :: P.Options
   , pscmUsePrefix    :: Bool
   , pscmJSONErrors   :: Bool
@@ -68,12 +72,23 @@ compile PSCMakeOptions{..} = do
                              ]
     exitFailure
   moduleFiles <- readUTF8FilesT input
+
+  _ <- createDirectoryIfMissing True pscmOutputDir
+  let logFile = pscmOutputDir </> pscmLogFile
+  let cleanFile = True
+
   (makeErrors, makeWarnings) <- runMake pscmOpts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
-    let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+    logProgress <- progressWithFile logFile cleanFile
+    let makeActions = (buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix)
+            { P.progress = (*>) <$> printProgress <*> logProgress }
+    let makeOpts = MakeOptions
+          { moCollectAll = not pscmIncWarnings
+          , moDiffCheck = not pscmNoDiffCheck
+          }
+    P.make' makeOpts makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
@@ -119,6 +134,28 @@ codegenTargets = Opts.option targetParser $
       <> " The default target is 'js', but if this option is used only the targets specified will be used."
       )
 
+compileLogFile :: Opts.Parser FilePath
+compileLogFile = Opts.strOption $
+     Opts.short 'l'
+  <> Opts.long "log-file"
+  <> Opts.value "compile.log"
+  <> Opts.showDefault
+  <> Opts.help
+      "File name for compile progress log put in output directory."
+
+noDiffCheck :: Opts.Parser Bool
+noDiffCheck = Opts.switch $
+     Opts.long "no-diff-check"
+  <> Opts.help
+      ( "Disable module external changes check while incremental build."
+      <> " Useful for diagnosing an unexpected build result."
+      )
+
+incWarnings :: Opts.Parser Bool
+incWarnings = Opts.switch $
+     Opts.long "incremental-warnings"
+  <> Opts.help "Output warnings only for incrementally compiled modules."
+
 targetsMessage :: String
 targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'."
 
@@ -147,6 +184,9 @@ pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile
                                 <*> SharedCLI.globInputFile
                                 <*> many SharedCLI.excludeFiles
                                 <*> outputDirectory
+                                <*> compileLogFile
+                                <*> noDiffCheck
+                                <*> incWarnings
                                 <*> options
                                 <*> (not <$> noPrefix)
                                 <*> jsonErrors

diff --git a/purescript.cabal b/purescript.cabal
@@ -335,7 +335,9 @@ library
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
+    Language.PureScript.Make.ExternsDiff
     Language.PureScript.Make.Monad
+    Language.PureScript.Make.Patch
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
     Language.PureScript.Options

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-}
 -- |
 -- Case binders
 --
@@ -7,12 +7,14 @@ module Language.PureScript.AST.Binders where
 import Prelude
 
 import Control.DeepSeq (NFData)
+import Codec.Serialise (Serialise)
 import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (SourceSpan)
 import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
+import Data.Data (Data)
 
 -- |
 -- Data type for binders
@@ -64,7 +66,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 -- |
@@ -33,6 +33,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
 import Language.PureScript.Constants.Prim qualified as C
+import Data.Data (Data)
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
@@ -50,7 +51,7 @@ data TypeSearch
     -- ^ Record fields that are available on the first argument to the typed
     -- hole
     }
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -90,7 +91,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- | Categories of hints
 data HintCategory
@@ -101,7 +102,7 @@ data HintCategory
   | SolverHint
   | DeclarationHint
   | OtherHint
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic, NFData, Data)
 
 -- |
 -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented
@@ -112,7 +113,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -165,7 +166,7 @@ importPrim =
       . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Eq, Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
@@ -204,7 +205,7 @@ data DeclarationRef
   -- elaboration in name desugaring.
   --
   | ReExportRef SourceSpan ExportSource DeclarationRef
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Show, Generic, NFData, Serialise, Data)
 
 instance Eq DeclarationRef where
   (TypeClassRef _ name) == (TypeClassRef _ name') = name == name'
@@ -244,7 +245,7 @@ data ExportSource =
   { exportSourceImportedFrom :: Maybe ModuleName
   , exportSourceDefinedIn :: ModuleName
   }
-  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
+  deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise)
 
 declRefSourceSpan :: DeclarationRef -> SourceSpan
 declRefSourceSpan (TypeRef ss _ _) = ss
@@ -306,7 +307,7 @@ data ImportDeclarationType
   -- An import with a list of references to hide: `import M hiding (foo)`
   --
   | Hiding [DeclarationRef]
-  deriving (Eq, Show, Generic, Serialise, NFData)
+  deriving (Eq, Show, Generic, Serialise, NFData, Data)
 
 isExplicit :: ImportDeclarationType -> Bool
 isExplicit (Explicit _) = True
@@ -323,7 +324,7 @@ data RoleDeclarationData = RoleDeclarationData
   { rdeclSourceAnn :: !SourceAnn
   , rdeclIdent :: !(ProperName 'TypeName)
   , rdeclRoles :: ![Role]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Data, Serialise)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -334,7 +335,7 @@ data TypeDeclarationData = TypeDeclarationData
   { tydeclSourceAnn :: !SourceAnn
   , tydeclIdent :: !Ident
   , tydeclType :: !SourceType
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Data, Serialise)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -356,7 +357,7 @@ data ValueDeclarationData a = ValueDeclarationData
   -- ^ Whether or not this value is exported/visible
   , valdeclBinders :: ![Binder]
   , valdeclExpression :: !a
-  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)
+  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable, Serialise, Data)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -370,7 +371,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
   { dataCtorAnn :: !SourceAnn
   , dataCtorName :: !(ProperName 'ConstructorName)
   , dataCtorFields :: ![(Ident, SourceType)]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, NFData, Data, Serialise)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
@@ -445,13 +446,13 @@ data Declaration
   -- declaration, while the second @SourceAnn@ serves as the
   -- annotation for the type class and its arguments.
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -462,7 +463,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -472,7 +473,7 @@ data TypeInstanceBody
   -- ^ This is an instance derived from a newtype
   | ExplicitInstance [Declaration]
   -- ^ This is a regular (explicit) instance
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -488,7 +489,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData, Data, Serialise)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -625,13 +626,13 @@ flattenDecls = concatMap flattenOne
 --
 data Guard = ConditionGuard Expr
            | PatternGuard Binder Expr
-           deriving (Show, Generic, NFData)
+           deriving (Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-                 deriving (Show, Generic, NFData)
+                 deriving (Show, Generic, NFData, Data, Serialise)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -762,7 +763,7 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -776,7 +777,7 @@ data WhereProvenance
   -- The let binding was always a let binding
   --
   | FromLet
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- An alternative in a case statement
@@ -790,7 +791,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     --
   , caseAlternativeResult :: [GuardedExpr]
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Generic, NFData, Data, Serialise)
 
 -- |
 -- A statement in a do-notation block
@@ -812,7 +813,7 @@ data DoNotationElement
   -- A do notation element with source position information
   --
   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Data, Serialise)
 
 
 -- For a record update such as:
@@ -839,15 +840,16 @@ data DoNotationElement
 --
 
 newtype PathTree t = PathTree (AssocList PSString (PathNode t))
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
-  deriving newtype NFData
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data)
+  deriving newtype (NFData, Serialise)
+
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Data, Serialise)
 
 newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
-  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
-  deriving newtype NFData
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic, Data)
+  deriving newtype (NFData, Serialise)
 
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)

diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs
@@ -1,20 +1,22 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 module Language.PureScript.AST.Declarations.ChainId
-  ( ChainId
+  ( ChainId(..)
   , mkChainId
   ) where
 
 import Prelude
 import Language.PureScript.AST.SourcePos qualified as Pos
 import Control.DeepSeq (NFData)
 import Codec.Serialise (Serialise)
+import Data.Data (Data)
 
 -- |
 -- For a given instance chain, stores the chain's file name and
 -- the starting source pos of the first instance in the chain.
 -- This data is used to determine which instances are part of
 -- the same instance chain.
 newtype ChainId = ChainId (String, Pos.SourcePos)
-  deriving (Eq, Ord, Show, NFData, Serialise)
+  deriving (Eq, Ord, Show, NFData, Serialise, Data)
 
 mkChainId :: String -> Pos.SourcePos -> ChainId
 mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos)