{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.FileSystem.Fake ( FileSystem , FileSystemT (..) , FileSystemM , MonadFileSystem , runFileSystemT , evalFileSystemT , execFileSystemT , runFileSystemM , evalFileSystemM , execFileSystemM , readPath , writePath , modifyPath ) where import Control.Applicative (Alternative) import Control.Monad (MonadPlus) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM) import Control.Monad.Cont.Class (MonadCont) import Control.Monad.Except (MonadError) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) import Control.Monad.RWS.Class (MonadRWS, MonadReader, MonadState, MonadWriter) import Control.Monad.State.Strict (StateT, gets, modify', runStateT) import Control.Monad.Trans (MonadTrans) import Data.Functor.Identity (Identity, runIdentity) import qualified Data.Map.Strict as M import System.IO.Error (doesNotExistErrorType, mkIOError) #if __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail (MonadFail) #endif type FileSystem contents = M.Map String contents newtype FileSystemT contents m a = FileSystemT { unFileSystemT :: StateT (FileSystem contents) m a } deriving ( Functor , Applicative , Monad , MonadTrans , MonadIO , Alternative , MonadFix , MonadFail , MonadPlus , MonadState (FileSystem contents) , MonadReader r , MonadWriter w , MonadRWS r w (FileSystem contents) , MonadCont , MonadError e , MonadCatch , MonadMask , MonadThrow ) type FileSystemM contents = FileSystemT contents Identity type MonadFileSystem contents = MonadState (FileSystem contents) runFileSystemT :: FileSystemT contents m a -> FileSystem contents -> m (a, FileSystem contents) runFileSystemT (FileSystemT act) = runStateT act evalFileSystemT :: Functor f => FileSystemT contents f a -> FileSystem contents -> f a evalFileSystemT act = fmap fst . runFileSystemT act execFileSystemT :: Functor f => FileSystemT contents f a -> FileSystem contents -> f (FileSystem contents) execFileSystemT act = fmap snd . runFileSystemT act runFileSystemM :: FileSystemM contents a -> FileSystem contents -> (a, FileSystem contents) runFileSystemM act = runIdentity . runFileSystemT act evalFileSystemM :: FileSystemM contents a -> FileSystem contents -> a evalFileSystemM act = fst . runFileSystemM act execFileSystemM :: FileSystemM contents a -> FileSystem contents -> FileSystem contents execFileSystemM act = snd . runFileSystemM act readPath :: (MonadThrow m, MonadFileSystem contents m) => FilePath -> m contents readPath path = do mContent <- gets $ M.lookup path case mContent of Just content -> return content Nothing -> throwM . mkIOError doesNotExistErrorType "openFile" Nothing $ Just path writePath :: MonadFileSystem contents m => FilePath -> contents -> m () writePath path = modify' . M.insert path modifyPath :: MonadFileSystem contents m => FilePath -> (Maybe contents -> Maybe contents) -> m () modifyPath path f = modify' $ M.alter f path