module System.Chatty.Filesystem where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import Data.Chatty.Atoms
import Data.List
import Data.Monoid
import qualified Data.Text.IO as TIO
import qualified Data.Text as T
import Text.Chatty.Printer
import Text.Chatty.Scanner
data FSExec a = FSSucc a
| NoPermission
| NotFound
data File m = File {
loadFun :: m (FSExec ()),
saveFun :: m (FSExec ()),
leftBehind :: String,
rightPending :: String
}
newtype Path = MultiPath [PathSpec] deriving (Eq,Ord,Show)
data PathSpec = Path PathRoot [PathSeg] deriving (Eq,Ord,Show)
data PathRoot = Absolute | Relative deriving (Eq,Ord,Show)
data PathSeg = SelParent | SelChild String deriving (Eq,Ord,Show)
type FileA m = Atom (File m)
data Mountpoint m = forall a. Mount {
subMounts :: [Mountpoint m],
mstate :: Atom a,
mpath :: Path,
mopen :: Path -> (Atom a, Path) -> m (FSExec (FileA m))
}
class Monad m => ChFilesystem m where
fopen :: Path -> m (FSExec (FileA m))
fpwd :: m Path
fcd :: Path -> m ()
class Monad m => CanLoad m n where
fload :: FileA n -> m (FSExec ())
class Monad m => CanSave m n where
fsave :: FileA n -> m (FSExec ())
class Monad m => CanMount m n where
fmount :: Mountpoint n -> m ()
data FilePrinterT m a = FilePrinter { runFilePrinterT :: FileA m -> m a }
data FileScannerT m a = FileScanner { runFileScannerT :: FileA m -> m a }
instance Monad m => Monad (FilePrinterT m) where
return a = FilePrinter $ \_ -> return a
m >>= f = FilePrinter $ \d -> do a <- runFilePrinterT m d; runFilePrinterT (f a) d
instance Monad m => Monad (FileScannerT m) where
return a = FileScanner $ \_ -> return a
m >>= f = FileScanner $ \d -> do a <- runFileScannerT m d; runFileScannerT (f a) d
instance Functor f => Functor (FilePrinterT f) where
fmap f a = FilePrinter $ fmap f . runFilePrinterT a
instance (Functor m, Monad m) => Applicative (FilePrinterT m) where
(<*>) = ap
pure = return
instance Functor f => Functor (FileScannerT f) where
fmap f a = FileScanner $ fmap f . runFileScannerT a
instance (Functor m, Monad m) => Applicative (FileScannerT m) where
(<*>) = ap
pure = return
instance MonadTrans FilePrinterT where
lift m = FilePrinter $ \_ -> m
instance MonadTrans FileScannerT where
lift m = FileScanner $ \_ -> m
instance MonadIO m => MonadIO (FilePrinterT m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (FileScannerT m) where
liftIO = lift . liftIO
instance ChAtoms m => ChPrinter (FilePrinterT m) where
mprint s = FilePrinter $ \d -> do
f <- getAtom d
putAtom d f{leftBehind=reverse (take (length s) $ rightPending f) ++ leftBehind f, rightPending=drop (length s) $ rightPending f}
instance ChAtoms m => ChScanner (FileScannerT m) where
mscan1 = FileScanner $ \d -> do
f <- getAtom d
putAtom d f{leftBehind=head (rightPending f) : leftBehind f, rightPending=tail $ rightPending f}
return $ head $ rightPending f
mscanL = FileScanner $ liftM rightPending . getAtom
mscannable = FileScanner $ liftM (not . null . rightPending) . getAtom
mready = mscannable
newtype NullFsT m a = NullFs { runNullFsT :: Path -> [Mountpoint (NullFsT m)] -> m (a, Path, [Mountpoint (NullFsT m)]) }
instance Monad m => Monad (NullFsT m) where
return a = NullFs $ \p ms -> return (a,p,ms)
m >>= f = NullFs $ \p ms -> do (a,p',ms') <- runNullFsT m p ms; runNullFsT (f a) p' ms'
instance Functor f => Functor (NullFsT f) where
fmap f a = NullFs $ \p ms -> fmap (\(a,p,ms) -> (f a,p,ms)) $ runNullFsT a p ms
instance (Functor m, Monad m) => Applicative (NullFsT m) where
(<*>) = ap
pure = return
instance MonadTrans NullFsT where
lift m = NullFs $ \p ms -> do a <- m; return (a,p,ms)
instance MonadIO m => MonadIO (NullFsT m) where
liftIO = lift . liftIO
instance Monad m => ChFilesystem (NullFsT m) where
fpwd = NullFs $ \p ms -> return (p,p,ms)
fopen p = do
ap <- absPath p
p' <- NullFs $ \wd ms -> do
case filter (isPath . snd) $ map (\m -> (m,ap `cmpPath` mpath m)) ms of
[] -> return (NotFound, wd, ms)
(p:_) -> return (FSSucc p, wd, ms)
case p' of
FSSucc (Mount subs st pa op, p') -> op p' (st,pa)
NotFound -> return NotFound
fcd p = NullFs $ \_ ms -> return ((),p,ms)
instance Monad m => CanMount (NullFsT m) (NullFsT m) where
fmount m = NullFs $ \p ms -> return ((),p,m:ms)
absPath :: ChFilesystem m => Path -> m Path
absPath (MultiPath ps) =
liftM (MultiPath . concat) $
forM ps $ \(Path r ps) -> case r of
Absolute -> return [Path Absolute $ rempar ps]
Relative -> do
MultiPath wds <- fpwd
return $ do
Path Absolute wd <- wds
return $ Path Absolute $ rempar (wd++ps)
where
rempar (SelChild _:SelParent:rem) = rempar rem
rempar (a:rem) = a : rempar rem
rempar [] = []
cmpPath' :: [PathSeg] -> [PathSeg] -> Maybe [PathSeg]
cmpPath' ps [] = Just ps
cmpPath' (SelChild a:as) (SelChild b:bs) | a == b = cmpPath' as bs
cmpPath' (SelParent:as) (SelParent:bs) = cmpPath' as bs
cmpPath' _ _ = Nothing
cmpPath :: Path -> Path -> Path
cmpPath (MultiPath as) (MultiPath bs) = MultiPath $ do
Path Absolute a <- as
Path Absolute b <- bs
case a `cmpPath'` b of
Nothing -> []
Just p -> [Path Absolute p]
isPath :: Path -> Bool
isPath (MultiPath p) = not $ null p
path :: String -> Path
path [] = MultiPath []
path ps =
let took s = takeWhile (/='/') s
left s = case drop (length $ took s) s of
[] -> []
(_:cs) -> cs
subparse [] = []
subparse s = case (took s, left s) of
([], []) -> []
([], l) -> subparse l
("..", l) -> SelParent : subparse l
(".", l) -> subparse l
(t, l) -> SelChild t : subparse l
in case head ps of
'/' -> MultiPath [Path Absolute $ subparse $ tail ps]
_ -> MultiPath [Path Relative $ subparse ps]
expandofs :: (ChAtoms m,ChFilesystem m) => m (Mountpoint m)
expandofs = do
a <- newAtom
putAtom a []
return $ Mount [] a (MultiPath []) $ \(MultiPath p) (sta,pa) -> do
fa <- newAtom
let ld = do
st <- getAtom sta
case filter (\(MultiPath x,_) -> not $ null $ intersect x p) st of
[] -> putAtom fa (File ld sv "" "") >> return (FSSucc ())
(_,tx):_ -> putAtom fa (File ld sv "" tx) >> return (FSSucc ())
sv = do
st <- getAtom sta
fi <- getAtom fa
case filter (\(_,(MultiPath x,_)) -> not $ null $ intersect x p) $ zip [1..] st of
[] -> do
putAtom sta ((MultiPath p,reverse (leftBehind fi)++rightPending fi) : st)
return (FSSucc ())
(i,_):_ -> do
putAtom sta (take i st ++ [(MultiPath p,reverse (leftBehind fi)++rightPending fi)] ++ drop (i+1) st)
return (FSSucc ())
putAtom fa $ File ld sv "" ""
return $ FSSucc fa
printerfs :: (ChPrinter m,ChAtoms m,ChFilesystem m) => m (Mountpoint m)
printerfs = do
a <- newAtom
putAtom a ()
return $ Mount [] a (MultiPath []) $ \p _ -> do
fa <- newAtom
let ld = return $ FSSucc ()
sv = do
fi <- getAtom fa
mprint (reverse (leftBehind fi) ++ rightPending fi)
return $ FSSucc ()
putAtom fa $ File ld sv "" ""
return $ FSSucc fa
iomapfs :: (MonadIO m,ChAtoms m) => String -> m (Mountpoint m)
iomapfs fp = do
a <- newAtom
putAtom a ()
return $ Mount [] a (MultiPath []) $ \p _ -> do
fa <- newAtom
let ld = do
tx <- liftIO $ TIO.readFile fp
putAtom fa (File ld sv "" (T.unpack tx))
return $ FSSucc ()
sv = do
f <- getAtom fa
liftIO $ TIO.writeFile fp $ T.pack (reverse (leftBehind f)++rightPending f)
return $ FSSucc ()
putAtom fa $ File ld sv "" ""
return $ FSSucc fa
mount :: (CanMount m m, ChAtoms m, ChFilesystem m) => m (Mountpoint m) -> Path -> m ()
mount mpf p = do
mp <- mpf
fmount mp{mpath=p}
withNullFs :: ChAtoms m => NullFsT m a -> m a
withNullFs m = do
(a,_,_) <- runNullFsT m (path "/") []
return a
withExpandoFs :: (ChAtoms m, ChAtoms (NullFsT m)) => NullFsT m a -> m a
withExpandoFs m = withNullFs $ do
mount expandofs (path "/")
m