{-# Language LambdaCase #-}
module System.Directory.Contents.Zipper where
import Control.Applicative
import Data.Map (Map)
import qualified Data.Map as Map
import System.FilePath
import System.Directory.Contents.Types
data DirZipper a = DirZipper
{ _dirZipper_cursor :: DirTree a
, _dirZipper_siblings :: Map FilePath (DirTree a)
, _dirZipper_elders :: [(DirTree a, Map FilePath (DirTree a))]
}
deriving (Show, Read, Eq, Ord)
zipped :: DirTree a -> DirZipper a
zipped a = DirZipper a Map.empty []
focused :: DirZipper a -> DirTree a
focused = _dirZipper_cursor
unzipped :: DirZipper a -> DirTree a
unzipped = focused . home
down :: DirZipper a -> Maybe (DirZipper a)
down dz = case dz of
DirZipper p@(DirTree_Dir _ xs) siblings parents ->
withFirstChild xs $ \firstChild children ->
DirZipper firstChild children $ (p, siblings) : parents
DirZipper p@(DirTree_Symlink _ (Symlink_External _ xs)) siblings parents ->
withFirstChild xs $ \firstChild children ->
DirZipper firstChild children $ (p, siblings) : parents
DirZipper (DirTree_Symlink _ (Symlink_Internal _ ref)) _ _ ->
followRelative ref $ home dz
_ -> Nothing
up :: DirZipper a -> Maybe (DirZipper a)
up = \case
DirZipper c s ((parent, uncles):ps) ->
Just $ DirZipper (update c s parent) uncles ps
_ -> Nothing
where
update :: DirTree a -> Map FilePath (DirTree a) -> DirTree a -> DirTree a
update child siblings parent = case parent of
DirTree_Dir f _ -> DirTree_Dir f $ insertSibling child siblings
DirTree_Symlink f (Symlink_External s _) ->
DirTree_Symlink f $ Symlink_External s $ insertSibling child siblings
_ -> parent
home :: DirZipper a -> DirZipper a
home dz =
let upmost z = maybe z upmost $ up z
in upmost dz
data NavSibling = NavLeft | NavRight
nextSibling :: NavSibling -> DirZipper a -> Maybe (DirZipper a)
nextSibling nav (DirZipper cursor siblings parents) =
let kids = insertSibling cursor siblings
next = case nav of
NavRight -> Map.lookupGT (fileName cursor) kids
NavLeft -> Map.lookupLT (fileName cursor) kids
in case next of
Nothing -> Nothing
Just (_, sibling) -> Just $
DirZipper sibling (removeSibling sibling kids) parents
left :: DirZipper a -> Maybe (DirZipper a)
left = nextSibling NavLeft
right :: DirZipper a -> Maybe (DirZipper a)
right = nextSibling NavRight
toSibling :: FileName -> DirZipper a -> Maybe (DirZipper a)
toSibling name (DirZipper cursor siblings parents) =
case Map.lookup name siblings of
Nothing -> Nothing
Just sibling ->
let otherSiblings = insertSibling cursor $
removeSibling sibling siblings
in Just $ DirZipper sibling otherSiblings parents
downTo :: FileName -> DirZipper a -> Maybe (DirZipper a)
downTo name z = do
d <- down z
if fileName (focused d) == name
then pure d
else toSibling name d
mapCursor
:: (DirTree a -> DirTree a)
-> DirZipper a
-> DirZipper a
mapCursor f (DirZipper cursor siblings parents) =
DirZipper (f cursor) siblings parents
replaceCursor
:: DirTree a
-> DirZipper a
-> DirZipper a
replaceCursor = mapCursor . const
insert
:: DirTree a
-> DirZipper a
-> DirZipper a
insert d (DirZipper cursor siblings parents) =
DirZipper
d
(insertSibling cursor siblings)
parents
remove
:: DirZipper a
-> Maybe (DirZipper a)
remove z@(DirZipper cursor _ _) =
let rm (DirZipper c s p) =
DirZipper c (removeSibling cursor s) p
in case rm <$> (left z <|> right z) of
Just s -> Just s
Nothing -> case up z of
Nothing -> Nothing
Just dz -> Just $ flip replaceCursor dz $
case _dirZipper_cursor dz of
DirTree_Dir f _ -> DirTree_Dir f Map.empty
DirTree_Symlink f (Symlink_External s _) ->
DirTree_Symlink f (Symlink_External s Map.empty)
x -> x
followRelative
:: FilePath
-> DirZipper a
-> Maybe (DirZipper a)
followRelative path dz =
let follow r z = case r of
"." -> Just z
".." -> up z
_ -> downTo r z <|> toSibling r z
go rs z = case rs of
[] -> Just z
(r:more) -> go more =<< follow r z
in go (splitDirectories path) dz
followLink
:: DirZipper a
-> Maybe (DirZipper a)
followLink z = case z of
DirZipper (DirTree_Symlink _ (Symlink_Internal s _)) _ _ -> followRelative s z
_ -> Nothing