-- | Based on «Scrap Your Zippers: A Generic Zipper for Heterogeneous Types.
-- Michael D. Adams.  WGP '10: Proceedings of the 2010 ACM SIGPLAN
-- workshop on Generic programming, 2010»
-- (<http://michaeldadams.org/papers/scrap_your_zippers/>).
--
-- Compared to the original @syz@ package, this implementation (based on
-- 'GTraversable') gives more flexibility as to where a zipper may point
-- to and what is considered as siblings.
--
-- Specifically, a zipper may point to any element which `gtraverse`
-- applies its function to.
--
-- == Example
-- === syz
-- Consider the classical example: lists. With syz, a list is interpreted as a right-balanced
-- tree.
--
-- >>> let z = fromJust . down' $ toZipper ['a'..'d']
-- >>> getHole z :: Maybe Char
-- Just 'a'
--
-- The zipper @z@ points to the first element of the list. Now let's
-- move to the right:
--
-- >>> let z' = fromJust . right $ z
-- >>> getHole z' :: Maybe Char
-- Nothing
-- >>> getHole z' :: Maybe [Char]
-- Just "bcd"
--
-- Instead of pointing to the second element of the list, as one might
-- expect, the zipper @z\'@ points to the tail of the list. In order to
-- actually move to the second element, we need another 'down'':
--
-- >>> let z'' = fromJust . down' $ z'
-- >>> getHole z'' :: Maybe Char
-- Just 'b'
--
-- === traverse-with-class
-- 'GTraversable'-based zippers behave more intuitively in this regard,
-- thanks to the uniform instance for lists.
--
-- >>> let z = fromJust . down' $ toZipper ['a'..'d'] :: Zipper Typeable [Char]
-- >>> getHole z :: Maybe Char
-- Just 'a'
--
-- So far it's more or less the same as with syz. We needed to add a type
-- annotation for the zipper itself to clarify the context which should
-- be available at each hole ('Typeable' in this case). Now let's see
-- what's to the right of us:
--
-- >>> let z' = fromJust . right $ z
-- >>> getHole z' :: Maybe Char
-- Just 'b'
--
-- That is, we jumped right to the second element of the list. Likewise,
--
-- >>> let z'' = rightmost z
-- >>> getHole z'' :: Maybe Char
-- Just 'd'
--
-- So, unlike in @syz@, all of the list elements are siblings.
{-# LANGUAGE GADTs #-}

module Data.Generics.Traversable.Zipper (
  -- * Core types
  Zipper(),

  -- * Core interface
  -- ** Injection and projection
  toZipper, fromZipper,
  -- ** Basic movement
  left, right, down, down', up, leftmost, rightmost,

  -- ** Basic hole manipulation
  query,
  trans,
  transM,

  -- * Convenience hole manipulation interface
  -- | It does not appear easy to make these functions polymorphic over the constraint @c@.
  --
  -- If you want these functions for your own constraint (which entails
  -- 'Typeable'), you need to copy their definitions and change 'Typeable'
  -- to your constraint in the 'Zipper' \'s argument.
  getHole,
  setHole,
  setHole'
  ) where

import Control.Monad (liftM)
import Data.Generics.Traversable
import Data.Typeable (Typeable, cast)
import GHC.Exts (Constraint)

-- Core types

-- | A generic zipper with a root object of type @root@.
data Zipper (c :: * -> Constraint) root =
  forall hole. (Rec c hole) =>
    Zipper hole (Context c hole root)

---- Internal types and functions
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

-- Left is essentially Ørjan Johansen’s free applicative functor.
-- (see http://ro-che.info/articles/2013-03-31-flavours-of-free-applicative-functors.html)
--
-- This allows us to convert any GTraversable value to a zipper.
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

-- Core interface

---- Injection and projection

-- | Move up a zipper to the root and return the root object.
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)

-- | Create a zipper.  The focus starts at the root of the object.
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

---- Basic movement

-- | Move left.  Returns 'Nothing' iff already at leftmost sibling.
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))

-- | Move right.  Returns 'Nothing' iff already at rightmost sibling.
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))

-- | Move down.  Moves to rightmost immediate child.  Returns 'Nothing' iff at a leaf and thus no children exist.
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))

-- | Move down. Move to the leftmost immediate child.  Returns 'Nothing' iff at a leaf and thus no children exist.
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)

-- | Move up.  Returns 'Nothing' iff already at root and thus no parent exists.
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)

---- Basic hole manipulation

-- | Apply a generic query to the hole.
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

-- | Apply a generic transformation to the 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

-- | Apply a generic monadic transformation to the hole
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)

-- Convenience hole manipulation interface

-- | Get the value in the hole.  Returns 'Nothing' iff @a@ is not the type of the value in the hole.
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

-- | Set the value in the hole.  Does nothing iff @a@ is not the type of the value in the hole.
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

-- | Set the value in the hole.  Returns 'Nothing' iff @a@ is not the type of the value in the hole.
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
-- Generic zipper traversals
---- Traversal helpers

-- | A movement operation such as 'left', 'right', 'up', or 'down'.
type Move c a = Zipper c a -> Maybe (Zipper c a)

-- | Apply a generic query using the specified movement operation.
moveQ :: Move c a -- ^ Move operation
      -> b -- ^ Default if can't move
      -> (Zipper c a -> b) -- ^ Query if can move
      -> Zipper c a -- ^ Zipper
      -> 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'

------ Query
-- | Apply a generic query to the left sibling if one exists.
leftQ :: b -- ^ Value to return of no left sibling exists.
      -> (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

-- | Apply a generic query to the right sibling if one exists.
rightQ :: b -- ^ Value to return if no right sibling exists.
       -> (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

-- | Move to the leftmost sibling.
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

-- | Move to the rightmost sibling.
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