{-|
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 :: forall to. Uniplate to => to -> Zipper to to
zipper = forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall to from.
Uniplate to =>
(from -> (Str to, Str to -> from))
-> from -> Maybe (Zipper from to)
toZipper (\to
x -> (forall a. a -> Str a
One to
x, \(One to
x) -> to
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 :: forall from to. Biplate from to => from -> Maybe (Zipper from to)
zipperBi = forall to from.
Uniplate to =>
(from -> (Str to, Str to -> from))
-> from -> Maybe (Zipper from to)
toZipper forall from to. Biplate from to => from -> (Str to, Str to -> from)
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
    {forall from to. Zipper from to -> Str to -> from
reform :: Str to -> from
    ,forall from to. Zipper from to -> ZipN to
zipp :: ZipN to
    }

rezipp :: (ZipN to -> f (ZipN to)) -> Zipper from to -> f (Zipper from to)
rezipp ZipN to -> f (ZipN to)
f (Zipper Str to -> from
a ZipN to
b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall from to. (Str to -> from) -> ZipN to -> Zipper from to
Zipper Str to -> from
a) forall a b. (a -> b) -> a -> b
$ ZipN to -> f (ZipN to)
f ZipN to
b

instance (Eq from, Eq to) => Eq (Zipper from to) where
    Zipper from to
a == :: Zipper from to -> Zipper from to -> Bool
== Zipper from to
b = forall from to. Zipper from to -> from
fromZipper Zipper from to
a forall a. Eq a => a -> a -> Bool
== forall from to. Zipper from to -> from
fromZipper Zipper from to
b Bool -> Bool -> Bool
&& forall from to. Zipper from to -> ZipN to
zipp Zipper from to
a forall a. Eq a => a -> a -> Bool
== forall from to. Zipper from to -> ZipN to
zipp Zipper from to
b


toZipper :: Uniplate to => (from -> (Str to, Str to -> from)) -> from -> Maybe (Zipper from to)
toZipper :: forall to from.
Uniplate to =>
(from -> (Str to, Str to -> from))
-> from -> Maybe (Zipper from to)
toZipper from -> (Str to, Str to -> from)
biplate from
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall from to. (Str to -> from) -> ZipN to -> Zipper from to
Zipper Str to -> from
gen) forall a b. (a -> b) -> a -> b
$ forall x. Str x -> Maybe (ZipN x)
zipN Str to
cs
    where (Str to
cs,Str to -> from
gen) = from -> (Str to, Str to -> from)
biplate from
x


-- | From a zipper take the whole structure, including any modifications.
fromZipper :: Zipper from to -> from
fromZipper :: forall from to. Zipper from to -> from
fromZipper Zipper from to
x = forall from to. Zipper from to -> Str to -> from
reform Zipper from to
x forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> Str a
top1 forall a b. (a -> b) -> a -> b
$ forall {x}. ZipN x -> Zip1 x
topN forall a b. (a -> b) -> a -> b
$ forall from to. Zipper from to -> ZipN to
zipp Zipper from to
x


-- | Move one step left from the current position.
left :: Zipper from to -> Maybe (Zipper from to)
left :: forall from to. Zipper from to -> Maybe (Zipper from to)
left = forall {f :: * -> *} {to} {from}.
Functor f =>
(ZipN to -> f (ZipN to)) -> Zipper from to -> f (Zipper from to)
rezipp forall {x}. ZipN x -> Maybe (ZipN x)
leftN

-- | Move one step right from the current position.
right :: Zipper from to -> Maybe (Zipper from to)
right :: forall from to. Zipper from to -> Maybe (Zipper from to)
right = forall {f :: * -> *} {to} {from}.
Functor f =>
(ZipN to -> f (ZipN to)) -> Zipper from to -> f (Zipper from to)
rezipp forall {x}. ZipN x -> Maybe (ZipN x)
rightN

-- | Move one step down from the current position.
down :: Uniplate to => Zipper from to -> Maybe (Zipper from to)
down :: forall to from.
Uniplate to =>
Zipper from to -> Maybe (Zipper from to)
down = forall {f :: * -> *} {to} {from}.
Functor f =>
(ZipN to -> f (ZipN to)) -> Zipper from to -> f (Zipper from to)
rezipp forall x. Uniplate x => ZipN x -> Maybe (ZipN x)
downN

-- | Move one step up from the current position.
up :: Zipper from to -> Maybe (Zipper from to)
up :: forall from to. Zipper from to -> Maybe (Zipper from to)
up = forall {f :: * -> *} {to} {from}.
Functor f =>
(ZipN to -> f (ZipN to)) -> Zipper from to -> f (Zipper from to)
rezipp forall {x}. ZipN x -> Maybe (ZipN x)
upN


-- | Retrieve the current focus of the zipper..
hole :: Zipper from to -> to
hole :: forall from to. Zipper from to -> to
hole = forall {a}. ZipN a -> a
holeN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from to. Zipper from to -> ZipN to
zipp


-- | Replace the value currently at the focus of the zipper.
replaceHole :: to -> Zipper from to -> Zipper from to
replaceHole :: forall to from. to -> Zipper from to -> Zipper from to
replaceHole to
x Zipper from to
z = Zipper from to
z{zipp :: ZipN to
zipp=forall {x}. x -> ZipN x -> ZipN x
replaceN to
x (forall from to. Zipper from to -> ZipN to
zipp Zipper from to
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 x
x@(ZipN [Str x -> Zip1 x]
_ Zip1 x
xx) == :: ZipN x -> ZipN x -> Bool
== y :: ZipN x
y@(ZipN [Str x -> Zip1 x]
_ Zip1 x
yy) = Zip1 x
xx forall a. Eq a => a -> a -> Bool
== Zip1 x
yy Bool -> Bool -> Bool
&& forall {x}. ZipN x -> Maybe (ZipN x)
upN ZipN x
x forall a. Eq a => a -> a -> Bool
== forall {x}. ZipN x -> Maybe (ZipN x)
upN ZipN x
y

zipN :: Str x -> Maybe (ZipN x)
zipN :: forall x. Str x -> Maybe (ZipN x)
zipN Str x
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN []) forall a b. (a -> b) -> a -> b
$ forall x. Str x -> Maybe (Zip1 x)
zip1 Str x
x

leftN :: ZipN x -> Maybe (ZipN x)
leftN  (ZipN [Str x -> Zip1 x]
p Zip1 x
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN [Str x -> Zip1 x]
p) forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> Maybe (Zip1 a)
left1  Zip1 x
x
rightN :: ZipN x -> Maybe (ZipN x)
rightN (ZipN [Str x -> Zip1 x]
p Zip1 x
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN [Str x -> Zip1 x]
p) forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> Maybe (Zip1 a)
right1 Zip1 x
x
holeN :: ZipN a -> a
holeN (ZipN [Str a -> Zip1 a]
_ Zip1 a
x) = forall a. Zip1 a -> a
hole1 Zip1 a
x
replaceN :: x -> ZipN x -> ZipN x
replaceN x
v (ZipN [Str x -> Zip1 x]
p Zip1 x
x) = forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN [Str x -> Zip1 x]
p forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> a -> Zip1 a
replace1 Zip1 x
x x
v

upN :: ZipN x -> Maybe (ZipN x)
upN (ZipN [] Zip1 x
x) = forall a. Maybe a
Nothing
upN (ZipN (Str x -> Zip1 x
p:[Str x -> Zip1 x]
ps) Zip1 x
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN [Str x -> Zip1 x]
ps forall a b. (a -> b) -> a -> b
$ Str x -> Zip1 x
p forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> Str a
top1 Zip1 x
x

topN :: ZipN x -> Zip1 x
topN (ZipN [] Zip1 x
x) = Zip1 x
x
topN ZipN x
x = ZipN x -> Zip1 x
topN forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall {x}. ZipN x -> Maybe (ZipN x)
upN ZipN x
x

downN :: Uniplate x => ZipN x -> Maybe (ZipN x)
downN :: forall x. Uniplate x => ZipN x -> Maybe (ZipN x)
downN (ZipN [Str x -> Zip1 x]
ps Zip1 x
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. [Str x -> Zip1 x] -> Zip1 x -> ZipN x
ZipN forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> a -> Zip1 a
replace1 Zip1 x
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str x -> x
gen forall a. a -> [a] -> [a]
: [Str x -> Zip1 x]
ps) forall a b. (a -> b) -> a -> b
$ forall x. Str x -> Maybe (Zip1 x)
zip1 Str x
cs
    where (Str x
cs,Str x -> x
gen) = forall on. Uniplate on => on -> (Str on, Str on -> on)
uniplate forall a b. (a -> b) -> a -> b
$ forall a. Zip1 a -> a
hole1 Zip1 x
x


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

data Diff1 a = TwoLeft (Str a) | TwoRight (Str a) deriving Diff1 a -> Diff1 a -> Bool
forall a. Eq a => Diff1 a -> Diff1 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Diff1 a -> Diff1 a -> Bool
$c/= :: forall a. Eq a => Diff1 a -> Diff1 a -> Bool
== :: Diff1 a -> Diff1 a -> Bool
$c== :: forall a. Eq a => Diff1 a -> Diff1 a -> Bool
Eq

undiff1 :: Str a -> Diff1 a -> Str a
undiff1 Str a
r (TwoLeft  Str a
l) = forall a. Str a -> Str a -> Str a
Two Str a
l Str a
r
undiff1 Str a
l (TwoRight Str a
r) = forall a. Str a -> Str a -> Str a
Two Str a
l Str a
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 Zip1 a -> Zip1 a -> Bool
forall a. Eq a => Zip1 a -> Zip1 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Zip1 a -> Zip1 a -> Bool
$c/= :: forall a. Eq a => Zip1 a -> Zip1 a -> Bool
== :: Zip1 a -> Zip1 a -> Bool
$c== :: forall a. Eq a => Zip1 a -> Zip1 a -> Bool
Eq

zip1 :: Str x -> Maybe (Zip1 x)
zip1 :: forall x. Str x -> Maybe (Zip1 x)
zip1 = forall a. Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)
insert1 Bool
True []

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

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

move1 :: Bool -> Zip1 a -> Maybe (Zip1 a)
move1 :: forall a. Bool -> Zip1 a -> Maybe (Zip1 a)
move1 Bool
leftward (Zip1 [Diff1 a]
p a
x) = forall {a}. [Diff1 a] -> Str a -> Maybe (Zip1 a)
f [Diff1 a]
p forall a b. (a -> b) -> a -> b
$ forall a. a -> Str a
One a
x
    where
        f :: [Diff1 a] -> Str a -> Maybe (Zip1 a)
f [Diff1 a]
p Str a
x = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
            [forall a. Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)
insert1 Bool
False (forall a. Str a -> Diff1 a
TwoRight Str a
xforall a. a -> [a] -> [a]
:[Diff1 a]
ps) Str a
l | TwoLeft  Str a
l:[Diff1 a]
ps <- [[Diff1 a]
p], Bool
leftward] forall a. [a] -> [a] -> [a]
++
            [forall a. Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)
insert1 Bool
True  (forall a. Str a -> Diff1 a
TwoLeft  Str a
xforall a. a -> [a] -> [a]
:[Diff1 a]
ps) Str a
r | TwoRight Str a
r:[Diff1 a]
ps <- [[Diff1 a]
p], Bool -> Bool
not Bool
leftward] forall a. [a] -> [a] -> [a]
++
            [[Diff1 a] -> Str a -> Maybe (Zip1 a)
f [Diff1 a]
ps (Str a
x forall {a}. Str a -> Diff1 a -> Str a
`undiff1` Diff1 a
p) | Diff1 a
p:[Diff1 a]
ps <- [[Diff1 a]
p]]

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

hole1 :: Zip1 a -> a
hole1 :: forall a. Zip1 a -> a
hole1 (Zip1 [Diff1 a]
_ a
x) = a
x

-- this way round so the a can be disguarded quickly
replace1 :: Zip1 a -> a -> Zip1 a
replace1 :: forall a. Zip1 a -> a -> Zip1 a
replace1 (Zip1 [Diff1 a]
p a
_) = forall a. [Diff1 a] -> a -> Zip1 a
Zip1 [Diff1 a]
p