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