{-# LANGUAGE GADTs #-}
module Data.Generics.Traversable.Zipper (
Zipper(),
toZipper, fromZipper,
left, right, down, down', up, leftmost, rightmost,
query,
trans,
transM,
getHole,
setHole,
setHole'
) where
import Control.Monad (liftM)
import Data.Generics.Traversable
import Data.Typeable (Typeable, cast)
import GHC.Exts (Constraint)
data Zipper (c :: * -> Constraint) root =
forall hole. (Rec c hole) =>
Zipper hole (Context c hole root)
data Context c hole root where
CtxtNull :: Context c a a
CtxtCons ::
forall hole root rights parent c. (Rec c parent) =>
Left c (hole -> rights)
-> Right c rights parent
-> Context c parent root
-> Context c hole root
combine :: Left c (hole -> rights)
-> hole
-> Right c rights parent
-> parent
combine :: Left c (hole -> rights) -> hole -> Right c rights parent -> parent
combine Left c (hole -> rights)
lefts hole
hole Right c rights parent
rights =
rights -> Right c rights parent -> parent
forall r (c :: * -> Constraint) parent.
r -> Right c r parent -> parent
fromRight ((Left c (hole -> rights) -> hole -> rights
forall (c :: * -> Constraint) r. Left c r -> r
fromLeft Left c (hole -> rights)
lefts) hole
hole) Right c rights parent
rights
data Left c expects
= LeftUnit expects
| forall b. (Rec c b) => LeftCons (Left c (b -> expects)) b
instance Functor (Left c) where
fmap :: (a -> b) -> Left c a -> Left c b
fmap a -> b
f (LeftUnit a
x) = b -> Left c b
forall (c :: * -> Constraint) expects. expects -> Left c expects
LeftUnit (b -> Left c b) -> b -> Left c b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
fmap a -> b
f (LeftCons Left c (b -> a)
lft b
x) = Left c (b -> b) -> b -> Left c b
forall (c :: * -> Constraint) expects b.
Rec c b =>
Left c (b -> expects) -> b -> Left c expects
LeftCons (((b -> a) -> b -> b) -> Left c (b -> a) -> Left c (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Left c (b -> a)
lft) b
x
instance Applicative (Left c) where
pure :: a -> Left c a
pure = a -> Left c a
forall (c :: * -> Constraint) expects. expects -> Left c expects
LeftUnit
Left c (a -> b)
tx <*> :: Left c (a -> b) -> Left c a -> Left c b
<*> LeftUnit a
e = ((a -> b) -> b) -> Left c (a -> b) -> Left c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
e) Left c (a -> b)
tx
Left c (a -> b)
tx <*> LeftCons Left c (b -> a)
ty b
az = Left c (b -> b) -> b -> Left c b
forall (c :: * -> Constraint) expects b.
Rec c b =>
Left c (b -> expects) -> b -> Left c expects
LeftCons ((a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((a -> b) -> (b -> a) -> b -> b)
-> Left c (a -> b) -> Left c ((b -> a) -> b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Left c (a -> b)
tx Left c ((b -> a) -> b -> b) -> Left c (b -> a) -> Left c (b -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Left c (b -> a)
ty) b
az
unit :: Rec c b => b -> Left c b
unit :: b -> Left c b
unit = Left c (b -> b) -> b -> Left c b
forall (c :: * -> Constraint) expects b.
Rec c b =>
Left c (b -> expects) -> b -> Left c expects
LeftCons ((b -> b) -> Left c (b -> b)
forall (c :: * -> Constraint) expects. expects -> Left c expects
LeftUnit b -> b
forall a. a -> a
id)
toLeft :: forall a c . (Rec c a) => a -> Left c a
toLeft :: a -> Left c a
toLeft = (forall d. Rec c d => d -> Left c d) -> a -> Left c a
forall (c :: * -> Constraint) a (f :: * -> *).
(GTraversable c a, Applicative f) =>
(forall d. c d => d -> f d) -> a -> f a
gtraverse @(Rec c) forall d. Rec c d => d -> Left c d
forall (c :: * -> Constraint) b. Rec c b => b -> Left c b
unit
fromLeft :: Left c r -> r
fromLeft :: Left c r -> r
fromLeft (LeftUnit r
a) = r
a
fromLeft (LeftCons Left c (b -> r)
f b
b) = Left c (b -> r) -> b -> r
forall (c :: * -> Constraint) r. Left c r -> r
fromLeft Left c (b -> r)
f b
b
data Right c provides parent where
RightNull :: Right c parent parent
RightCons ::
(Rec c b) => b -> Right c a t -> Right c (b -> a) t
fromRight :: r -> Right c r parent -> parent
fromRight :: r -> Right c r parent -> parent
fromRight r
f (Right c r parent
RightNull) = r
parent
f
fromRight r
f (RightCons b
b Right c a parent
r) = a -> Right c a parent -> parent
forall r (c :: * -> Constraint) parent.
r -> Right c r parent -> parent
fromRight (r
b -> a
f b
b) Right c a parent
r
fromZipper :: Zipper c a -> a
fromZipper :: Zipper c a -> a
fromZipper (Zipper hole
hole Context c hole a
CtxtNull) = a
hole
hole
fromZipper (Zipper hole
hole (CtxtCons Left c (hole -> rights)
l Right c rights parent
r Context c parent a
ctxt)) =
Zipper c a -> a
forall (c :: * -> Constraint) a. Zipper c a -> a
fromZipper (parent -> Context c parent a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper (Left c (hole -> rights) -> hole -> Right c rights parent -> parent
forall (c :: * -> Constraint) hole rights parent.
Left c (hole -> rights) -> hole -> Right c rights parent -> parent
combine Left c (hole -> rights)
l hole
hole Right c rights parent
r) Context c parent a
ctxt)
toZipper :: Rec c a => a -> Zipper c a
toZipper :: a -> Zipper c a
toZipper a
x = a -> Context c a a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper a
x Context c a a
forall (c :: * -> Constraint) a. Context c a a
CtxtNull
left :: Zipper c a -> Maybe (Zipper c a)
left :: Zipper c a -> Maybe (Zipper c a)
left (Zipper hole
_ Context c hole a
CtxtNull) = Maybe (Zipper c a)
forall a. Maybe a
Nothing
left (Zipper hole
_ (CtxtCons (LeftUnit hole -> rights
_) Right c rights parent
_ Context c parent a
_)) = Maybe (Zipper c a)
forall a. Maybe a
Nothing
left (Zipper hole
h (CtxtCons (LeftCons Left c (b -> hole -> rights)
l b
h') Right c rights parent
r Context c parent a
c)) =
Zipper c a -> Maybe (Zipper c a)
forall a. a -> Maybe a
Just (b -> Context c b a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper b
h' (Left c (b -> hole -> rights)
-> Right c (hole -> rights) parent
-> Context c parent a
-> Context c b a
forall hole root rights parent (c :: * -> Constraint).
Rec c parent =>
Left c (hole -> rights)
-> Right c rights parent
-> Context c parent root
-> Context c hole root
CtxtCons Left c (b -> hole -> rights)
l (hole -> Right c rights parent -> Right c (hole -> rights) parent
forall (c :: * -> Constraint) b a t.
Rec c b =>
b -> Right c a t -> Right c (b -> a) t
RightCons hole
h Right c rights parent
r) Context c parent a
c))
right :: Zipper c a -> Maybe (Zipper c a)
right :: Zipper c a -> Maybe (Zipper c a)
right (Zipper hole
_ Context c hole a
CtxtNull) = Maybe (Zipper c a)
forall a. Maybe a
Nothing
right (Zipper hole
_ (CtxtCons Left c (hole -> rights)
_ Right c rights parent
RightNull Context c parent a
_)) = Maybe (Zipper c a)
forall a. Maybe a
Nothing
right (Zipper hole
h (CtxtCons Left c (hole -> rights)
l (RightCons b
h' Right c a parent
r) Context c parent a
c)) =
Zipper c a -> Maybe (Zipper c a)
forall a. a -> Maybe a
Just (b -> Context c b a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper b
h' (Left c (b -> a)
-> Right c a parent -> Context c parent a -> Context c b a
forall hole root rights parent (c :: * -> Constraint).
Rec c parent =>
Left c (hole -> rights)
-> Right c rights parent
-> Context c parent root
-> Context c hole root
CtxtCons (Left c (hole -> rights) -> hole -> Left c rights
forall (c :: * -> Constraint) expects b.
Rec c b =>
Left c (b -> expects) -> b -> Left c expects
LeftCons Left c (hole -> rights)
l hole
h) Right c a parent
r Context c parent a
c))
down :: forall a c . Zipper c a -> Maybe (Zipper c a)
down :: Zipper c a -> Maybe (Zipper c a)
down (Zipper (hole
hole :: holeT) Context c hole a
ctxt) =
case hole -> Left c hole
forall a (c :: * -> Constraint). Rec c a => a -> Left c a
toLeft hole
hole :: Left c holeT of
LeftUnit hole
_ -> Maybe (Zipper c a)
forall a. Maybe a
Nothing
LeftCons Left c (b -> hole)
l b
hole' ->
Zipper c a -> Maybe (Zipper c a)
forall a. a -> Maybe a
Just (b -> Context c b a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper b
hole' (Left c (b -> hole)
-> Right c hole hole -> Context c hole a -> Context c b a
forall hole root rights parent (c :: * -> Constraint).
Rec c parent =>
Left c (hole -> rights)
-> Right c rights parent
-> Context c parent root
-> Context c hole root
CtxtCons Left c (b -> hole)
l Right c hole hole
forall (c :: * -> Constraint) parent. Right c parent parent
RightNull Context c hole a
ctxt))
down' :: Zipper c a -> Maybe (Zipper c a)
down' :: Zipper c a -> Maybe (Zipper c a)
down' Zipper c a
z = (Zipper c a -> Zipper c a)
-> Maybe (Zipper c a) -> Maybe (Zipper c a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Zipper c a -> Zipper c a
forall (c :: * -> Constraint) a. Zipper c a -> Zipper c a
leftmost (Zipper c a -> Maybe (Zipper c a)
forall a (c :: * -> Constraint). Zipper c a -> Maybe (Zipper c a)
down Zipper c a
z)
up :: Zipper c a -> Maybe (Zipper c a)
up :: Zipper c a -> Maybe (Zipper c a)
up (Zipper hole
_ Context c hole a
CtxtNull) = Maybe (Zipper c a)
forall a. Maybe a
Nothing
up (Zipper hole
hole (CtxtCons Left c (hole -> rights)
l Right c rights parent
r Context c parent a
ctxt)) =
Zipper c a -> Maybe (Zipper c a)
forall a. a -> Maybe a
Just (parent -> Context c parent a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper (Left c (hole -> rights) -> hole -> Right c rights parent -> parent
forall (c :: * -> Constraint) hole rights parent.
Left c (hole -> rights) -> hole -> Right c rights parent -> parent
combine Left c (hole -> rights)
l hole
hole Right c rights parent
r) Context c parent a
ctxt)
query
:: (forall d . Rec c d => d -> b)
-> Zipper c a -> b
query :: (forall d. Rec c d => d -> b) -> Zipper c a -> b
query forall d. Rec c d => d -> b
f (Zipper hole
hole Context c hole a
_ctxt) = hole -> b
forall d. Rec c d => d -> b
f hole
hole
trans
:: (forall d . Rec c d => d -> d)
-> Zipper c a -> Zipper c a
trans :: (forall d. Rec c d => d -> d) -> Zipper c a -> Zipper c a
trans forall d. Rec c d => d -> d
f (Zipper hole
hole Context c hole a
ctxt) = hole -> Context c hole a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper (hole -> hole
forall d. Rec c d => d -> d
f hole
hole) Context c hole a
ctxt
transM
:: Monad m
=> (forall d . Rec c d => d -> m d)
-> Zipper c a -> m (Zipper c a)
transM :: (forall d. Rec c d => d -> m d) -> Zipper c a -> m (Zipper c a)
transM forall d. Rec c d => d -> m d
f (Zipper hole
hole Context c hole a
ctxt) = do
hole
hole' <- hole -> m hole
forall d. Rec c d => d -> m d
f hole
hole
Zipper c a -> m (Zipper c a)
forall (m :: * -> *) a. Monad m => a -> m a
return (hole -> Context c hole a -> Zipper c a
forall (c :: * -> Constraint) root hole.
Rec c hole =>
hole -> Context c hole root -> Zipper c root
Zipper hole
hole' Context c hole a
ctxt)
getHole :: (Typeable b) => Zipper Typeable a -> Maybe b
getHole :: Zipper Typeable a -> Maybe b
getHole = (forall d. Rec Typeable d => d -> Maybe b)
-> Zipper Typeable a -> Maybe b
forall (c :: * -> Constraint) b a.
(forall d. Rec c d => d -> b) -> Zipper c a -> b
query forall d. Rec Typeable d => d -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast
setHole :: (Typeable a) => a -> Zipper Typeable b -> Zipper Typeable b
setHole :: a -> Zipper Typeable b -> Zipper Typeable b
setHole a
h Zipper Typeable b
z = (forall d. Rec Typeable d => d -> d)
-> Zipper Typeable b -> Zipper Typeable b
forall (c :: * -> Constraint) a.
(forall d. Rec c d => d -> d) -> Zipper c a -> Zipper c a
trans ((d -> d) -> (d -> d -> d) -> Maybe d -> d -> d
forall b a. b -> (a -> b) -> Maybe a -> b
maybe d -> d
forall a. a -> a
id d -> d -> d
forall a b. a -> b -> a
const (Maybe d -> d -> d) -> Maybe d -> d -> d
forall a b. (a -> b) -> a -> b
$ a -> Maybe d
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
h) Zipper Typeable b
z
setHole' :: (Typeable a) => a -> Zipper Typeable b -> Maybe (Zipper Typeable b)
setHole' :: a -> Zipper Typeable b -> Maybe (Zipper Typeable b)
setHole' a
h Zipper Typeable b
z = (forall d. Rec Typeable d => d -> Maybe d)
-> Zipper Typeable b -> Maybe (Zipper Typeable b)
forall (m :: * -> *) (c :: * -> Constraint) a.
Monad m =>
(forall d. Rec c d => d -> m d) -> Zipper c a -> m (Zipper c a)
transM (Maybe d -> d -> Maybe d
forall a b. a -> b -> a
const (a -> Maybe d
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
h)) Zipper Typeable b
z
type Move c a = Zipper c a -> Maybe (Zipper c a)
moveQ :: Move c a
-> b
-> (Zipper c a -> b)
-> Zipper c a
-> b
moveQ :: Move c a -> b -> (Zipper c a -> b) -> Zipper c a -> b
moveQ Move c a
move b
b Zipper c a -> b
f Zipper c a
z = case Move c a
move Zipper c a
z of
Maybe (Zipper c a)
Nothing -> b
b
Just Zipper c a
z' -> Zipper c a -> b
f Zipper c a
z'
leftQ :: b
-> (Zipper c a -> b) -> Zipper c a -> b
leftQ :: b -> (Zipper c a -> b) -> Zipper c a -> b
leftQ b
b Zipper c a -> b
f Zipper c a
z = Move c a -> b -> (Zipper c a -> b) -> Zipper c a -> b
forall (c :: * -> Constraint) a b.
Move c a -> b -> (Zipper c a -> b) -> Zipper c a -> b
moveQ Move c a
forall (c :: * -> Constraint) a. Zipper c a -> Maybe (Zipper c a)
left b
b Zipper c a -> b
f Zipper c a
z
rightQ :: b
-> (Zipper c a -> b) -> Zipper c a -> b
rightQ :: b -> (Zipper c a -> b) -> Zipper c a -> b
rightQ b
b Zipper c a -> b
f Zipper c a
z = Move c a -> b -> (Zipper c a -> b) -> Zipper c a -> b
forall (c :: * -> Constraint) a b.
Move c a -> b -> (Zipper c a -> b) -> Zipper c a -> b
moveQ Move c a
forall (c :: * -> Constraint) a. Zipper c a -> Maybe (Zipper c a)
right b
b Zipper c a -> b
f Zipper c a
z
leftmost :: Zipper c a -> Zipper c a
leftmost :: Zipper c a -> Zipper c a
leftmost Zipper c a
z = Zipper c a
-> (Zipper c a -> Zipper c a) -> Zipper c a -> Zipper c a
forall b (c :: * -> Constraint) a.
b -> (Zipper c a -> b) -> Zipper c a -> b
leftQ Zipper c a
z Zipper c a -> Zipper c a
forall (c :: * -> Constraint) a. Zipper c a -> Zipper c a
leftmost Zipper c a
z
rightmost :: Zipper c a -> Zipper c a
rightmost :: Zipper c a -> Zipper c a
rightmost Zipper c a
z = Zipper c a
-> (Zipper c a -> Zipper c a) -> Zipper c a -> Zipper c a
forall b (c :: * -> Constraint) a.
b -> (Zipper c a -> b) -> Zipper c a -> b
rightQ Zipper c a
z Zipper c a -> Zipper c a
forall (c :: * -> Constraint) a. Zipper c a -> Zipper c a
rightmost Zipper c a
z