safe tree zipper using maybe

TreeZipperSafe.hs

import Data.Foldable as F

-- our data structure
data Tree a = Empty
            | Node (Tree a) a (Tree a)
            deriving Show

-- a step on the way through our tree.
-- either going to the left or to the right.
data Direction a = DLeft a (Tree a)
                 | DRight a (Tree a)
                 deriving Show

-- the way from the root node to the current location.
-- with this data the whole tree except the current node
-- can be reconstructed.
type Directions a = [Direction a]

-- the zipper represents all data under the current
-- location (Tree a) and the way to the current
-- location (Directions a).
type Zipper a = (Tree a, Directions a)

-- make a zipper from a tree
makeZipper :: Tree a -> Maybe (Zipper a)
makeZipper tree = return (tree, [])

-- descend into the left node
left :: Zipper a -> Maybe (Zipper a)
left ((Node l v r), ds) = Just (l, DLeft v r : ds)
left _ = Nothing

-- descend into the right node
right :: Zipper a -> Maybe (Zipper a)
right ((Node l v r), ds) = Just (r, DRight v l : ds)
right _ = Nothing

-- go to the parent of the current zipper position
up :: Zipper a -> Maybe (Zipper a)
up (l, (DLeft v r):ds) = Just (Node l v r, ds)
up (r, (DRight v l):ds) = Just (Node l v r, ds)
up _ = Nothing

-- go to the top of the tree
top :: Zipper a -> Maybe (Zipper a)
top (z, []) = Just (z, [])
top z = up z >>= top

-- apply function f to the value at the current zipper position
modify :: (a -> a) -> Zipper a -> Maybe (Zipper a)
modify f (Node l v r, ds) = Just (Node l (f v) r, ds)
modify _ _ = Nothing

-- attach a new tree element at the current zipper position
attach :: Tree a -> Zipper a -> Maybe (Zipper a)
attach t (_, ds) = Just (t, ds)


-- pretty print a tree
ppTree :: (Show a) => Int -> Tree a -> String
ppTree i t = pp t 0
    where pp Empty level = (s level) ++ "(E)\n"
          pp (Node l v r) level =
            pp l (level + i) ++
            (s level) ++ show v ++ "\n" ++
            pp r (level + i)
          s l = take l $ repeat ' '

showTree :: (Show a) => Maybe (Zipper a) -> String
showTree = F.concatMap ((ppTree 4) . fst)

sampleTree = Node 
                (Node Empty 'B' (Node Empty 'D' Empty))
                'A'
                (Node Empty 'C' Empty)

main = do
    let s = makeZipper sampleTree >>= left >>= right >>= (modify $ const 'X') >>= top >>= right >>= right >>= (attach $ Node Empty 'Y' Empty) >>= top
    let f = makeZipper sampleTree >>= left >>= left >>= left >>= top
    F.mapM_ putStrLn [ "-----------------------------------------------------------------"
                     , "original tree"
                     , "-----------------------------------------------------------------"
                     , ppTree 4 sampleTree
                     , "-----------------------------------------------------------------"
                     , "change 'D' to 'X'   and   add Node 'Y' as right child of Node 'C'"
                     , "-----------------------------------------------------------------"
                     , showTree s
                     , "-----------------------------------------------------------------"
                     , "failure in navigation (left, left, left)"
                     , "-----------------------------------------------------------------"
                     , showTree f
                     , show f
                     ]