git.iko.soy/effectful
on 534ceee help sign in
effectful/examples/FileSystem.hs
63 lines 2.0 kB history raw
1module FileSystem
2 ( FileSystem
3 , FsError(..)
4 , readFile
5 , writeFile
6 , runFileSystemIO
7 , runFileSystemPure
8 ) where
10import Control.Monad.Catch
11import Prelude hiding (readFile, writeFile)
12import qualified Control.Exception as E
13import qualified Data.Map.Strict as M
14import qualified System.IO as IO
16import Effective
17import Effective.Error
19-- | Effect for reading and writing files.
20data FileSystem = forall fs. FileSystem
21 { _fs :: fs
22 , _readFile :: forall es. Error FsError :> es => fs -> FilePath -> Eff es String
23 , _writeFile :: forall es. Error FsError :> es => fs -> FilePath -> String -> Eff es fs
24 }
26-- | File system error.
27newtype FsError = FsError String
28 deriving Show
29instance Exception FsError
31----------------------------------------
32-- Operations
34-- | Read contents of a file.
35readFile :: (FileSystem :> es, Error FsError :> es) => FilePath -> Eff es String
36readFile path = readerEffectM $ \FileSystem{..} -> _readFile _fs path
38-- | Write contents to a file.
39writeFile :: (FileSystem :> es, Error FsError :> es) => FilePath -> String -> Eff es ()
40writeFile path contents = stateEffectM $ \FileSystem{..} -> do
41 fs <- _writeFile _fs path contents
42 pure ((), FileSystem { _fs = fs, .. })
44----------------------------------------
45-- Handlers
47runFileSystemIO :: Eff (FileSystem : es) a -> Eff es a
48runFileSystemIO = evalEffect $ FileSystem
49 { _fs = ()
50 , _readFile = \() path -> wrap $ IO.readFile path
51 , _writeFile = \() path contents -> wrap $ IO.writeFile path contents
52 }
53 where
54 wrap m = impureEff_ m `catch` \(e::E.IOException) -> throwError . FsError $ show e
56runFileSystemPure :: M.Map FilePath String -> Eff (FileSystem : es) a -> Eff es a
57runFileSystemPure fs0 = evalEffect $ FileSystem
58 { _fs = fs0
59 , _readFile = \fs path -> case path `M.lookup` fs of
60 Just contents -> pure contents
61 Nothing -> throwError . FsError $ "File not found: " ++ show path
62 , _writeFile = \fs path contents -> pure $ M.insert path contents fs
63 }