Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment