{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.PureScript.Make.Monad
(
Make(..)
, runMake
, makeIO
, getTimestamp
, getTimestampMaybe
, readTextFile
, readJSONFile
, readJSONFileIO
, readCborFile
, readCborFileIO
, readExternsFile
, hashFile
, writeTextFile
, writeJSONFile
, writeCborFile
, writeCborFileIO
, copyFile
) where
import Prelude
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as Serialise
import Control.Exception (fromException, tryJust)
import Control.Monad (join, guard)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class
import Control.Monad.Logger
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 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.Externs (ExternsFile, externsIsCurrentVersion)
import Language.PureScript.Make.Cache (ContentHash, hash)
import Language.PureScript.Options
import System.Directory (createDirectoryIfMissing, getModificationTime)
import qualified System.Directory as Directory
import System.FilePath (takeDirectory)
import System.IO.Error (tryIOError, isDoesNotExistError)
import System.IO.UTF8 (readUTF8FileT)
newtype Make a = Make
{ unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
instance MonadBase IO Make where
liftBase = liftIO
instance MonadBaseControl IO Make where
type StM Make a = Either MultipleErrors a
liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
restoreM = Make . restoreM
runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
makeIO :: (MonadIO m, MonadError MultipleErrors m) => Text -> IO a -> m a
makeIO description io = do
res <- liftIO (tryIOError io)
either (throwError . singleError . ErrorMessage [] . FileIOError description) pure res
getTimestamp :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m UTCTime
getTimestamp path =
makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path
getTimestampMaybe :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe UTCTime)
getTimestampMaybe path =
makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path
readTextFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m Text
readTextFile path =
makeIO ("read file: " <> Text.pack path) $
readUTF8FileT path
readJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.FromJSON a => FilePath -> m (Maybe a)
readJSONFile path =
makeIO ("read JSON file: " <> Text.pack path) (readJSONFileIO path)
readJSONFileIO :: Aeson.FromJSON a => FilePath -> IO (Maybe a)
readJSONFileIO path = do
r <- catchDoesNotExist $ Aeson.decodeFileStrict' path
return $ join r
readCborFile :: (MonadIO m, MonadError MultipleErrors m) => Serialise a => FilePath -> m (Maybe a)
readCborFile path =
makeIO ("read Binary file: " <> Text.pack path) (readCborFileIO path)
readCborFileIO :: Serialise a => FilePath -> IO (Maybe a)
readCborFileIO path = do
r <- catchDoesNotExist $ catchDeserialiseFailure $ Serialise.readFileDeserialise path
return (join r)
readExternsFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe ExternsFile)
readExternsFile path = do
mexterns <- readCborFile path
return $ do
externs <- mexterns
guard $ externsIsCurrentVersion externs
return externs
hashFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ContentHash
hashFile path = do
makeIO ("hash file: " <> Text.pack path)
(hash <$> B.readFile path)
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)
catchDeserialiseFailure :: IO a -> IO (Maybe a)
catchDeserialiseFailure inner = do
r <- tryJust fromException inner
case r of
Left (_ :: Serialise.DeserialiseFailure) ->
return Nothing
Right x ->
return (Just x)
writeTextFile :: FilePath -> B.ByteString -> Make ()
writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do
createParentDirectory path
B.writeFile path text
writeJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.ToJSON a => FilePath -> a -> m ()
writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do
createParentDirectory path
Aeson.encodeFile path value
writeCborFile :: (MonadIO m, MonadError MultipleErrors m) => Serialise a => FilePath -> a -> m ()
writeCborFile path value =
makeIO ("write Cbor file: " <> Text.pack path) (writeCborFileIO path value)
writeCborFileIO :: Serialise a => FilePath -> a -> IO ()
writeCborFileIO path value = do
createParentDirectory path
Serialise.writeFileSerialise path value
copyFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> FilePath -> m ()
copyFile src dest =
makeIO ("copy file: " <> Text.pack src <> " -> " <> Text.pack dest) $ do
createParentDirectory dest
Directory.copyFile src dest
createParentDirectory :: FilePath -> IO ()
createParentDirectory = createDirectoryIfMissing True . takeDirectory