-- -- 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 --------------------------------------------------------------------------------