summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Make
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/PureScript/Make')
-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
4 files changed, 322 insertions, 63 deletions
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