Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE AllowAmbiguousTypes #-}
- {-# LANGUAGE ConstrainedClassMethods #-}
- {-# LANGUAGE FlexibleContexts #-}
- {-# LANGUAGE InstanceSigs #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE TypeFamilies #-}
- module FilesystemUtil where
- import qualified Data.ByteString as BS
- import qualified Data.ByteString.Lazy as BSL
- import Data.Map (Map)
- import qualified Data.Map as M
- import qualified Data.Semigroup as SG (Semigroup (..))
- import Data.Set as S
- import Data.Text as T
- import Filesystem
- import qualified Filesystem.Path.CurrentOS as COS
- -- for maps between paths and file contents
- newtype HandleMap = HandleMap (Map String BSL.ByteString) deriving Show
- instance SG.Semigroup HandleMap
- where
- HandleMap a <> HandleMap b = HandleMap (a <> b) -- first overrides second
- instance Monoid HandleMap
- where
- mempty = HandleMap mempty
- -- for maps between paths and file contents-in progress, each bit representing a separate write call
- newtype FileMap = FileMap (Map String BS.ByteString) deriving Show
- instance SG.Semigroup FileMap
- where
- FileMap a <> FileMap b = FileMap $ M.fromList $ a' <> b' <> joined
- where
- ak = S.fromList $ M.keys a
- bk = S.fromList $ M.keys b
- abk = intersection ak bk -- both keys present; we join the values for these.
- a' = (\k -> (k, a M.! k)) <$> (elems $ difference ak abk)
- b' = (\k -> (k, b M.! k)) <$> (elems $ difference bk abk)
- joined = (\k -> (k, a M.! k <> b M.! k)) <$> elems abk
- instance Monoid FileMap
- where
- mempty = FileMap mempty
- ------------------------------------------
- data FSState = FSState { _handles :: HandleMap
- , _files :: FileMap
- } deriving (Show)
- instance SG.Semigroup FSState
- where
- (<>) FSState { _handles = handlesA, _files = filesA }
- FSState { _handles = handlesB, _files = filesB }
- = FSState { _handles = handlesA <> handlesB, _files = filesA <> filesB }
- instance Monoid FSState
- where
- mempty = FSState { _handles = mempty, _files = mempty }
- mappend = (SG.<>)
- newtype FSHandle = FSHandle String
- newtype FSStateMonad a = FSStateMonad a deriving Show
- instance Functor FSStateMonad
- where
- fmap f (FSStateMonad a) = FSStateMonad $ f a
- instance Applicative FSStateMonad
- where
- pure v = FSStateMonad v
- (<*>) (FSStateMonad f) (FSStateMonad a) = FSStateMonad $ f a
- instance Monad FSStateMonad
- where
- FSStateMonad a >>= b = b a
- return = pure
- -----------------------
- -- the generic statement
- class Monad m => MonadWriteHandler m where
- type MWHandle m
- type MWResult m
- withFile :: FilePath -> IOMode -> (MWHandle m -> m r) -> m r
- hPutBSL :: MWHandle m -> BSL.ByteString -> m (MWResult m)
- closeHandles :: MWResult m -> MWResult m
- -- the real filesystem
- instance MonadWriteHandler IO where
- type MWHandle IO = Handle
- type MWResult IO = ()
- hPutBSL = BSL.hPut
- withFile path WriteMode handler = Filesystem.withFile (cosPath path) WriteMode handler
- withFile _ _ _ = error "Read not implemented"
- closeHandles = error "closeHandles on IO: undefined"
- -- the test filesystem
- instance MonadWriteHandler FSStateMonad where
- type MWHandle FSStateMonad = FSHandle
- type MWResult FSStateMonad = FSState
- hPutBSL (FSHandle h) bs = return $ FSState { _files = mempty
- , _handles = HandleMap $ M.fromList [(h, bs)] }
- -- can't uncomment this type annotation because r is not FSState
- --withFile :: FilePath -> IOMode -> (FSHandle -> FSStateMonad FSState) -> FSStateMonad FSState
- withFile path WriteMode handler = do
- completed <- handler $ FSHandle path
- -- can't call this: wrong type.
- -- let _completed' = closeHandles completed
- return completed
- withFile _ _ _ = error "Read not implemented"
- closeHandles :: FSState -> FSState
- closeHandles FSState { _files = fs, _handles = hs} = FSState { _files = fs <> closeFSHandles hs, _handles = mempty }
- where
- closeFSHandles (HandleMap hm) = FileMap $ M.map BSL.toStrict hm
- -----------------------
- closeHandles' :: FSState -> FSState
- closeHandles' FSState { _files = fs, _handles = hs} = FSState { _files = fs <> closeFSHandles hs, _handles = mempty }
- where
- closeFSHandles (HandleMap hm) = FileMap $ M.map BSL.toStrict hm
- cosPath :: FilePath -> COS.FilePath
- cosPath = COS.fromText . T.pack
- -- below here: illustration of use
- writeAHelloFileSayingHi :: MonadWriteHandler m => m (MWResult m)
- writeAHelloFileSayingHi = do
- FilesystemUtil.withFile "hello.txt" WriteMode (\h -> hPutBSL h "hi!")
- runOnRealFS :: IO ()
- runOnRealFS = writeAHelloFileSayingHi
- runTest :: FSStateMonad FSState
- runTest = writeAHelloFileSayingHi
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement