```{-|
A zipper is a structure for walking a value and manipulating it in constant time.

This module was inspired by the paper:
/Michael D. Adams. Scrap Your Zippers: A Generic Zipper for Heterogeneous Types, Workshop on Generic Programming 2010/.
-}

module Data.Generics.Uniplate.Zipper(
-- * Create a zipper and get back the value
Zipper, zipper, zipperBi, fromZipper,
-- * Navigate within a zipper
left, right, up, down,
-- * Manipulate the zipper hole
hole, replaceHole
) where

import Data.Generics.Uniplate.Operations
import Data.Generics.Str
import Data.Maybe

-- | Create a zipper, focused on the top-left value.
zipper :: Uniplate to => to -> Zipper to to
zipper = fromJust . toZipper (\x -> (One x, \(One x) -> x))

-- | Create a zipper with a different focus type from the outer type. Will return
--   @Nothing@ if there are no instances of the focus type within the original value.
zipperBi :: Biplate from to => from -> Maybe (Zipper from to)
zipperBi = toZipper biplate

-- | Zipper structure, whose root type is the first type argument, and whose
--   focus type is the second type argument.
data Zipper from to = Zipper
{reform :: Str to -> from
,zipp :: ZipN to
}

rezipp f (Zipper a b) = fmap (Zipper a) \$ f b

instance (Eq from, Eq to) => Eq (Zipper from to) where
a == b = fromZipper a == fromZipper b && zipp a == zipp b

toZipper :: Uniplate to => (from -> (Str to, Str to -> from)) -> from -> Maybe (Zipper from to)
toZipper biplate x = fmap (Zipper gen) \$ zipN cs
where (cs,gen) = biplate x

-- | From a zipper take the whole structure, including any modifications.
fromZipper :: Zipper from to -> from
fromZipper x = reform x \$ top1 \$ topN \$ zipp x

-- | Move one step left from the current position.
left :: Zipper from to -> Maybe (Zipper from to)
left = rezipp leftN

-- | Move one step right from the current position.
right :: Zipper from to -> Maybe (Zipper from to)
right = rezipp rightN

-- | Move one step down from the current position.
down :: Uniplate to => Zipper from to -> Maybe (Zipper from to)
down = rezipp downN

-- | Move one step up from the current position.
up :: Zipper from to -> Maybe (Zipper from to)
up = rezipp upN

-- | Retrieve the current focus of the zipper..
hole :: Zipper from to -> to
hole = holeN . zipp

-- | Replace the value currently at the focus of the zipper.
replaceHole :: to -> Zipper from to -> Zipper from to
replaceHole x z = z{zipp=replaceN x (zipp z)}

---------------------------------------------------------------------
-- N LEVEL ZIPPER ON Str

data ZipN x = ZipN [Str x -> Zip1 x] (Zip1 x)

instance Eq x => Eq (ZipN x) where
x@(ZipN _ xx) == y@(ZipN _ yy) = xx == yy && upN x == upN y

zipN :: Str x -> Maybe (ZipN x)
zipN x = fmap (ZipN []) \$ zip1 x

leftN  (ZipN p x) = fmap (ZipN p) \$ left1  x
rightN (ZipN p x) = fmap (ZipN p) \$ right1 x
holeN (ZipN _ x) = hole1 x
replaceN v (ZipN p x) = ZipN p \$ replace1 x v

upN (ZipN [] x) = Nothing
upN (ZipN (p:ps) x) = Just \$ ZipN ps \$ p \$ top1 x

topN (ZipN [] x) = x
topN x = topN \$ fromJust \$ upN x

downN :: Uniplate x => ZipN x -> Maybe (ZipN x)
downN (ZipN ps x) = fmap (ZipN \$ replace1 x . gen : ps) \$ zip1 cs
where (cs,gen) = uniplate \$ hole1 x

---------------------------------------------------------------------
-- 1 LEVEL ZIPPER ON Str

data Diff1 a = TwoLeft (Str a) | TwoRight (Str a) deriving Eq

undiff1 r (TwoLeft  l) = Two l r
undiff1 l (TwoRight r) = Two l r

-- Warning: this definition of Eq may look too strong (Str Left/Right is not relevant)
--          but you don't know what the uniplate.gen function will do
data Zip1 a = Zip1 [Diff1 a] a deriving Eq

zip1 :: Str x -> Maybe (Zip1 x)
zip1 = insert1 True []

insert1 :: Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)
insert1 leftmost c Zero = Nothing
insert1 leftmost c (One x) = Just \$ Zip1 c x
insert1 leftmost c (Two l r) = if leftmost then ll `mplus` rr else rr `mplus` ll
where ll = insert1 leftmost (TwoRight r:c) l
rr = insert1 leftmost (TwoLeft  l:c) r

left1, right1 :: Zip1 a -> Maybe (Zip1 a)
left1  = move1 True
right1 = move1 False

move1 :: Bool -> Zip1 a -> Maybe (Zip1 a)
move1 leftward (Zip1 p x) = f p \$ One x
where
f p x = msum \$
[insert1 False (TwoRight x:ps) l | TwoLeft  l:ps <- [p], leftward] ++
[insert1 True  (TwoLeft  x:ps) r | TwoRight r:ps <- [p], not leftward] ++
[f ps (x `undiff1` p) | p:ps <- [p]]

top1 :: Zip1 a -> Str a
top1 (Zip1 p x) = f p (One x)
where f :: [Diff1 a] -> Str a -> Str a
f [] x = x
f (p:ps) x = f ps (x `undiff1` p)

hole1 :: Zip1 a -> a
hole1 (Zip1 _ x) = x

-- this way round so the a can be disguarded quickly
replace1 :: Zip1 a -> a -> Zip1 a
replace1 (Zip1 p _) = Zip1 p
```