Zipper.hs

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


--------------------------------------------------------------------------------