module Matterhorn.Zipper
  ( Zipper
  , fromList
  , toList
  , focus
  , unsafeFocus
  , left
  , leftL
  , right
  , rightL
  , findRight
  , maybeFindRight
  , updateList
  , updateListBy
  , filterZipper
  , maybeMapZipper
  , isEmpty
  )
where

import           Prelude ()
import           Matterhorn.Prelude hiding (toList)

import           Data.Maybe ( fromJust )
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.CircularList as C
import           Lens.Micro.Platform

data Zipper a b =
    Zipper { Zipper a b -> CList b
zRing :: C.CList b
           , Zipper a b -> Seq (a, Seq b)
zTrees :: Seq.Seq (a, Seq.Seq b)
           }

instance F.Foldable (Zipper a) where
    foldMap :: (a -> m) -> Zipper a a -> m
foldMap a -> m
f = (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ([a] -> m) -> (Zipper a a -> [a]) -> Zipper a a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq a -> [a]) -> (Zipper a a -> Seq a) -> Zipper a a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                [Seq a] -> Seq a
forall a. Monoid a => [a] -> a
mconcat ([Seq a] -> Seq a)
-> (Zipper a a -> [Seq a]) -> Zipper a a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Seq (Seq a) -> [Seq a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Seq a) -> [Seq a])
-> (Zipper a a -> Seq (Seq a)) -> Zipper a a -> [Seq a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                ((a, Seq a) -> Seq a) -> Seq (a, Seq a) -> Seq (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Seq a) -> Seq a
forall a b. (a, b) -> b
snd (Seq (a, Seq a) -> Seq (Seq a))
-> (Zipper a a -> Seq (a, Seq a)) -> Zipper a a -> Seq (Seq a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Zipper a a -> Seq (a, Seq a)
forall a b. Zipper a b -> Seq (a, Seq b)
zTrees

instance Functor (Zipper a) where
    fmap :: (a -> b) -> Zipper a a -> Zipper a b
fmap a -> b
f Zipper a a
z =
        Zipper :: forall a b. CList b -> Seq (a, Seq b) -> Zipper a b
Zipper { zRing :: CList b
zRing = a -> b
f (a -> b) -> CList a -> CList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Zipper a a -> CList a
forall a b. Zipper a b -> CList b
zRing Zipper a a
z
               , zTrees :: Seq (a, Seq b)
zTrees = Zipper a a -> Seq (a, Seq a)
forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a a
z Seq (a, Seq a)
-> (Seq (a, Seq a) -> Seq (a, Seq b)) -> Seq (a, Seq b)
forall a b. a -> (a -> b) -> b
& ASetter (Seq (a, Seq a)) (Seq (a, Seq b)) (a, Seq a) (a, Seq b)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter (Seq (a, Seq a)) (Seq (a, Seq b)) (a, Seq a) (a, Seq b)
-> ((a -> Identity b) -> (a, Seq a) -> Identity (a, Seq b))
-> (a -> Identity b)
-> Seq (a, Seq a)
-> Identity (Seq (a, Seq b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq a -> Identity (Seq b)) -> (a, Seq a) -> Identity (a, Seq b)
forall s t a b. Field2 s t a b => Lens s t a b
_2((Seq a -> Identity (Seq b)) -> (a, Seq a) -> Identity (a, Seq b))
-> ((a -> Identity b) -> Seq a -> Identity (Seq b))
-> (a -> Identity b)
-> (a, Seq a)
-> Identity (a, Seq b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Identity b) -> Seq a -> Identity (Seq b)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ((a -> Identity b) -> Seq (a, Seq a) -> Identity (Seq (a, Seq b)))
-> (a -> b) -> Seq (a, Seq a) -> Seq (a, Seq b)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> b
f
               }

isEmpty :: Zipper a b -> Bool
isEmpty :: Zipper a b -> Bool
isEmpty = CList b -> Bool
forall a. CList a -> Bool
C.isEmpty (CList b -> Bool) -> (Zipper a b -> CList b) -> Zipper a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing

-- Move the focus one element to the left
left :: Zipper a b -> Zipper a b
left :: Zipper a b -> Zipper a b
left Zipper a b
z = Zipper a b
z { zRing :: CList b
zRing = CList b -> CList b
forall a. CList a -> CList a
C.rotL (Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing Zipper a b
z) }

-- A lens on the zipper moved to the left
leftL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
leftL :: (Zipper a b -> f (Zipper a b)) -> Zipper a b -> f (Zipper a b)
leftL = (Zipper a b -> Zipper a b)
-> (Zipper a b -> Zipper a b -> Zipper a b)
-> Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Zipper a b -> Zipper a b
forall a b. Zipper a b -> Zipper a b
left (\ Zipper a b
_ Zipper a b
b -> Zipper a b -> Zipper a b
forall a b. Zipper a b -> Zipper a b
right Zipper a b
b)

-- Move the focus one element to the right
right :: Zipper a b -> Zipper a b
right :: Zipper a b -> Zipper a b
right Zipper a b
z = Zipper a b
z { zRing :: CList b
zRing = CList b -> CList b
forall a. CList a -> CList a
C.rotR (Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing Zipper a b
z) }

-- A lens on the zipper moved to the right
rightL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
rightL :: (Zipper a b -> f (Zipper a b)) -> Zipper a b -> f (Zipper a b)
rightL = (Zipper a b -> Zipper a b)
-> (Zipper a b -> Zipper a b -> Zipper a b)
-> Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Zipper a b -> Zipper a b
forall a b. Zipper a b -> Zipper a b
right (\ Zipper a b
_ Zipper a b
b -> Zipper a b -> Zipper a b
forall a b. Zipper a b -> Zipper a b
left Zipper a b
b)

-- Return the focus element
focus :: Zipper a b -> Maybe b
focus :: Zipper a b -> Maybe b
focus = CList b -> Maybe b
forall a. CList a -> Maybe a
C.focus (CList b -> Maybe b)
-> (Zipper a b -> CList b) -> Zipper a b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing

unsafeFocus :: Zipper a b -> b
unsafeFocus :: Zipper a b -> b
unsafeFocus = Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (Zipper a b -> Maybe b) -> Zipper a b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a b -> Maybe b
forall a b. Zipper a b -> Maybe b
focus

-- Turn a list into a wraparound zipper, focusing on the head
fromList :: (Eq b) => [(a, [b])] -> Zipper a b
fromList :: [(a, [b])] -> Zipper a b
fromList [(a, [b])]
xs =
    let ts :: Seq (a, Seq b)
ts = [(a, Seq b)] -> Seq (a, Seq b)
forall a. [a] -> Seq a
Seq.fromList ([(a, Seq b)] -> Seq (a, Seq b)) -> [(a, Seq b)] -> Seq (a, Seq b)
forall a b. (a -> b) -> a -> b
$ [(a, [b])]
xs [(a, [b])] -> ([(a, [b])] -> [(a, Seq b)]) -> [(a, Seq b)]
forall a b. a -> (a -> b) -> b
& ASetter [(a, [b])] [(a, Seq b)] (a, [b]) (a, Seq b)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter [(a, [b])] [(a, Seq b)] (a, [b]) (a, Seq b)
-> (([b] -> Identity (Seq b)) -> (a, [b]) -> Identity (a, Seq b))
-> ([b] -> Identity (Seq b))
-> [(a, [b])]
-> Identity [(a, Seq b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([b] -> Identity (Seq b)) -> (a, [b]) -> Identity (a, Seq b)
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([b] -> Identity (Seq b)) -> [(a, [b])] -> Identity [(a, Seq b)])
-> ([b] -> Seq b) -> [(a, [b])] -> [(a, Seq b)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [b] -> Seq b
forall a. [a] -> Seq a
Seq.fromList
        tsList :: [b]
tsList = Seq b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq b -> [b]) -> Seq b -> [b]
forall a b. (a -> b) -> a -> b
$ [Seq b] -> Seq b
forall a. Monoid a => [a] -> a
mconcat ([Seq b] -> Seq b) -> [Seq b] -> Seq b
forall a b. (a -> b) -> a -> b
$ Seq (Seq b) -> [Seq b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Seq b) -> [Seq b]) -> Seq (Seq b) -> [Seq b]
forall a b. (a -> b) -> a -> b
$ (a, Seq b) -> Seq b
forall a b. (a, b) -> b
snd ((a, Seq b) -> Seq b) -> Seq (a, Seq b) -> Seq (Seq b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (a, Seq b)
ts
        maybeFocus :: CList b -> CList b
maybeFocus = if [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
tsList
                     then CList b -> CList b
forall a. a -> a
id
                     else Maybe (CList b) -> CList b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CList b) -> CList b)
-> (CList b -> Maybe (CList b)) -> CList b -> CList b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> CList b -> Maybe (CList b)
forall a. Eq a => a -> CList a -> Maybe (CList a)
C.rotateTo ([b]
tsList [b] -> Int -> b
forall a. [a] -> Int -> a
!! Int
0)
    in Zipper :: forall a b. CList b -> Seq (a, Seq b) -> Zipper a b
Zipper { zRing :: CList b
zRing = CList b -> CList b
maybeFocus (CList b -> CList b) -> CList b -> CList b
forall a b. (a -> b) -> a -> b
$ [b] -> CList b
forall a. [a] -> CList a
C.fromList [b]
tsList
              , zTrees :: Seq (a, Seq b)
zTrees = Seq (a, Seq b)
ts
              }

toList :: Zipper a b -> [(a, [b])]
toList :: Zipper a b -> [(a, [b])]
toList Zipper a b
z = Seq (a, [b]) -> [(a, [b])]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (a, [b]) -> [(a, [b])]) -> Seq (a, [b]) -> [(a, [b])]
forall a b. (a -> b) -> a -> b
$ Zipper a b -> Seq (a, Seq b)
forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a b
z Seq (a, Seq b) -> (Seq (a, Seq b) -> Seq (a, [b])) -> Seq (a, [b])
forall a b. a -> (a -> b) -> b
& ASetter (Seq (a, Seq b)) (Seq (a, [b])) (a, Seq b) (a, [b])
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter (Seq (a, Seq b)) (Seq (a, [b])) (a, Seq b) (a, [b])
-> ((Seq b -> Identity [b]) -> (a, Seq b) -> Identity (a, [b]))
-> (Seq b -> Identity [b])
-> Seq (a, Seq b)
-> Identity (Seq (a, [b]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq b -> Identity [b]) -> (a, Seq b) -> Identity (a, [b])
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Seq b -> Identity [b])
 -> Seq (a, Seq b) -> Identity (Seq (a, [b])))
-> (Seq b -> [b]) -> Seq (a, Seq b) -> Seq (a, [b])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Seq b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

-- Shift the focus until a given element is found, or return the
-- same zipper if none applies
findRight :: (b -> Bool) -> Zipper a b -> Zipper a b
findRight :: (b -> Bool) -> Zipper a b -> Zipper a b
findRight b -> Bool
f Zipper a b
z = Zipper a b -> Maybe (Zipper a b) -> Zipper a b
forall a. a -> Maybe a -> a
fromMaybe Zipper a b
z (Maybe (Zipper a b) -> Zipper a b)
-> Maybe (Zipper a b) -> Zipper a b
forall a b. (a -> b) -> a -> b
$ (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)
forall b a. (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)
maybeFindRight b -> Bool
f Zipper a b
z

-- Shift the focus until a given element is found, or return
-- Nothing if none applies
maybeFindRight :: (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)
maybeFindRight :: (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)
maybeFindRight b -> Bool
f Zipper a b
z = do
    CList b
newRing <- (b -> Bool) -> CList b -> Maybe (CList b)
forall a. (a -> Bool) -> CList a -> Maybe (CList a)
C.findRotateTo b -> Bool
f (Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing Zipper a b
z)
    Zipper a b -> Maybe (Zipper a b)
forall (m :: * -> *) a. Monad m => a -> m a
return Zipper a b
z { zRing :: CList b
zRing = CList b
newRing }

updateList :: (Eq b) => [(a, [b])] -> Zipper a b -> Zipper a b
updateList :: [(a, [b])] -> Zipper a b -> Zipper a b
updateList [(a, [b])]
newList Zipper a b
oldZip = (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b
forall b a.
Eq b =>
(Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b
updateListBy (\Maybe b
old b
b -> Maybe b
old Maybe b -> Maybe b -> Bool
forall a. Eq a => a -> a -> Bool
== b -> Maybe b
forall a. a -> Maybe a
Just b
b) [(a, [b])]
newList Zipper a b
oldZip

updateListBy :: (Eq b) => (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b
updateListBy :: (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b
updateListBy Maybe b -> b -> Bool
f [(a, [b])]
newList Zipper a b
oldZip = (b -> Bool) -> Zipper a b -> Zipper a b
forall b a. (b -> Bool) -> Zipper a b -> Zipper a b
findRight (Maybe b -> b -> Bool
f (Zipper a b -> Maybe b
forall a b. Zipper a b -> Maybe b
focus Zipper a b
oldZip)) (Zipper a b -> Zipper a b) -> Zipper a b -> Zipper a b
forall a b. (a -> b) -> a -> b
$ [(a, [b])] -> Zipper a b
forall b a. Eq b => [(a, [b])] -> Zipper a b
fromList [(a, [b])]
newList

maybeMapZipper :: (Eq c) => (b -> Maybe c) -> Zipper a b -> Zipper a c
maybeMapZipper :: (b -> Maybe c) -> Zipper a b -> Zipper a c
maybeMapZipper b -> Maybe c
f Zipper a b
z =
    let oldTrees :: Seq (a, Seq b)
oldTrees = Zipper a b -> Seq (a, Seq b)
forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a b
z
        newTrees :: [(a, [c])]
newTrees = Seq (a, [c]) -> [(a, [c])]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (a, [c]) -> [(a, [c])]) -> Seq (a, [c]) -> [(a, [c])]
forall a b. (a -> b) -> a -> b
$ Seq (a, Seq b)
oldTrees Seq (a, Seq b) -> (Seq (a, Seq b) -> Seq (a, [c])) -> Seq (a, [c])
forall a b. a -> (a -> b) -> b
& ASetter (Seq (a, Seq b)) (Seq (a, [c])) (a, Seq b) (a, [c])
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter (Seq (a, Seq b)) (Seq (a, [c])) (a, Seq b) (a, [c])
-> ((Seq b -> Identity [c]) -> (a, Seq b) -> Identity (a, [c]))
-> (Seq b -> Identity [c])
-> Seq (a, Seq b)
-> Identity (Seq (a, [c]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq b -> Identity [c]) -> (a, Seq b) -> Identity (a, [c])
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Seq b -> Identity [c])
 -> Seq (a, Seq b) -> Identity (Seq (a, [c])))
-> (Seq b -> [c]) -> Seq (a, Seq b) -> Seq (a, [c])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Maybe c] -> [c]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe c] -> [c]) -> (Seq b -> [Maybe c]) -> Seq b -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Maybe c) -> [Maybe c]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Maybe c) -> [Maybe c])
-> (Seq b -> Seq (Maybe c)) -> Seq b -> [Maybe c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Maybe c) -> Seq b -> Seq (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe c
f)
    in [(a, [c])] -> Zipper a c
forall b a. Eq b => [(a, [b])] -> Zipper a b
fromList [(a, [c])]
newTrees

filterZipper :: (Eq b) => (b -> Bool) -> Zipper a b -> Zipper a b
filterZipper :: (b -> Bool) -> Zipper a b -> Zipper a b
filterZipper b -> Bool
f Zipper a b
oldZip = Zipper a b -> Zipper a b
forall a. Zipper a b -> Zipper a b
maintainFocus Zipper a b
newZip
  where maintainFocus :: Zipper a b -> Zipper a b
maintainFocus = (b -> Bool) -> Zipper a b -> Zipper a b
forall b a. (b -> Bool) -> Zipper a b -> Zipper a b
findRight ((Maybe b -> Maybe b -> Bool
forall a. Eq a => a -> a -> Bool
== Zipper a b -> Maybe b
forall a b. Zipper a b -> Maybe b
focus Zipper a b
oldZip) (Maybe b -> Bool) -> (b -> Maybe b) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just)
        newZip :: Zipper a b
newZip = Zipper :: forall a b. CList b -> Seq (a, Seq b) -> Zipper a b
Zipper { zTrees :: Seq (a, Seq b)
zTrees = Zipper a b -> Seq (a, Seq b)
forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a b
oldZip Seq (a, Seq b)
-> (Seq (a, Seq b) -> Seq (a, Seq b)) -> Seq (a, Seq b)
forall a b. a -> (a -> b) -> b
& ASetter (Seq (a, Seq b)) (Seq (a, Seq b)) (a, Seq b) (a, Seq b)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter (Seq (a, Seq b)) (Seq (a, Seq b)) (a, Seq b) (a, Seq b)
-> ((Seq b -> Identity (Seq b))
    -> (a, Seq b) -> Identity (a, Seq b))
-> (Seq b -> Identity (Seq b))
-> Seq (a, Seq b)
-> Identity (Seq (a, Seq b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq b -> Identity (Seq b)) -> (a, Seq b) -> Identity (a, Seq b)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Seq b -> Identity (Seq b))
 -> Seq (a, Seq b) -> Identity (Seq (a, Seq b)))
-> (Seq b -> Seq b) -> Seq (a, Seq b) -> Seq (a, Seq b)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (b -> Bool) -> Seq b -> Seq b
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter b -> Bool
f
                        , zRing :: CList b
zRing = (b -> Bool) -> CList b -> CList b
forall a. (a -> Bool) -> CList a -> CList a
C.filterR b -> Bool
f (Zipper a b -> CList b
forall a b. Zipper a b -> CList b
zRing Zipper a b
oldZip)
                        }