{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} module Axel.Monad.FileSystem where import Prelude hiding (readFile, writeFile) import qualified Prelude (readFile, writeFile) import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Identity (IdentityT) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe (MaybeT) import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST) import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST) import Control.Monad.Trans.Reader (ReaderT) import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT) import qualified Control.Monad.Trans.State.Strict as StrictState (StateT) import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT) import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT) import qualified System.Directory ( copyFile , createDirectoryIfMissing , doesDirectoryExist , getCurrentDirectory , getDirectoryContents , getTemporaryDirectory , removeFile , setCurrentDirectory ) import System.FilePath (()) import qualified System.IO.Strict as S (readFile) class (Monad m) => MonadFileSystem m where copyFile :: FilePath -> FilePath -> m () default copyFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> FilePath -> m () copyFile src dest = lift $ copyFile src dest createDirectoryIfMissing :: Bool -> FilePath -> m () default createDirectoryIfMissing :: ( MonadTrans t , MonadFileSystem m' , m ~ t m' ) => Bool -> FilePath -> m () createDirectoryIfMissing createParents path = lift $ createDirectoryIfMissing createParents path doesDirectoryExist :: FilePath -> m Bool default doesDirectoryExist :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m Bool doesDirectoryExist = lift . doesDirectoryExist getCurrentDirectory :: m FilePath default getCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => m FilePath getCurrentDirectory = lift getCurrentDirectory getDirectoryContents :: FilePath -> m [FilePath] default getDirectoryContents :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m [FilePath] getDirectoryContents = lift . getDirectoryContents getTemporaryDirectory :: m FilePath default getTemporaryDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => m FilePath getTemporaryDirectory = lift getTemporaryDirectory readFile :: FilePath -> m String default readFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m String readFile = lift . readFile removeFile :: FilePath -> m () default removeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m () removeFile = lift . removeFile setCurrentDirectory :: FilePath -> m () default setCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m () setCurrentDirectory = lift . setCurrentDirectory writeFile :: FilePath -> String -> m () default writeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => String -> FilePath -> m () writeFile path contents = lift $ writeFile path contents instance (MonadFileSystem m) => MonadFileSystem (ContT r m) instance (MonadFileSystem m) => MonadFileSystem (ExceptT e m) instance (MonadFileSystem m) => MonadFileSystem (IdentityT m) instance (MonadFileSystem m) => MonadFileSystem (MaybeT m) instance (MonadFileSystem m) => MonadFileSystem (ReaderT r m) instance (Monoid w, MonadFileSystem m) => MonadFileSystem (LazyRWS.RWST r w s m) instance (Monoid w, MonadFileSystem m) => MonadFileSystem (StrictRWS.RWST r w s m) instance (MonadFileSystem m) => MonadFileSystem (LazyState.StateT s m) instance (MonadFileSystem m) => MonadFileSystem (StrictState.StateT s m) instance (Monoid w, MonadFileSystem m) => MonadFileSystem (LazyWriter.WriterT w m) instance (Monoid w, MonadFileSystem m) => MonadFileSystem (StrictWriter.WriterT w m) instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadFileSystem m where copyFile :: FilePath -> FilePath -> m () copyFile src dest = liftIO $ System.Directory.copyFile src dest createDirectoryIfMissing :: Bool -> FilePath -> m () createDirectoryIfMissing createParentDirs path = liftIO $ System.Directory.createDirectoryIfMissing createParentDirs path doesDirectoryExist :: FilePath -> m Bool doesDirectoryExist = liftIO . System.Directory.doesDirectoryExist getCurrentDirectory :: m FilePath getCurrentDirectory = liftIO System.Directory.getCurrentDirectory getDirectoryContents :: FilePath -> m [FilePath] getDirectoryContents = liftIO . System.Directory.getDirectoryContents getTemporaryDirectory :: m FilePath getTemporaryDirectory = liftIO System.Directory.getTemporaryDirectory readFile :: FilePath -> m String readFile = liftIO . S.readFile removeFile :: FilePath -> m () removeFile = liftIO . System.Directory.removeFile setCurrentDirectory :: FilePath -> m () setCurrentDirectory = liftIO . System.Directory.setCurrentDirectory writeFile :: FilePath -> String -> m () writeFile filePath contents = liftIO $ Prelude.writeFile filePath contents -- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html. getDirectoryContentsRec :: (Monad m, MonadFileSystem m) => FilePath -> m [FilePath] getDirectoryContentsRec dir = do names <- getDirectoryContents dir let properNames = filter (`notElem` [".", ".."]) names paths <- forM properNames $ \name -> do let path = dir name isDirectory <- doesDirectoryExist path if isDirectory then getDirectoryContentsRec path else pure [path] pure $ concat paths withCurrentDirectory :: (MonadFileSystem m) => FilePath -> m a -> m a withCurrentDirectory directory f = do originalDirectory <- getCurrentDirectory setCurrentDirectory directory result <- f setCurrentDirectory originalDirectory pure result withTemporaryDirectory :: (MonadFileSystem m) => (FilePath -> m a) -> m a withTemporaryDirectory action = getTemporaryDirectory >>= action