module Language.PureScript.Make.Monad
  ( -- * Implementation of Make API using files on disk
    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)

-- | A monad for running make actions
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

-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
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

-- | 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 :: (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

-- | Get a file's modification time in the 'Make' monad, capturing any errors
-- using the 'MonadError' instance.
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

-- | Get a file's modification time in the 'Make' monad, returning Nothing if
-- the file does not exist.
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

-- | Read a text file strictly in the 'Make' monad, capturing any errors using
-- the 'MonadError' instance.
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

-- | 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 :: (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

-- | Read a Cbor encoded 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.
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)

-- | Read an externs file, returning 'Nothing' if the file does not exist,
-- could not be parsed, or was generated by a different version of the
-- compiler.
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)

-- | 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 :: 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)

-- | Write a text file in the 'Make' monad, capturing any errors using the
-- 'MonadError' instance.
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

-- | Write a JSON file in the 'Make' monad, capturing any errors using the
-- 'MonadError' instance.
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

-- | Copy a file in the 'Make' monad, capturing any errors using the
-- 'MonadError' instance.
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