{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Test.FileSystem.Fake
( FileSystem
, MetaHandlers (..)
, FileSystemT (..)
, FileSystemM
, SimplestMetaHandlers
, simplestMetaHandlers
, runFileSystemT
, runFileSystemM
, readFileT
, writeFileT
) where
import Control.Exception (IOException)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.State.Strict (StateT, gets, modify', runStateT)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Functor.Identity (Identity (Identity), runIdentity)
import qualified Data.Map.Strict as M
import qualified Data.Tuple as Tuple
import System.IO.Error (doesNotExistErrorType, mkIOError)
type FileSystem meta contents = M.Map String (meta contents)
data MetaHandlers meta contents m = MetaHandlers
{ unwrapFile :: meta contents -> FileSystemT meta contents m contents
, wrapFile :: contents -> FileSystemT meta contents m (meta contents)
}
type SimplestMetaHandlers contents =
MetaHandlers Identity contents Identity
simplestMetaHandlers :: SimplestMetaHandlers contents
simplestMetaHandlers = MetaHandlers (return . runIdentity) (return . Identity)
newtype FileSystemT meta contents m a =
FileSystemT
(ReaderT
(MetaHandlers meta contents m)
(ExceptT IOException
(StateT (FileSystem meta contents) m)) a)
deriving (Functor, Applicative, Monad)
instance MonadTrans (FileSystemT meta contents) where
lift = FileSystemT . lift . lift . lift
type FileSystemM meta contents = FileSystemT meta contents Identity
runFileSystemM
:: MetaHandlers meta contents Identity
-> FileSystem meta contents
-> FileSystemM meta contents a
-> (FileSystem meta contents, Either IOException a)
runFileSystemM mhs fs =
runIdentity . runFileSystemT mhs fs
runFileSystemT
:: Functor m
=> MetaHandlers meta contents m
-> FileSystem meta contents
-> FileSystemT meta contents m a
-> m (FileSystem meta contents, Either IOException a)
runFileSystemT mhs fs (FileSystemT action) =
Tuple.swap <$> runStateT (runExceptT (runReaderT action mhs)) fs
readFileT :: Monad m => FilePath -> FileSystemT meta contents m contents
readFileT path = do
unwrap <- FileSystemT $ asks unwrapFile
mContent <- FileSystemT $ gets $ M.lookup path
case mContent of
Just content -> unwrap content
_ ->
FileSystemT
$ throwError
$ mkIOError doesNotExistErrorType "openFile" Nothing
$ Just path
writeFileT :: Monad m => FilePath -> contents -> FileSystemT meta contents m ()
writeFileT path contents = do
wrap <- FileSystemT $ asks wrapFile
FileSystemT . modify' . M.insert path =<< wrap contents