    {-|
    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 Control.Monad
    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