summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Make/Monad.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/PureScript/Make/Monad.hs')
-rw-r--r--src/Language/PureScript/Make/Monad.hs85
1 files changed, 78 insertions, 7 deletions
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