module Data.Conduit.VFS.Pure
( PureVFS
, runPureVFS
, runPureVFS'
, runPureVFS_
) where
import Control.Monad.Trans.State.Lazy
import ClassyPrelude hiding (ByteString, handle, hash)
import Data.Conduit.VFS.Import
import qualified Data.HashMap.Lazy as HashMap
import Data.HashMap.Lazy (HashMap)
import Control.Monad.Extra (whenJust, maybeM)
import Control.Monad.Fail (MonadFail)
import System.FilePath (splitPath, (</>))
import qualified Data.Text as Text
data PNode
= PNodeDir (HashMap Text PNode)
| PNodeFile ByteString
newtype PureVFS m a = PureVFS
{ unPVFS :: StateT PNode m a }
deriving (Applicative, Functor, MonadFail, Monad, MonadTrans)
runPureVFS :: PureVFS m a -> m (a, PNode)
runPureVFS pvfs = runStateT (unPVFS pvfs) (PNodeDir mempty)
{-# INLINE runPureVFS #-}
runPureVFS' :: (Monad m) => PureVFS m a -> m PNode
runPureVFS' pvfs = execStateT (unPVFS pvfs) (PNodeDir mempty)
{-# INLINE runPureVFS' #-}
runPureVFS_ :: (Monad m) => PureVFS m a -> m ()
runPureVFS_ = void . runPureVFS
{-# INLINE runPureVFS_ #-}
getRoot :: (Monad m) => PureVFS m PNode
getRoot = PureVFS get
{-# INLINE getRoot #-}
setRoot :: (Monad m) => PNode -> PureVFS m PNode
setRoot newRoot = setRoot_ newRoot >> return newRoot
{-# INLINE setRoot #-}
setRoot_ :: (Monad m) => PNode -> PureVFS m ()
setRoot_ = PureVFS . put
{-# INLINE setRoot_ #-}
modifyRoot_ :: (Monad m) => (PNode -> PureVFS m PNode) -> PureVFS m ()
modifyRoot_ f = getRoot >>= f >>= PureVFS . put
{-# INLINE modifyRoot_ #-}
modifyRoot :: (Monad m) => (PNode -> PureVFS m PNode) -> PureVFS m PNode
modifyRoot f = modifyRoot_ f >> getRoot
{-# INLINE modifyRoot #-}
getNodeC :: (Monad m) => FilePath -> ConduitT i o (PureVFS m) (Maybe PNode)
getNodeC = lift . getNode
{-# INLINE getNodeC #-}
getNode :: (Monad m) => FilePath -> PureVFS m (Maybe PNode)
getNode filepath = loop (splitPath filepath) <$> getRoot
where
loop [] _ = Nothing
loop _ (PNodeFile _) = Nothing
loop [filename] (PNodeDir hash) = HashMap.lookup (Text.pack filename) hash
loop (dirname:rest) (PNodeDir hash) = HashMap.lookup (Text.pack dirname) hash >>= loop rest
{-# INLINE getNode #-}
modifyNodeC_ :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> ConduitT i o (PureVFS m) ()
modifyNodeC_ filepath f = lift $ modifyNode_ filepath f
{-# INLINE modifyNodeC_ #-}
modifyNode_ :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> PureVFS m ()
modifyNode_ filepath f = modifyRoot_ $ loop (splitPath filepath)
where
loop [] node = return node
loop _ file@(PNodeFile _) = return file
loop (nodename:rest) dir@(PNodeDir hash) = case HashMap.lookup (Text.pack nodename) hash of
Nothing -> case rest of
[] ->
maybeM
(return dir)
(\result -> return . PNodeDir $ HashMap.insert (Text.pack nodename) result hash)
(f (Just dir))
(restHead:restTail) ->
loop restTail (PNodeDir mempty) >>= \result ->
return . PNodeDir $ HashMap.insert (Text.pack nodename) (PNodeDir $ HashMap.singleton (Text.pack restHead) result) hash
(Just node) -> loop rest node >>= \result -> return $ PNodeDir $ HashMap.insert (Text.pack nodename) result hash
{-# INLINEABLE modifyNode_ #-}
modifyNodeC :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> ConduitT i o (PureVFS m) (Maybe PNode)
modifyNodeC filepath f = lift $ modifyNode filepath f
{-# INLINE modifyNodeC #-}
modifyNode :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> PureVFS m (Maybe PNode)
modifyNode filepath f = modifyNode_ filepath f >> getNode filepath
{-# INLINE modifyNode #-}
instance (Monad m) => ReadVFSC (PureVFS m) where
vfsTypeC = awaitForever $ \filepath -> do
maybeNode <- getNodeC filepath
yield (filepath, toType <$> maybeNode)
where
toType (PNodeDir _) = VDirectory
toType (PNodeFile _) = VFile
{-# INLINE vfsTypeC #-}
vfsContentsC = awaitForever $ \filepath -> do
maybeResult <- getNodeC filepath
whenJust maybeResult $ \case
(PNodeFile bytes) -> yield (filepath, bytes)
(PNodeDir _) -> return ()
{-# INLINE vfsContentsC #-}
vfsChildrenC = awaitForever $ \filepath -> do
maybeNode <- getNodeC filepath
case maybeNode of
Nothing -> yield filepath
(Just (PNodeFile _)) -> yield filepath
(Just (PNodeDir hash)) -> yieldMany $ (filepath </>) . Text.unpack <$> HashMap.keys hash
{-# INLINE vfsChildrenC #-}
instance (Monad m) => WriteVFSC (PureVFS m) where
vfsWriteSink = awaitForever $ \(filepath, bs) -> modifyNodeC_ filepath (const . return . Just $ PNodeFile bs)
{-# INLINE vfsWriteSink #-}
vfsRemoveSink = awaitForever $ flip modifyNodeC_ (const $ return Nothing)
{-# INLINE vfsRemoveSink #-}
instance (Monad m) => VFSC (PureVFS m)