{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.PureScript.Make.Monad
(
Make(..)
, runMake
, makeIO
, getTimestamp
, getTimestampMaybe
, readTextFile
, readJSONFile
, readExternsFile
, hashFile
, writeTextFile
, writeJSONFile
, copyFile
) 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
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 :: Text -> IO a -> Make a
makeIO description io = do
e <- liftIO $ tryIOError io
either (throwError . singleError . ErrorMessage [] . FileIOError description) return e
getTimestamp :: FilePath -> Make UTCTime
getTimestamp path =
makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path
getTimestampMaybe :: FilePath -> Make (Maybe UTCTime)
getTimestampMaybe path =
makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path
readTextFile :: FilePath -> Make Text
readTextFile path =
makeIO ("read file: " <> Text.pack path) $
readUTF8FileT path
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
readExternsFile :: FilePath -> Make (Maybe ExternsFile)
readExternsFile path = do
mexterns <- readJSONFile path
return $ do
externs <- mexterns
guard $ externsIsCurrentVersion externs
return externs
hashFile :: FilePath -> Make 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)
writeTextFile :: FilePath -> B.ByteString -> Make ()
writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do
createParentDirectory path
B.writeFile path text
writeJSONFile :: Aeson.ToJSON a => FilePath -> a -> Make ()
writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do
createParentDirectory path
Aeson.encodeFile path value
copyFile :: FilePath -> FilePath -> Make ()
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