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, Exception (displayException))
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 -> Text -> SimpleErrorMessage
FileIOError Text
description forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> String
displayException) 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) =>
String -> m UTCTime
getTimestamp String
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
<> String -> Text
Text.pack String
path) forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationTime String
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) =>
String -> m (Maybe UTCTime)
getTimestampMaybe String
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
<> String -> Text
Text.pack String
path) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
catchDoesNotExist forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationTime String
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) =>
String -> m Text
readTextFile String
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
<> String -> Text
Text.pack String
path) forall a b. (a -> b) -> a -> b
$
    String -> IO Text
readUTF8FileT String
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) =>
String -> m (Maybe a)
readJSONFile String
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
<> String -> Text
Text.pack String
path) (forall a. FromJSON a => String -> IO (Maybe a)
readJSONFileIO String
path)

readJSONFileIO :: Aeson.FromJSON a => FilePath -> IO (Maybe a)
readJSONFileIO :: forall a. FromJSON a => String -> IO (Maybe a)
readJSONFileIO String
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 => String -> IO (Maybe a)
Aeson.decodeFileStrict' String
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) =>
String -> m (Maybe a)
readCborFile String
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
<> String -> Text
Text.pack String
path) (forall a. Serialise a => String -> IO (Maybe a)
readCborFileIO String
path)

readCborFileIO :: Serialise a => FilePath -> IO (Maybe a)
readCborFileIO :: forall a. Serialise a => String -> IO (Maybe a)
readCborFileIO String
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 => String -> IO a
Serialise.readFileDeserialise String
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) =>
String -> m (Maybe ExternsFile)
readExternsFile String
path = do
  Maybe ExternsFile
mexterns <- forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, Serialise a) =>
String -> m (Maybe a)
readCborFile String
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) =>
String -> m ContentHash
hashFile String
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
<> String -> Text
Text.pack String
path)
    (ByteString -> ContentHash
hash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
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 :: String -> ByteString -> Make ()
writeTextFile String
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
<> String -> Text
Text.pack String
path) forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
createParentDirectory String
path
  String -> ByteString -> IO ()
B.writeFile String
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) =>
String -> a -> m ()
writeJSONFile String
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
<> String -> Text
Text.pack String
path) forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
createParentDirectory String
path
  forall a. ToJSON a => String -> a -> IO ()
Aeson.encodeFile String
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) =>
String -> a -> m ()
writeCborFile String
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
<> String -> Text
Text.pack String
path) (forall a. Serialise a => String -> a -> IO ()
writeCborFileIO String
path a
value)

writeCborFileIO :: Serialise a => FilePath -> a -> IO ()
writeCborFileIO :: forall a. Serialise a => String -> a -> IO ()
writeCborFileIO String
path a
value = do
  String -> IO ()
createParentDirectory String
path
  forall a. Serialise a => String -> a -> IO ()
Serialise.writeFileSerialise String
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) =>
String -> String -> m ()
copyFile String
src String
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
<> String -> Text
Text.pack String
src forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
dest) forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
createParentDirectory String
dest
    String -> String -> IO ()
Directory.copyFile String
src String
dest

createParentDirectory :: FilePath -> IO ()
createParentDirectory :: String -> IO ()
createParentDirectory = Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory