summaryrefslogtreecommitdiff
path: root/src/Language
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language')
-rw-r--r--src/Language/PureScript/AST/Declarations.hs6
-rw-r--r--src/Language/PureScript/AST/Traversals.hs11
-rw-r--r--src/Language/PureScript/Bundle.hs57
-rw-r--r--src/Language/PureScript/Errors.hs43
-rw-r--r--src/Language/PureScript/Linter/Imports.hs3
-rw-r--r--src/Language/PureScript/Make.hs34
-rw-r--r--src/Language/PureScript/Make/Actions.hs77
-rw-r--r--src/Language/PureScript/Make/BuildPlan.hs93
-rw-r--r--src/Language/PureScript/Make/Cache.hs130
-rw-r--r--src/Language/PureScript/Make/Monad.hs85
-rw-r--r--src/Language/PureScript/Names.hs7
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs1
13 files changed, 432 insertions, 122 deletions
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 93f8d87..557cb51 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -75,9 +75,7 @@ data SimpleErrorMessage
| MissingFFIImplementations ModuleName [Ident]
| UnusedFFIImplementations ModuleName [Ident]
| InvalidFFIIdentifier ModuleName Text
- | CannotGetFileInfo FilePath
- | CannotReadFile FilePath
- | CannotWriteFile FilePath
+ | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred
| InfiniteType SourceType
| InfiniteKind SourceKind
| MultipleValueOpFixities (OpName 'ValueOpName)
@@ -151,7 +149,7 @@ data SimpleErrorMessage
| IncompleteExhaustivityCheck
| MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
| ImportHidingModule ModuleName
- | UnusedImport ModuleName
+ | UnusedImport ModuleName (Maybe ModuleName)
| UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef]
| UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
| UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 70543f8..4aaeeec 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -11,6 +11,7 @@ import Data.Foldable (fold)
import Data.List (mapAccumL)
import Data.Maybe (mapMaybe)
import qualified Data.List.NonEmpty as NEL
+import qualified Data.Map as M
import qualified Data.Set as S
import Language.PureScript.AST.Binders
@@ -19,6 +20,7 @@ import Language.PureScript.AST.Literals
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Traversals
+import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
import Language.PureScript.Types
guardedExprM :: Applicative m
@@ -693,5 +695,12 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
where
g :: Expr -> Expr
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
- g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints
+ g (TypeClassDictionary c sco hints) =
+ TypeClassDictionary
+ (mapConstraintArgs (fmap f) c)
+ (updateCtx sco)
+ hints
g other = other
+ updateDict fn dict = dict { tcdInstanceTypes = fn (tcdInstanceTypes dict) }
+ updateScope = fmap . fmap . fmap . fmap $ updateDict $ fmap f
+ updateCtx = M.alter updateScope Nothing
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 2fd4165..df746f3 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -270,7 +270,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
boundNames = mapMaybe toBoundName es
where
toBoundName :: ModuleElement -> Maybe String
- toBoundName (Member _ _ nm _ _) = Just nm
+ toBoundName (Member _ Internal nm _ _) = Just nm
toBoundName _ = Nothing
-- | Calculate dependencies and add them to the current element.
@@ -301,13 +301,33 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
-- bound to the module level (i.e., hasn't been shadowed by a function
-- parameter)
= ([(m, nm, Internal)], bn)
+ toReference (JSObjectLiteral _ props _) bn
+ = let
+ shorthandNames =
+ filter (`elem` bn) $
+ -- ^ only add a dependency if this name is still in the list of
+ -- names bound to the module level (i.e., hasn't been shadowed by a
+ -- function parameter)
+ mapMaybe unPropertyIdentRef $
+ trailingCommaList props
+ in
+ (map (\name -> (m, name, Internal)) shorthandNames, bn)
toReference (JSFunctionExpression _ _ _ params _ _) bn
- = ([], bn \\ (mapMaybe unIdent $ commaList 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
+ -- this module.
+ = ([(m, nm, Public)], bn)
toReference _ bn = ([], bn)
- unIdent :: JSIdent -> Maybe String
- unIdent (JSIdentName _ name) = Just name
- unIdent _ = Nothing
+ unIdentifier :: JSExpression -> Maybe String
+ unIdentifier (JSIdentifier _ name) = Just name
+ unIdentifier _ = Nothing
+
+ unPropertyIdentRef :: JSObjectProperty -> Maybe String
+ unPropertyIdentRef (JSPropertyIdentRef _ name) = Just name
+ unPropertyIdentRef _ = Nothing
-- String literals include the quote chars
fromStringLiteral :: JSExpression -> Maybe String
@@ -450,21 +470,22 @@ matchMember stmt
= Just (Internal, name, decl)
-- exports.foo = expr; exports["foo"] = expr;
| JSAssignStatement e (JSAssign _) decl _ <- stmt
- , Just name <- accessor e
+ , Just name <- exportsAccessor e
= Just (Public, name, decl)
| otherwise
= Nothing
- where
- accessor :: JSExpression -> Maybe String
- accessor (JSMemberDot exports _ nm)
- | JSIdentifier _ "exports" <- exports
- , JSIdentifier _ name <- nm
- = Just name
- accessor (JSMemberSquare exports _ nm _)
- | JSIdentifier _ "exports" <- exports
- , Just name <- fromStringLiteral nm
- = Just name
- accessor _ = Nothing
+
+-- Matches exports.* or exports["*"] expressions and returns the property name.
+exportsAccessor :: JSExpression -> Maybe String
+exportsAccessor (JSMemberDot exports _ nm)
+ | JSIdentifier _ "exports" <- exports
+ , JSIdentifier _ name <- nm
+ = Just name
+exportsAccessor (JSMemberSquare exports _ nm _)
+ | JSIdentifier _ "exports" <- exports
+ , Just name <- fromStringLiteral nm
+ = Just name
+exportsAccessor _ = Nothing
-- Matches assignments to module.exports, like this:
-- module.exports = { ... }
@@ -757,7 +778,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
iife :: [JSStatement] -> String -> JSExpression -> JSStatement
iife body param arg =
- JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot param)) JSNoAnnot
+ JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentifier JSNoAnnot param)) JSNoAnnot
(JSBlock sp (prependWhitespace "\n " body) lf))
JSNoAnnot)
JSNoAnnot
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index cb4f460..1386ce6 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -10,6 +10,7 @@ import Prelude.Compat
import Protolude (ordNub)
import Control.Arrow ((&&&))
+import Control.Exception (displayException)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.State.Lazy
@@ -85,9 +86,7 @@ errorCode em = case unwrapErrorMessage em of
MissingFFIImplementations{} -> "MissingFFIImplementations"
UnusedFFIImplementations{} -> "UnusedFFIImplementations"
InvalidFFIIdentifier{} -> "InvalidFFIIdentifier"
- CannotGetFileInfo{} -> "CannotGetFileInfo"
- CannotReadFile{} -> "CannotReadFile"
- CannotWriteFile{} -> "CannotWriteFile"
+ FileIOError{} -> "FileIOError"
InfiniteType{} -> "InfiniteType"
InfiniteKind{} -> "InfiniteKind"
MultipleValueOpFixities{} -> "MultipleValueOpFixities"
@@ -465,17 +464,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
else
"Make sure the source file exists, and that it has been provided as an input to the compiler."
]
- renderSimpleErrorMessage (CannotGetFileInfo path) =
- paras [ line "Unable to read file info: "
- , indent . lineS $ path
- ]
- renderSimpleErrorMessage (CannotReadFile path) =
- paras [ line "Unable to read file: "
- , indent . lineS $ path
- ]
- renderSimpleErrorMessage (CannotWriteFile path) =
- paras [ line "Unable to write file: "
- , indent . lineS $ path
+ renderSimpleErrorMessage (FileIOError doWhat err) =
+ paras [ line $ "I/O error while trying to " <> doWhat
+ , indent . lineS $ displayException err
]
renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =
paras $ [ line "Unable to parse foreign module:"
@@ -897,8 +888,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "An exhaustivity check was abandoned due to too many possible cases."
, line "You may want to decompose your data types into smaller types."
]
- renderSimpleErrorMessage (UnusedImport name) =
- line $ "The import of module " <> markCode (runModuleName name) <> " is redundant"
+
+ renderSimpleErrorMessage (UnusedImport mn qualifier) =
+ let
+ mark = markCode . runModuleName
+ unqualified = "The import of " <> mark mn <> " is redundant"
+ msg' q = "The qualified import of " <> mark mn <> " as " <> mark q <> " is redundant"
+ msg = maybe unqualified msg'
+ in line $ msg qualifier
renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:"
@@ -1190,11 +1187,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
printRow f t = markCodeBox $ indent $ f prettyDepth t
-- If both rows are not empty, print them as diffs
+ -- If verbose print all rows else only print unique rows
printRows :: Type a -> Type a -> (Box.Box, Box.Box)
- printRows r1@RCons{} r2@RCons{} = let
- (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2)
- in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2)
- printRows r1 r2 = (printRow typeAsBox r1, printRow typeAsBox r2)
+ printRows r1 r2 = case (full, r1, r2) of
+ (True, _ , _) -> (printRow typeAsBox r1, printRow typeAsBox r2)
+
+ (_, RCons{}, RCons{}) ->
+ let (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2)
+ in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2)
+
+ (_, _, _) -> (printRow typeAsBox r1, printRow typeAsBox r2)
+
-- Keep the unique labels only
filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a)
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 3aa8bf6..7b1bbf0 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -279,7 +279,7 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit =
isMatch _ _ = False
unused :: m Bool
- unused = warn (UnusedImport mni)
+ unused = warn (UnusedImport mni qualifierName)
warn :: SimpleErrorMessage -> m Bool
warn err = tell (errorMessage' ss err) >> return True
@@ -373,6 +373,7 @@ runDeclRef (ValueOpRef _ op) = Just $ ValOpName op
runDeclRef (TypeRef _ pn _) = Just $ TyName pn
runDeclRef (TypeOpRef _ op) = Just $ TyOpName op
runDeclRef (TypeClassRef _ pn) = Just $ TyClassName pn
+runDeclRef (KindRef _ pn) = Just $ KiName pn
runDeclRef _ = Nothing
checkDuplicateImports
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index f983266..3008930 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -22,7 +22,7 @@ import Data.Function (on)
import Data.Foldable (for_)
import Data.List (foldl', sortBy)
import qualified Data.List.NonEmpty as NEL
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
@@ -41,6 +41,7 @@ import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import Language.PureScript.Make.BuildPlan
import qualified Language.PureScript.Make.BuildPlan as BuildPlan
+import qualified Language.PureScript.Make.Cache as Cache
import Language.PureScript.Make.Actions as Actions
import Language.PureScript.Make.Monad as Monad
import qualified Language.PureScript.CoreFn as CF
@@ -99,18 +100,19 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file.
--
--- If timestamps have not changed, the externs file can be used to provide the module's types without
--- having to typecheck the module 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.
make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [CST.PartialResult Module]
-> m [ExternsFile]
make ma@MakeActions{..} ms = do
checkModuleNames
+ cacheDb <- readCacheDb
(sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms
- buildPlan <- BuildPlan.construct ma (sorted, graph)
+ (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
for_ toBeRebuilt $ \m -> fork $ do
@@ -122,21 +124,31 @@ make ma@MakeActions{..} ms = do
(deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
-- Wait for all threads to complete, and collect results (and errors).
- results <- BuildPlan.collectResults buildPlan
+ (failures, successes) <-
+ let
+ splitResults = \case
+ BuildJobSucceeded _ exts ->
+ Right exts
+ BuildJobFailed errs ->
+ Left errs
+ BuildJobSkipped ->
+ Left mempty
+ in
+ M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
+
+ -- Write the updated build cache database to disk
+ writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
-- All threads have completed, rethrow any caught errors.
- let errors = mapMaybe buildJobFailure $ M.elems results
+ let errors = M.elems failures
unless (null errors) $ throwError (mconcat errors)
-- 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 =
- snd
- . fromMaybe (internalError "make: module's build job did not succeed")
- . buildJobSuccess
- . fromMaybe (internalError "make: module not found in results")
- $ M.lookup mn results
+ fromMaybe (internalError "make: module not found in results")
+ $ M.lookup mn successes
return (map (lookupResult . getModuleName . CST.resPartial) sorted)
where
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 8b54765..a8f6318 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -16,7 +16,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 (encode)
+import qualified Data.Aeson as Aeson
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy as LB
@@ -25,7 +25,7 @@ import Data.Either (partitionEithers)
import Data.Foldable (for_, minimum)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -44,6 +44,7 @@ import qualified Language.PureScript.CST as CST
import qualified Language.PureScript.Docs.Types as Docs
import Language.PureScript.Errors
import Language.PureScript.Make.Monad
+import Language.PureScript.Make.Cache
import Language.PureScript.Names
import Language.PureScript.Names (runModuleName, ModuleName)
import Language.PureScript.Options hiding (codegenTargets)
@@ -51,8 +52,8 @@ import Language.PureScript.Pretty.Common (SMap(..))
import qualified Paths_purescript as Paths
import SourceMap
import SourceMap.Types
-import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
-import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
+import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>), makeRelative, splitPath, normalise)
-- | Determines when to rebuild a module
data RebuildPolicy
@@ -83,10 +84,10 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule
--
-- * The details of how files are read/written etc.
data MakeActions m = MakeActions
- { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
- -- ^ Get the timestamp for the input file(s) for a module. If there are multiple
- -- files (@.purs@ and foreign files, for example) the timestamp should be for
- -- the most recently modified file.
+ { getInputTimestampsAndHashes :: ModuleName -> m (Either RebuildPolicy (M.Map FilePath (UTCTime, m ContentHash)))
+ -- ^ Get the timestamps and content hashes for the input files for a module.
+ -- The content hash is returned as a monadic action so that the file does not
+ -- have to be read if it's not necessary.
, getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
-- ^ Get the timestamp for the output files for a module. This should be the
-- timestamp for the oldest modified file, or 'Nothing' if any of the required
@@ -100,6 +101,12 @@ data MakeActions m = MakeActions
-- ^ Check ffi and print it in the output directory.
, progress :: ProgressMessage -> m ()
-- ^ Respond to a progress update.
+ , readCacheDb :: m CacheDb
+ -- ^ Read the cache database (which contains timestamps and hashes for input
+ -- files) from some external source, e.g. a file on disk.
+ , writeCacheDb :: CacheDb -> m ()
+ -- ^ Write the given cache database to some external source (e.g. a file on
+ -- disk).
}
-- | A set of make actions that read and write modules from the given directory.
@@ -114,15 +121,24 @@ buildMakeActions
-- ^ Generate a prefix comment?
-> MakeActions Make
buildMakeActions outputDir filePathMap foreigns usePrefix =
- MakeActions getInputTimestamp getOutputTimestamp readExterns codegen ffiCodegen progress
+ MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb
where
- getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
- getInputTimestamp mn = do
+ getInputTimestampsAndHashes
+ :: ModuleName
+ -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash)))
+ getInputTimestampsAndHashes mn = do
let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
- e1 <- traverse getTimestamp path
- fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
- return $ fmap (max fPath) e1
+ case path of
+ Left policy ->
+ return (Left policy)
+ Right filePath -> do
+ let inputPaths = filePath : maybeToList (M.lookup mn foreigns)
+ getInfo fp = do
+ ts <- getTimestamp fp
+ return (ts, hash <$> readTextFile fp)
+ pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
+ return $ Right $ M.fromList pathsWithInfo
outputFilename :: ModuleName -> String -> FilePath
outputFilename mn fn =
@@ -140,7 +156,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
getOutputTimestamp mn = do
codegenTargets <- asks optionsCodegenTargets
let outputPaths = [outputFilename mn "externs.json"] <> fmap (targetFilename mn) (S.toList codegenTargets)
- timestamps <- traverse getTimestamp outputPaths
+ timestamps <- traverse getTimestampMaybe outputPaths
pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps
readExterns :: ModuleName -> Make (FilePath, Externs)
@@ -156,7 +172,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
when (S.member CoreFn codegenTargets) $ do
let coreFnFile = targetFilename mn CoreFn
json = CFJ.moduleToJSON Paths.version m
- lift $ writeTextFile coreFnFile (encode json)
+ lift $ writeTextFile coreFnFile (Aeson.encode json)
when (S.member JS codegenTargets) $ do
foreignInclude <- case mn `M.lookup` foreigns of
Just _
@@ -167,7 +183,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
| otherwise -> return Nothing
rawJs <- J.moduleToJs m foreignInclude
- dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
+ dir <- lift $ makeIO "get the current directory" getCurrentDirectory
let sourceMaps = S.member JSSourceMap codegenTargets
(pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
jsFile = targetFilename mn JS
@@ -179,7 +195,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)
when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
when (S.member Docs codegenTargets) $ do
- lift $ writeTextFile (outputFilename mn "docs.json") (encode docs)
+ lift $ writeTextFile (outputFilename mn "docs.json") (Aeson.encode docs)
ffiCodegen :: CF.Module CF.Ann -> Make ()
ffiCodegen m = do
@@ -212,7 +228,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
}) mappings
}
let mapping = generate rawMapping
- writeTextFile mapFile (encode mapping)
+ writeTextFile mapFile (Aeson.encode mapping)
where
add :: Int -> Int -> SourcePos -> SourcePos
add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
@@ -224,24 +240,17 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
requiresForeign :: CF.Module a -> Bool
requiresForeign = not . null . CF.moduleForeign
- getTimestamp :: FilePath -> Make (Maybe UTCTime)
- getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
- exists <- doesFileExist path
- if exists
- then Just <$> getModificationTime path
- else pure Nothing
-
- writeTextFile :: FilePath -> B.ByteString -> Make ()
- writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
- mkdirp path
- B.writeFile path text
- where
- mkdirp :: FilePath -> IO ()
- mkdirp = createDirectoryIfMissing True . takeDirectory
-
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage
+ readCacheDb :: Make CacheDb
+ readCacheDb = fmap (fromMaybe mempty) $ readJSONFile cacheDbFile
+
+ writeCacheDb :: CacheDb -> Make ()
+ writeCacheDb = writeJSONFile cacheDbFile
+
+ cacheDbFile = outputDir </> "cache-db.json"
+
-- | Check that the declarations in a given PureScript module match with those
-- in its corresponding foreign module.
checkForeignDecls :: CF.Module ann -> FilePath -> Make ()
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index 7e4d81e..ebbe50d 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -15,12 +15,11 @@ import Prelude
import Control.Concurrent.Async.Lifted as A
import Control.Concurrent.Lifted as C
import Control.Monad hiding (sequence)
-import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Foldable (foldl')
import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.Time.Clock (UTCTime)
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -28,6 +27,7 @@ import qualified Language.PureScript.CST as CST
import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Make.Actions as Actions
+import Language.PureScript.Make.Cache
import Language.PureScript.Names (ModuleName)
-- | The BuildPlan tracks information about our build progress, and holds all
@@ -65,6 +65,20 @@ buildJobFailure :: BuildJobResult -> Maybe MultipleErrors
buildJobFailure (BuildJobFailed errors) = Just errors
buildJobFailure _ = 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
+ -- ^ 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.
+ }
+
-- | 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
@@ -115,32 +129,67 @@ getResult buildPlan moduleName =
construct
:: forall m. (Monad m, MonadBaseControl IO m)
=> MakeActions m
+ -> CacheDb
-> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
- -> m BuildPlan
-construct MakeActions{..} (sorted, graph) = do
- prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern
- let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted
- buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt)
- pure $ BuildPlan prebuilt buildJobs
+ -> m (BuildPlan, CacheDb)
+construct MakeActions{..} cacheDb (sorted, graph) = 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
+ pure
+ ( BuildPlan prebuilt buildJobs
+ , let
+ update = flip $ \s ->
+ M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
+ in
+ foldl' update cacheDb rebuildStatuses
+ )
where
makeBuildJob prev moduleName = do
buildJob <- BuildJob <$> C.newEmptyMVar
pure (M.insert moduleName buildJob prev)
- findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt))
- findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do
- inputTimestamp <- lift $ getInputTimestamp moduleName
- (rebuildNever, existingTimestamp) <-
- case inputTimestamp of
- Left RebuildNever ->
- fmap (True,) $ MaybeT $ getOutputTimestamp moduleName
- Right (Just t1) -> do
- outputTimestamp <- MaybeT $ getOutputTimestamp moduleName
- guard (t1 < outputTimestamp)
- pure (False, outputTimestamp)
- _ -> mzero
- externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
- pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile)
+ getRebuildStatus :: ModuleName -> m RebuildStatus
+ getRebuildStatus moduleName = do
+ inputInfo <- getInputTimestampsAndHashes moduleName
+ case inputInfo of
+ Left RebuildNever -> do
+ prebuilt <- findExistingExtern moduleName
+ pure (RebuildStatus
+ { statusModuleName = moduleName
+ , statusRebuildNever = True
+ , statusPrebuilt = prebuilt
+ , statusNewCacheInfo = Nothing
+ })
+ Left RebuildAlways -> do
+ pure (RebuildStatus
+ { statusModuleName = moduleName
+ , statusRebuildNever = False
+ , statusPrebuilt = Nothing
+ , statusNewCacheInfo = Nothing
+ })
+ Right cacheInfo -> do
+ (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cacheInfo
+ prebuilt <-
+ if isUpToDate
+ then findExistingExtern moduleName
+ else pure Nothing
+ pure (RebuildStatus
+ { statusModuleName = moduleName
+ , statusRebuildNever = False
+ , statusPrebuilt = prebuilt
+ , statusNewCacheInfo = Just newCacheInfo
+ })
+
+ findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
+ findExistingExtern moduleName = runMaybeT $ do
+ timestamp <- MaybeT $ getOutputTimestamp moduleName
+ externs <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
+ pure (Prebuilt timestamp externs)
collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
collectPrebuiltModules prev (moduleName, rebuildNever, pb)
diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs
new file mode 100644
index 0000000..337ee2d
--- /dev/null
+++ b/src/Language/PureScript/Make/Cache.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Language.PureScript.Make.Cache
+ ( ContentHash
+ , hash
+ , CacheDb
+ , CacheInfo
+ , checkChanged
+ , removeModules
+ ) where
+
+import Prelude
+
+import Control.Category ((>>>))
+import Control.Monad ((>=>))
+import Crypto.Hash (hashlazy, HashAlgorithm, Digest, SHA512, digestFromByteString)
+import qualified Data.Aeson as Aeson
+import Data.Align (align)
+import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Data.Monoid (All(..))
+import Data.Set (Set)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.These (These(..))
+import Data.Time.Clock (UTCTime)
+import Data.Traversable (for)
+
+import Language.PureScript.Names (ModuleName)
+
+digestToHex :: Digest a -> Text
+digestToHex = decodeUtf8 . convertToBase Base16
+
+digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a)
+digestFromHex =
+ encodeUtf8
+ >>> either (const Nothing) Just . convertFromBase Base16
+ >=> (digestFromByteString :: BS.ByteString -> Maybe (Digest a))
+
+-- | Defines the hash algorithm we use for cache invalidation of input files.
+newtype ContentHash = ContentHash
+ { unContentHash :: Digest SHA512 }
+ deriving (Show, Eq, Ord)
+
+instance Aeson.ToJSON ContentHash where
+ toJSON = Aeson.toJSON . digestToHex . unContentHash
+
+instance Aeson.FromJSON ContentHash where
+ parseJSON x = do
+ str <- Aeson.parseJSON x
+ case digestFromHex str of
+ Just digest ->
+ pure $ ContentHash digest
+ Nothing ->
+ fail "Unable to decode ContentHash"
+
+hash :: BSL.ByteString -> ContentHash
+hash = ContentHash . hashlazy
+
+type CacheDb = Map ModuleName CacheInfo
+
+-- | A CacheInfo contains all of the information we need to store about a
+-- particular module in the cache database.
+newtype CacheInfo = CacheInfo
+ { unCacheInfo :: Map FilePath (UTCTime, ContentHash) }
+ deriving stock (Show)
+ deriving newtype (Eq, Ord, Semigroup, Monoid, Aeson.FromJSON, Aeson.ToJSON)
+
+-- | Given a module name, and a map containing the associated input files
+-- together with current metadata i.e. timestamps and hashes, check whether the
+-- input files have changed, based on comparing with the database stored in the
+-- monadic state.
+--
+-- The CacheInfo in the return value should be stored in the cache for future
+-- builds.
+--
+-- The Bool in the return value indicates whether it is safe to use existing
+-- build artifacts for this module, at least based on the timestamps and hashes
+-- of the module's input files.
+--
+-- If the timestamps are the same as those in the database, assume the file is
+-- unchanged, and return True without checking hashes.
+--
+-- If any of the timestamps differ from what is in the database, check the
+-- hashes of those files. In this case, update the database with any changed
+-- timestamps and hashes, and return True if and only if all of the hashes are
+-- unchanged.
+checkChanged
+ :: Monad m
+ => CacheDb
+ -> ModuleName
+ -> Map FilePath (UTCTime, m ContentHash)
+ -> m (CacheInfo, Bool)
+checkChanged cacheDb mn currentInfo = do
+ let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb)
+ (newInfo, isUpToDate) <-
+ fmap mconcat $
+ for (Map.toList (align dbInfo currentInfo)) $ \(fp, aligned) -> do
+ case aligned of
+ This _ -> do
+ -- One of the input files listed in the cache no longer exists;
+ -- remove that file from the cache and note that the module needs
+ -- rebuilding
+ pure (Map.empty, All False)
+ That (timestamp, getHash) -> do
+ -- The module has a new input file; add it to the cache and
+ -- note that the module needs rebuilding.
+ newHash <- getHash
+ pure (Map.singleton fp (timestamp, newHash), All False)
+ These db@(dbTimestamp, _) (newTimestamp, _) | dbTimestamp == newTimestamp -> do
+ -- This file exists both currently and in the cache database,
+ -- and the timestamp is unchanged, so we skip checking the
+ -- hash.
+ pure (Map.singleton fp db, mempty)
+ These (_, dbHash) (newTimestamp, getHash) -> do
+ -- This file exists both currently and in the cache database,
+ -- but the timestamp has changed, so we need to check the hash.
+ newHash <- getHash
+ pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash))
+
+ pure (CacheInfo newInfo, getAll isUpToDate)
+
+-- | Remove any modules from the given set from the cache database; used when
+-- they failed to build.
+removeModules :: Set ModuleName -> CacheDb -> CacheDb
+removeModules moduleNames = flip Map.withoutKeys moduleNames
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index bbc737e..6fe38f3 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -5,11 +5,19 @@ module Language.PureScript.Make.Monad
Make(..)
, runMake
, makeIO
+ , getTimestamp
+ , getTimestampMaybe
, readTextFile
+ , readTextFileMaybe
+ , readJSONFile
+ , writeTextFile
+ , writeJSONFile
) where
import Prelude
+import Control.Exception (tryJust)
+import Control.Monad (join, guard)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class
@@ -18,11 +26,17 @@ import Control.Monad.Reader (MonadReader(..), ReaderT(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Except
import Control.Monad.Writer.Class (MonadWriter(..))
+import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as B
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Time.Clock (UTCTime)
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Options
-import System.IO.Error (tryIOError)
+import System.Directory (createDirectoryIfMissing, getModificationTime)
+import System.FilePath (takeDirectory)
+import System.IO.Error (tryIOError, isDoesNotExistError)
-- | A monad for running make actions
newtype Make a = Make
@@ -41,14 +55,71 @@ instance MonadBaseControl IO Make where
runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
--- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should
--- be rendered as 'ErrorMessage' values.
-makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
-makeIO f io = do
+-- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
+-- describe what we were trying to do; it is used for rendering errors in the
+-- case that an IOException is thrown.
+makeIO :: Text -> IO a -> Make a
+makeIO description io = do
e <- liftIO $ tryIOError io
- either (throwError . singleError . f) return e
+ either (throwError . singleError . ErrorMessage [] . FileIOError description) return e
+
+-- | Get a file's modification time in the 'Make' monad, capturing any errors
+-- using the 'MonadError' instance.
+getTimestamp :: FilePath -> Make UTCTime
+getTimestamp path =
+ makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path
+
+-- | Get a file's modification time in the 'Make' monad, returning Nothing if
+-- the file does not exist.
+getTimestampMaybe :: FilePath -> Make (Maybe UTCTime)
+getTimestampMaybe path =
+ makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path
-- | Read a text file in the 'Make' monad, capturing any errors using the
-- 'MonadError' instance.
readTextFile :: FilePath -> Make B.ByteString
-readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
+readTextFile path =
+ makeIO ("read file: " <> Text.pack path) $ B.readFile path
+
+-- | Read a text file in the 'Make' monad, or return 'Nothing' if the file does
+-- not exist. Errors are captured using the 'MonadError' instance.
+readTextFileMaybe :: FilePath -> Make (Maybe B.ByteString)
+readTextFileMaybe path =
+ makeIO ("read file: " <> Text.pack path) $ catchDoesNotExist $ B.readFile path
+
+-- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does
+-- not exist or could not be parsed. Errors are captured using the 'MonadError'
+-- instance.
+readJSONFile :: Aeson.FromJSON a => FilePath -> Make (Maybe a)
+readJSONFile path =
+ makeIO ("read JSON file: " <> Text.pack path) $ do
+ r <- catchDoesNotExist $ Aeson.decodeFileStrict' path
+ return $ join r
+
+-- | If the provided action threw an 'isDoesNotExist' error, catch it and
+-- return Nothing. Otherwise return Just the result of the inner action.
+catchDoesNotExist :: IO a -> IO (Maybe a)
+catchDoesNotExist inner = do
+ r <- tryJust (guard . isDoesNotExistError) inner
+ case r of
+ Left () ->
+ return Nothing
+ Right x ->
+ return (Just x)
+
+-- | Write a text file in the 'Make' monad, capturing any errors using the
+-- 'MonadError' instance.
+writeTextFile :: FilePath -> B.ByteString -> Make ()
+writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do
+ createParentDirectory path
+ B.writeFile path text
+
+-- | Write a JSON file in the 'Make' monad, capturing any errors using the
+-- 'MonadError' instance.
+writeJSONFile :: Aeson.ToJSON a => FilePath -> a -> Make ()
+writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do
+ createParentDirectory path
+ Aeson.encodeFile path value
+
+createParentDirectory :: FilePath -> IO ()
+createParentDirectory = createDirectoryIfMissing True . takeDirectory
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index e2327c1..5f8afd7 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -12,6 +12,7 @@ import Prelude.Compat
import Control.Monad.Supply.Class
import Control.DeepSeq (NFData)
+import Data.Functor.Contravariant (contramap)
import GHC.Generics (Generic)
import Data.Aeson
@@ -243,3 +244,9 @@ isQualifiedWith _ _ = False
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)
+
+instance ToJSONKey ModuleName where
+ toJSONKey = contramap runModuleName toJSONKey
+
+instance FromJSONKey ModuleName where
+ fromJSONKey = fmap moduleNameFromString fromJSONKey
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index 4253709..f4e5298 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -32,10 +32,9 @@ findImports
-> M.Map ModuleName [ImportDef]
findImports = foldr go M.empty
where
- go (ImportDeclaration (pos, _) mn typ qual) result =
- let imp = (pos, typ, qual)
- in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result
- go _ result = result
+ go (ImportDeclaration (pos, _) mn typ qual) =
+ M.alter (return . ((pos, typ, qual) :) . fromMaybe []) mn
+ go _ = id
-- |
-- Constructs a set of imports for a module.
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index e449135..b0bc93d 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -173,6 +173,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
constrain cs ty = foldr srcConstrainedType ty (map (\(_, _, x) -> x) cs)
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
+
tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts
isHoleError :: ErrorMessage -> Bool
generated by cgit v0.10.2 at 2021-03-07 08:06:22 (GMT)