{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Cursor.List.NonEmpty
( NonEmptyCursor(..)
, makeNonEmptyCursor
, makeNonEmptyCursorWithSelection
, singletonNonEmptyCursor
, rebuildNonEmptyCursor
, nonEmptyCursorElemL
, mapNonEmptyCursor
, nonEmptyCursorSelectPrev
, nonEmptyCursorSelectNext
, nonEmptyCursorSelectFirst
, nonEmptyCursorSelectLast
, nonEmptyCursorSelection
, nonEmptyCursorSelectIndex
, nonEmptyCursorInsert
, nonEmptyCursorAppend
, nonEmptyCursorInsertAndSelect
, nonEmptyCursorAppendAndSelect
, nonEmptyCursorInsertAtStart
, nonEmptyCursorAppendAtEnd
, nonEmptyCursorInsertAtStartAndSelect
, nonEmptyCursorAppendAtEndAndSelect
, nonEmptyCursorRemoveElemAndSelectPrev
, nonEmptyCursorDeleteElemAndSelectNext
, nonEmptyCursorRemoveElem
, nonEmptyCursorDeleteElem
, nonEmptyCursorSearch
, nonEmptyCursorSelectOrAdd
, renderNonEmptyCursor
, nonemptyPrepend
, nonemptyAppend
, traverseNonEmptyCursor
, foldNonEmptyCursor
) where
import GHC.Generics (Generic)
import Data.Validity
import Data.Maybe
import Control.Monad
import Lens.Micro
import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NE
import Cursor.Types
data NonEmptyCursor a b =
NonEmptyCursor
{ nonEmptyCursorPrev :: [b]
, nonEmptyCursorCurrent :: a
, nonEmptyCursorNext :: [b]
}
deriving (Show, Eq, Generic, Functor)
instance (Validity a, Validity b) => Validity (NonEmptyCursor a b)
makeNonEmptyCursor :: (b -> a) -> NonEmpty b -> NonEmptyCursor a b
makeNonEmptyCursor g = fromJust . makeNonEmptyCursorWithSelection g 0
makeNonEmptyCursorWithSelection ::
(b -> a) -> Int -> NonEmpty b -> Maybe (NonEmptyCursor a b)
makeNonEmptyCursorWithSelection g i ne = do
(l, m, r) <- applyNonEmptySelection ne i
pure
NonEmptyCursor
{ nonEmptyCursorPrev = reverse l
, nonEmptyCursorCurrent = g m
, nonEmptyCursorNext = r
}
where
applyNonEmptySelection :: NonEmpty a -> Int -> Maybe ([a], a, [a])
applyNonEmptySelection (c :| rest) i_
| i_ < 0 = Nothing
| i_ == 0 = Just ([], c, rest)
| otherwise = do
ne_ <- NE.nonEmpty rest
(l, m, r) <- applyNonEmptySelection ne_ (i_ - 1)
pure (c : l, m, r)
singletonNonEmptyCursor :: a -> NonEmptyCursor a b
singletonNonEmptyCursor a =
NonEmptyCursor
{ nonEmptyCursorPrev = []
, nonEmptyCursorCurrent = a
, nonEmptyCursorNext = []
}
rebuildNonEmptyCursor :: (a -> b) -> NonEmptyCursor a b -> NonEmpty b
rebuildNonEmptyCursor f NonEmptyCursor {..} =
nonemptyPrepend (reverse nonEmptyCursorPrev) $
f nonEmptyCursorCurrent :| nonEmptyCursorNext
mapNonEmptyCursor ::
(a -> c) -> (b -> d) -> NonEmptyCursor a b -> NonEmptyCursor c d
mapNonEmptyCursor f g NonEmptyCursor {..} =
NonEmptyCursor
{ nonEmptyCursorPrev = map g nonEmptyCursorPrev
, nonEmptyCursorCurrent = f nonEmptyCursorCurrent
, nonEmptyCursorNext = map g nonEmptyCursorNext
}
nonEmptyCursorElemL :: Lens (NonEmptyCursor a c) (NonEmptyCursor b c) a b
nonEmptyCursorElemL =
lens nonEmptyCursorCurrent $ \lec le -> lec {nonEmptyCursorCurrent = le}
nonEmptyCursorSelectPrev ::
(a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b)
nonEmptyCursorSelectPrev f g lec =
case nonEmptyCursorPrev lec of
[] -> Nothing
(e:rest) ->
Just $
lec
{ nonEmptyCursorPrev = rest
, nonEmptyCursorCurrent = g e
, nonEmptyCursorNext =
f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec
}
nonEmptyCursorSelectNext ::
(a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b)
nonEmptyCursorSelectNext f g lec =
case nonEmptyCursorNext lec of
[] -> Nothing
(e:rest) ->
Just $
lec
{ nonEmptyCursorPrev =
f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec
, nonEmptyCursorCurrent = g e
, nonEmptyCursorNext = rest
}
nonEmptyCursorSelectFirst ::
(a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorSelectFirst f g lec =
case nonEmptyCursorSelectPrev f g lec of
Nothing -> lec
Just lec' -> nonEmptyCursorSelectFirst f g lec'
nonEmptyCursorSelectLast ::
(a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorSelectLast f g lec =
case nonEmptyCursorSelectNext f g lec of
Nothing -> lec
Just lec' -> nonEmptyCursorSelectLast f g lec'
nonEmptyCursorSelection :: NonEmptyCursor a b -> Int
nonEmptyCursorSelection = length . nonEmptyCursorPrev
nonEmptyCursorSelectIndex ::
(a -> b)
-> (b -> a)
-> Int
-> NonEmptyCursor a b
-> Maybe (NonEmptyCursor a b)
nonEmptyCursorSelectIndex f g i nec
| i < nonEmptyCursorSelection nec =
nonEmptyCursorSelectPrev f g nec >>= nonEmptyCursorSelectIndex f g i
| i > nonEmptyCursorSelection nec =
nonEmptyCursorSelectNext f g nec >>= nonEmptyCursorSelectIndex f g i
| otherwise = Just nec
nonEmptyCursorInsert :: b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorInsert c lec =
lec {nonEmptyCursorPrev = c : nonEmptyCursorPrev lec}
nonEmptyCursorAppend :: b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorAppend c lec =
lec {nonEmptyCursorNext = c : nonEmptyCursorNext lec}
nonEmptyCursorInsertAndSelect ::
(a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorInsertAndSelect f c lec =
lec
{ nonEmptyCursorCurrent = c
, nonEmptyCursorNext =
f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec
}
nonEmptyCursorAppendAndSelect ::
(a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorAppendAndSelect f c lec =
lec
{ nonEmptyCursorCurrent = c
, nonEmptyCursorPrev =
f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec
}
nonEmptyCursorInsertAtStart :: b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorInsertAtStart c lec =
lec {nonEmptyCursorPrev = nonEmptyCursorPrev lec ++ [c]}
nonEmptyCursorAppendAtEnd :: b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorAppendAtEnd c lec =
lec {nonEmptyCursorNext = nonEmptyCursorNext lec ++ [c]}
nonEmptyCursorInsertAtStartAndSelect ::
(a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorInsertAtStartAndSelect f g c =
nonEmptyCursorSelectFirst f g . nonEmptyCursorInsertAtStart c
nonEmptyCursorAppendAtEndAndSelect ::
(a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b
nonEmptyCursorAppendAtEndAndSelect f g c =
nonEmptyCursorSelectLast f g . nonEmptyCursorAppendAtEnd c
nonEmptyCursorRemoveElemAndSelectPrev ::
(b -> a)
-> NonEmptyCursor a b
-> Maybe (DeleteOrUpdate (NonEmptyCursor a b))
nonEmptyCursorRemoveElemAndSelectPrev g lec =
case nonEmptyCursorPrev lec of
[] ->
case nonEmptyCursorNext lec of
[] -> Just Deleted
_ -> Nothing
(e:rest) ->
Just $
Updated $ lec {nonEmptyCursorPrev = rest, nonEmptyCursorCurrent = g e}
nonEmptyCursorDeleteElemAndSelectNext ::
(b -> a)
-> NonEmptyCursor a b
-> Maybe (DeleteOrUpdate (NonEmptyCursor a b))
nonEmptyCursorDeleteElemAndSelectNext g lec =
case nonEmptyCursorNext lec of
[] ->
case nonEmptyCursorPrev lec of
[] -> Just Deleted
_ -> Nothing
(e:rest) ->
Just $
Updated $ lec {nonEmptyCursorCurrent = g e, nonEmptyCursorNext = rest}
nonEmptyCursorRemoveElem ::
(b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b)
nonEmptyCursorRemoveElem g lec =
joinDeletes
(nonEmptyCursorRemoveElemAndSelectPrev g lec)
(nonEmptyCursorDeleteElemAndSelectNext g lec)
nonEmptyCursorDeleteElem ::
(b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b)
nonEmptyCursorDeleteElem g lec =
joinDeletes
(nonEmptyCursorDeleteElemAndSelectNext g lec)
(nonEmptyCursorRemoveElemAndSelectPrev g lec)
nonEmptyCursorSearch ::
(a -> b)
-> (b -> a)
-> (a -> Bool)
-> NonEmptyCursor a b
-> Maybe (NonEmptyCursor a b)
nonEmptyCursorSearch f g p nec =
if p $ nonEmptyCursorCurrent nec
then Just nec
else lookPrev nec `mplus` lookNext nec
where
lookPrev = look nonEmptyCursorSelectPrev
lookNext = look nonEmptyCursorSelectNext
look func nec_ = do
nec' <- func f g nec_
if p $ nonEmptyCursorCurrent nec'
then Just nec'
else look func nec'
nonEmptyCursorSelectOrAdd ::
(a -> b)
-> (b -> a)
-> (a -> Bool)
-> a
-> NonEmptyCursor a b
-> NonEmptyCursor a b
nonEmptyCursorSelectOrAdd f g p a nec =
case nonEmptyCursorSearch f g p nec of
Nothing -> nonEmptyCursorAppendAndSelect f a nec
Just nec' -> nec'
renderNonEmptyCursor :: ([b] -> a -> [b] -> c) -> NonEmptyCursor a b -> c
renderNonEmptyCursor f NonEmptyCursor {..} =
f (reverse nonEmptyCursorPrev) nonEmptyCursorCurrent nonEmptyCursorNext
nonemptyPrepend :: [a] -> NonEmpty a -> NonEmpty a
nonemptyPrepend ls ne = foldr (<|) ne ls
nonemptyAppend :: NonEmpty a -> [a] -> NonEmpty a
nonemptyAppend (x :| xs) ls = x :| (xs ++ ls)
traverseNonEmptyCursor :: ([b] -> a -> [b] -> f c) -> NonEmptyCursor a b -> f c
traverseNonEmptyCursor = foldNonEmptyCursor
foldNonEmptyCursor :: ([b] -> a -> [b] -> c) -> NonEmptyCursor a b -> c
foldNonEmptyCursor func NonEmptyCursor {..} =
func (reverse nonEmptyCursorPrev) nonEmptyCursorCurrent nonEmptyCursorNext