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

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

import           Data.List ( elemIndex )
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 { forall a b. Zipper a b -> CList b
zRing :: C.CList b
           , forall a b. Zipper a b -> Seq (a, Seq b)
zTrees :: Seq.Seq (a, Seq.Seq b)
           }

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

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

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

position :: (Eq b) => Zipper a b -> Maybe Int
position :: forall b a. Eq b => Zipper a b -> Maybe Int
position Zipper a b
z = do
    b
f <- forall a b. Zipper a b -> Maybe b
focus Zipper a b
z
    forall a. Eq a => a -> [a] -> Maybe Int
elemIndex b
f forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. Zipper a b -> [(a, [b])]
toList Zipper a b
z

-- Move the focus one element to the left
left :: Zipper a b -> Zipper a b
left :: forall a b. Zipper a b -> Zipper a b
left Zipper a b
z = Zipper a b
z { zRing :: CList b
zRing = forall a. CList a -> CList a
C.rotL (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 :: forall a b.
Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
leftL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a b. Zipper a b -> Zipper a b
left (\ Zipper a b
_ Zipper a b
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 :: forall a b. Zipper a b -> Zipper a b
right Zipper a b
z = Zipper a b
z { zRing :: CList b
zRing = forall a. CList a -> CList a
C.rotR (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 :: forall a b.
Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)
rightL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a b. Zipper a b -> Zipper a b
right (\ Zipper a b
_ Zipper a b
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 :: forall a b. Zipper a b -> Maybe b
focus = forall a. CList a -> Maybe a
C.focus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Zipper a b -> CList b
zRing

-- Return the heading value corresponding to the focused value, if any
-- element is in focus
focusHeading :: (Eq b) => Zipper a b -> Maybe a
focusHeading :: forall b a. Eq b => Zipper a b -> Maybe a
focusHeading Zipper a b
z = do
    b
f <- forall a b. Zipper a b -> Maybe b
focus Zipper a b
z
    let matchesElems :: (a, t b) -> Bool
matchesElems (a
_, t b
es) = b
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t b
es
        matches :: [(a, [b])]
matches = forall a. (a -> Bool) -> [a] -> [a]
filter forall {t :: * -> *} {a}. Foldable t => (a, t b) -> Bool
matchesElems forall a b. (a -> b) -> a -> b
$ forall a b. Zipper a b -> [(a, [b])]
toList Zipper a b
z
    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, [b])]
matches

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

-- | Update the zipper's entry list, using the specified function
-- determine which entry should be selected in the new zipper state.
updateListBy :: (Eq b)
             => (Maybe b -> b -> Bool)
             -- ^ The comparison function. This is given the previous
             -- zipper's focus value (which is optional) and is given
             -- every element in the new zipper state for comparison.
             -- This should return True for the item in the new zipper
             -- that matches the focused item in the old zipper.
             -> [(a, [b])]
             -- ^ The new zipper list contents.
             -> Zipper a b
             -- ^ The old zipper.
             -> Zipper a b
updateListBy :: forall b a.
Eq b =>
(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 = forall b a. (b -> Bool) -> Zipper a b -> Zipper a b
findRight (Maybe b -> b -> Bool
f (forall a b. Zipper a b -> Maybe b
focus Zipper a b
oldZip)) forall a b. (a -> b) -> 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 :: forall c b a. Eq c => (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 = forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a b
z
        newTrees :: [(a, [c])]
newTrees = forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ Seq (a, Seq b)
oldTrees forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field2 s t a b => Lens s t a b
_2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe c
f)
    in 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 :: forall b a. Eq b => (b -> Bool) -> Zipper a b -> Zipper a b
filterZipper b -> Bool
f Zipper a b
oldZip = forall {a}. Zipper a b -> Zipper a b
maintainFocus Zipper a b
newZip
  where maintainFocus :: Zipper a b -> Zipper a b
maintainFocus = forall b a. (b -> Bool) -> Zipper a b -> Zipper a b
findRight ((forall a. Eq a => a -> a -> Bool
== forall a b. Zipper a b -> Maybe b
focus Zipper a b
oldZip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
        newZip :: Zipper a b
newZip = Zipper { zTrees :: Seq (a, Seq b)
zTrees = forall a b. Zipper a b -> Seq (a, Seq b)
zTrees Zipper a b
oldZip forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field2 s t a b => Lens s t a b
_2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter b -> Bool
f
                        , zRing :: CList b
zRing = forall a. (a -> Bool) -> CList a -> CList a
C.filterR b -> Bool
f (forall a b. Zipper a b -> CList b
zRing Zipper a b
oldZip)
                        }