module ZipperM (Term(..)
, FileName
, FileCont
, Path(..)
, DZipper(..)
, dzip'term
, module Control.Monad.CC
, promptP
) where
import Control.Monad.CC
import Control.Monad.Identity
import Control.Monad.Trans
import Data.Map as Map
promptP f = do p <- newPrompt; pushPrompt p (f p)
type FileName = String
type FileCont = String
data Term = File String | Folder (Map.Map FileName Term)
instance Show Term where
showsPrec _ (File file) = (file ++)
showsPrec _ (Folder dir) =
("\n >>>" ++) . (Map.foldWithKey fl ("\n<<<" ++) dir)
where fl k term acc = ("\n" ++) . (k ++) . (": " ++) .
(showsPrec 5 term) . acc
data Path = Down | DownTo FileName | DownToN Int | Up | Next
deriving (Eq, Show)
traverse tf term = traverse' id Down term >>= maybeM term id
where traverse' next_dir init_dir term =
do
(term', direction) <- tf init_dir term
let new_term = maybe term id term'
select (next_dir direction) new_term >>= maybeM term' Just
select Up t = return Nothing
select Next t@(File _) = return Nothing
select dir@(DownTo fname) t@(Folder fld) =
select (DownToN (Map.findIndex fname fld)) t
select dir t@(Folder _) | dir == Next || dir == Down =
select (DownToN 0) t
select (DownToN n) t@(Folder fld) | n >= Map.size fld =
return Nothing
select (DownToN n) t@(Folder fld) =
do
let (fname,term) = Map.elemAt n fld
t' <- traverse' id (DownTo fname) term >>=
(return . fmap (\newv -> Folder $
Map.adjust (const newv) fname fld))
let nextd = let idx = succ n
in if idx == Map.size fld then next Up
else next (DownToN idx)
traverse' nextd Up (maybe t id t') >>= maybeM t' Just
next next_dir dir = if dir == Next then next_dir else dir
maybeM onn onj v = return $ maybe onn onj v
fs1 :: Term =
Folder $ Map.fromList [("d1",d1), ("d2",Folder $ Map.empty),
("fl1", File "File1"),
("fl2", File "File2")]
where d1 = Folder $ Map.fromList [("fl13",File "File 3"),
("d11", d11)]
d11 = Folder $ Map.fromList [("d111", Folder $ Map.empty)]
testt1 = runIdentity (traverse (\_ term -> return (Nothing,Next)) fs1)
testt2 = traverse tf fs1
where tf dir term = do print dir; print term; return (Nothing,Next)
testt3 = traverse tf fs1
where
tf (DownTo "d11") term = do
print "cutting"
print term
return (Nothing,Up)
tf dir term = do
print term
return (Nothing,Next)
testt4 = runIdentity (traverse tf fs1)
where tf (DownTo "d11") _ = return (Just $ Folder $ Map.empty ,Up)
tf (DownTo "fl2") _ = return (Just $ File $ "New file2", Up)
tf _ _ = return (Nothing,Next)
lprint x = liftIO $ print x
data DZipper r m term dir =
DZipper{
dz_dir :: dir,
dz_path :: [dir],
dz_term :: term,
dz_k :: CCT r m (Maybe term, dir) -> CCT r m (DZipper r m term dir)
}
| DZipDone term
data HPReq r m dir = HPReq dir (CCT r m [dir] -> CCT r m (HPReq r m dir))
dzip'term term = do
p <- newPrompt
path_pr <- newPrompt
pushPrompt p (acc_path [] (pushPrompt path_pr (
traverse (tf p path_pr) term >>=
done p)))
where tf p path_pr dir term =
do
path <- shift path_pr (\k -> return (HPReq dir k))
shift p (\k -> return (DZipper dir path term k))
acc_path path body =
do
HPReq dir k <- body
let new_path = if dir == Up then tail path else dir:path
acc_path new_path (k (return new_path))
done p term = abort p (return $ DZipDone term)
testdz1 :: IO ()
= runCCT (
do
dz <- dzip'term fs1
let loop (DZipDone term) = lprint "Finished" >> lprint term
loop dz =
do
lprint $ (show $ dz_dir dz) ++ "->" ++ (show $ dz_path dz)
lprint $ dz_term dz
dz_k dz (return (Nothing,Next)) >>= loop
loop dz
)