Huet Zipper

Zipper.hs

-- See "The Zipper" by Huet 1997

module Main where

import Control.Applicative
import Control.Monad
import Data.Either

data Tree a =
    Item a
  | Section [Tree a]
  deriving (Eq, Show)

data Path a =
    Top
  | Node [Tree a] (Path a) [Tree a]
  deriving (Eq, Show)

data Location a = Loc (Tree a) (Path a)
  deriving (Eq, Show)

data GoError a =
    LeftOfTop (Location a)
  | LeftOfFirst (Location a)
  | RightOfTop (Location a)
  | RightOfLast (Location a)
  | UpOfTop (Location a)
  | DownOfItem (Location a)
  | DownOfEmpty (Location a)
  deriving (Eq, Show)


abcd = Section [ Section [ Item "a", Item "*", Item "b" ],
                 Item "+",
                 Section [ Item "c", Item "*", Item "d" ] ]

abcdTop = Loc abcd Top

locMult2 = Loc (Item "*")
               (Node [Item "c"]
                     (Node [Item "+", Section [Item "a", Item "*", Item "b"]]
                           Top
                           []
                     )
                     [Item "d"]
               )

locMult2Go = goDown abcdTop >>= goRight >>= goRight >>= goDown >>= goRight

goLeft loc@(Loc t Top) = Left $ LeftOfTop loc
goLeft (Loc t (Node (l : left) up right)) = Right $ Loc l (Node left up (t : right))
goLeft loc@(Loc t (Node [] up right)) = Left $ LeftOfFirst loc

goRight loc@(Loc t Top) = Left $ RightOfTop loc
goRight (Loc t (Node left up (r : right))) = Right $ Loc r (Node (t : left) up right)
goRight loc@(Loc t (Node left up [])) = Left $ RightOfLast loc

goUp loc@(Loc t Top) = Left $ UpOfTop loc
goUp (Loc t (Node left up right)) = Right $ Loc (Section (reverse left ++ (t : right))) up

goDown loc@(Loc (Item _) p) = Left $ DownOfItem loc
goDown (Loc (Section (t1 : trees)) p) = Right $ Loc t1 (Node [] p trees)
goDown loc = Left $ DownOfEmpty loc

main :: IO ()
main = do
  putStrLn . show $ locMult2
  putStrLn . show $ locMult2Go
  putStrLn . show $ (==) <$> pure locMult2 <*> locMult2Go