--
-- Copynext (c) Krasimir Angelov 2008.
-- Copynext (c) Iavor S. Diatchki 2008.
--
-- Generic zipper implementation for Data.Tree
--
--
module Data.Tree.Zipper
( TreePos
, PosType, Empty, Full
-- * Context
, before, after, forest, tree, label, parents
-- * Conversions
, fromTree
, fromForest
, toForest
, toTree
-- * Moving around
, parent
, root
, prevSpace, prevTree, prev, first, spaceAt
, nextSpace, nextTree, next, last
, children, firstChild, lastChild, childAt
-- * Node classification
, isRoot
, isFirst
, isLast
, isLeaf
, isContained
, hasChildren
-- * Working with the current tree
, insert
, delete
, setTree
, modifyTree
, modifyLabel
, setLabel
) where
import Data.Tree
import Prelude hiding (last)
-- | A position within a 'Tree'.
-- The parameter 't' inidcates if the position is pointing to
-- a specific tree (if 't' is 'Full'), or if it is pointing in-between
-- trees (if 't' is 'Empty').
data TreePos t a = Loc
{ _content :: t a -- ^ The currently selected tree.
, _before :: Forest a
, _after :: Forest a
, _parents :: [(Forest a, a, Forest a)]
} deriving (Read,Show,Eq)
-- | Siblings before this position, closest first.
before :: PosType t => TreePos t a -> Forest a
before = _before
-- | Siblings after this position, closest first.
after :: PosType t => TreePos t a -> Forest a
after = _after
-- | The contexts of the parents for this position.
parents :: PosType t => TreePos t a -> [(Forest a, a, Forest a)]
parents = _parents
-- | Position which does not point to a tree (e.g., it is between two trees).
data Empty a = E deriving (Read,Show,Eq)
-- | Position which points to a tree.
newtype Full a = F { unF :: Tree a } deriving (Read,Show,Eq)
-- | Positions may be either 'Full' or 'Empty'.
class PosType t where
_prev :: TreePos t a -> Maybe (TreePos t a)
_next :: TreePos t a -> Maybe (TreePos t a)
_forest :: TreePos t a -> Forest a
instance PosType Full where
_prev = prevTree . prevSpace
_next = nextTree . nextSpace
_forest loc = foldl (flip (:)) (tree loc : after loc) (before loc)
instance PosType Empty where
_prev = fmap prevSpace . prevTree
_next = fmap nextSpace . nextTree
_forest loc = foldl (flip (:)) (after loc) (before loc)
-- XXX: We do this because haddock insist on placing methods
-- in the class...
-- | The sibling before this location.
prev :: PosType t => TreePos t a -> Maybe (TreePos t a)
prev = _prev
-- | The sibling after this location.
next :: PosType t => TreePos t a -> Maybe (TreePos t a)
next = _next
-- | All trees at this location
-- (i.e., the current tree---if any---and its siblings).
forest :: PosType t => TreePos t a -> Forest a
forest = _forest
-- Moving around ---------------------------------------------------------------
-- | The parent of the given location.
parent :: PosType t => TreePos t a -> Maybe (TreePos Full a)
parent loc =
case parents loc of
(ls,a,rs) : ps -> Just
Loc { _content = F (Node a (forest loc))
, _before = ls
, _after = rs
, _parents = ps
}
[] -> Nothing
-- | The top-most parent of the given location.
root :: TreePos Full a -> TreePos Full a
root loc = maybe loc root (parent loc)
-- | The space immediately before this location.
prevSpace :: TreePos Full a -> TreePos Empty a
prevSpace loc = loc { _content = E, _after = tree loc : after loc }
-- | The tree before this location, if any.
prevTree :: TreePos Empty a -> Maybe (TreePos Full a)
prevTree loc =
case before loc of
t : ts -> Just loc { _content = F t, _before = ts }
[] -> Nothing
-- | The space immediately after this location.
nextSpace :: TreePos Full a -> TreePos Empty a
nextSpace loc = loc { _content = E, _before = tree loc : before loc }
-- | The tree after this location, if any.
nextTree :: TreePos Empty a -> Maybe (TreePos Full a)
nextTree loc =
case after loc of
t : ts -> Just loc { _content = F t, _after = ts }
[] -> Nothing
-- | The location at the beginning of the forest of children.
children :: TreePos Full a -> TreePos Empty a
children loc =
Loc { _content = E
, _before = []
, _after = subForest (tree loc)
, _parents = (before loc, rootLabel (tree loc), after loc)
: parents loc
}
-- | The first space in the current forest.
first :: TreePos Empty a -> TreePos Empty a
first loc = loc { _content = E
, _before = []
, _after = reverse (before loc) ++ after loc
}
-- | The last space in the current forest.
last :: TreePos Empty a -> TreePos Empty a
last loc = loc { _content = E
, _before = reverse (after loc) ++ before loc
, _after = []
}
-- | The empty space at the given index. The first space is at index 0.
-- For indexes that are negative or too large, we return the first and last
-- position in the tree, respectively.
spaceAt :: Int -> TreePos Empty a -> TreePos Empty a
spaceAt n loc = loc { _content = E
, _before = reverse as
, _after = bs
}
where (as,bs) = splitAt n (forest loc)
-- | The first child of the given location.
firstChild :: TreePos Full a -> Maybe (TreePos Full a)
firstChild = nextTree . children
-- | The last child of the given location.
lastChild :: TreePos Full a -> Maybe (TreePos Full a)
lastChild = prevTree . last . children
-- | The child at the given index in the tree.
-- The first child is at index 0.
childAt :: Int -> TreePos Full a -> Maybe (TreePos Full a)
childAt n | n < 0 = const Nothing
childAt n = nextTree . spaceAt n . children
-- Conversions -----------------------------------------------------------------
-- | A location corresponding to the root of the given tree.
fromTree :: Tree a -> TreePos Full a
fromTree t = Loc { _content = F t, _before = [], _after = [], _parents = [] }
-- | The location at the beginning of the forest.
fromForest :: Forest a -> TreePos Empty a
fromForest ts = Loc { _content = E, _before = [], _after = ts, _parents = [] }
-- | The tree containing this location.
toTree :: TreePos Full a -> Tree a
toTree loc = tree (root loc)
-- | The forest containing this location.
toForest :: PosType t => TreePos t a -> Forest a
toForest loc = case parent loc of
Nothing -> forest loc
Just p -> toForest p -- polymprphic recursion
-- Queries ---------------------------------------------------------------------
-- | Are we at the top of the tree?
isRoot :: PosType t => TreePos t a -> Bool
isRoot loc = null (parents loc)
-- | Are we the first position (of its kind) in a forest.
isFirst :: PosType t => TreePos t a -> Bool
isFirst loc = null (before loc)
-- | Are we the last position (of its kind) in a forest.
isLast :: PosType t => TreePos t a -> Bool
isLast loc = null (after loc)
-- | Are we at the bottom of the tree?
isLeaf :: TreePos Full a -> Bool
isLeaf loc = null (subForest (tree loc))
-- | Do we have a parent?
isContained :: PosType t => TreePos t a -> Bool
isContained loc = not (isRoot loc)
-- | Do we have children?
hasChildren :: TreePos Full a -> Bool
hasChildren loc = not (isLeaf loc)
-- The current tree -----------------------------------------------------------
-- | The selected tree.
tree :: TreePos Full a -> Tree a
tree x = unF (_content x)
-- | The current label.
label :: TreePos Full a -> a
label loc = rootLabel (tree loc)
-- | Insert a new tree at the current position.
insert :: Tree a -> TreePos Empty a -> TreePos Full a
insert t loc = loc { _content = F t }
-- | Remove the tree at the current position.
delete :: TreePos Full a -> TreePos Empty a
delete loc = loc { _content = E }
-- | Change the current tree.
setTree :: Tree a -> TreePos Full a -> TreePos Full a
setTree t loc = loc { _content = F t }
-- | Modify the current tree.
modifyTree :: (Tree a -> Tree a) -> TreePos Full a -> TreePos Full a
modifyTree f loc = setTree (f (tree loc)) loc
-- | Modify the label at the current node.
modifyLabel :: (a -> a) -> TreePos Full a -> TreePos Full a
modifyLabel f loc = setLabel (f (label loc)) loc
-- | Change the label at the current node.
setLabel :: a -> TreePos Full a -> TreePos Full a
setLabel v loc = modifyTree (\t -> t { rootLabel = v }) loc
--------------------------------------------------------------------------------