-- | An implementation of a zipper-like non-empty list structure that tracks -- an index position in the list (the 'focus'). module Data.List.PointedList where import Prelude hiding (foldl, foldr) import Control.Applicative import Control.Monad import Data.Binary import Data.Foldable import Data.List hiding (foldl, foldr) import Data.Maybe import Data.Traversable -- | The implementation of the pointed list structure which tracks the current -- position in the list structure. data PointedList a = PointedList [a] a [a] deriving (Eq, Ord {-! Binary !-}) instance (Show a) => Show (PointedList a) where show (PointedList ls x rs) = show (reverse ls) ++ " " ++ show x ++ " " ++ show rs instance Functor PointedList where fmap f (PointedList ls x rs) = PointedList (map f ls) (f x) (map f rs) instance Foldable PointedList where foldr f z (PointedList ls x rs) = foldl (flip f) (foldr f z (x:rs)) ls instance Traversable PointedList where traverse f (PointedList ls x rs) = PointedList <$> (reverse <$> traverse f (reverse ls)) <*> f x <*> traverse f rs -- | Create a @PointedList@ with a single element. singleton :: a -> PointedList a singleton x = PointedList [] x [] -- | Possibly create a @Just PointedList@ if the provided list has at least one -- element; otherwise, return Nothing. -- -- The provided list's head will be the focus of the list, and the rest of -- list will follow on the right side. fromList :: [a] -> Maybe (PointedList a) fromList [] = Nothing fromList (x:xs) = Just $ PointedList [] x xs -- | Possibly create a @Just PointedList@ if the provided list has at least one -- element; otherwise, return Nothing. -- -- The provided list's last element will be the focus of the list, following -- the rest of the list in order, to the left. fromListEnd :: [a] -> Maybe (PointedList a) fromListEnd [] = Nothing fromListEnd xs = Just $ PointedList xs' x [] where (x:xs') = reverse xs -- | The focus element of the pointed list. focus :: PointedList a -> a focus (PointedList _ x _) = x -- | Possibly move the focus to the next element in the list. next :: PointedList a -> Maybe (PointedList a) next (PointedList _ _ []) = Nothing next p = (Just . tryNext) p -- GHC doesn't allow PL form here -- | Attempt to move the focus to the next element, or 'error' if there are -- no more elements. tryNext :: PointedList a -> PointedList a tryNext p@(PointedList _ _ [] ) = error "cannot move to next element" tryNext (PointedList ls x (r:rs)) = PointedList (x:ls) r rs -- | Possibly move the focus to the previous element in the list. previous :: PointedList a -> Maybe (PointedList a) previous (PointedList [] _ _ ) = Nothing previous p = (Just . tryPrevious) p -- | Attempt to move the focus to the previous element, or 'error' if there are -- no more elements. tryPrevious :: PointedList a -> PointedList a tryPrevious p@(PointedList [] _ _ ) = error "cannot move to previous element" tryPrevious (PointedList (l:ls) x rs) = PointedList ls l (x:rs) -- | An alias for 'insertRight'. insert :: a -> PointedList a -> PointedList a insert = insertRight -- | Insert an element to the left of the focus, then move the focus to the new -- element. insertLeft :: a -> PointedList a -> PointedList a insertLeft y (PointedList ls x rs) = PointedList ls y (x:rs) -- | Insert an element to the right of the focus, then move the focus to the -- new element. insertRight :: a -> PointedList a -> PointedList a insertRight y (PointedList ls x rs) = PointedList (x:ls) y rs -- | An alias of 'deleteRight'. delete :: PointedList a -> Maybe (PointedList a) delete = deleteRight -- | Possibly delete the element at the focus, then move the element on the -- left to the focus. If no element is on the left, focus on the element to -- the right. If the deletion will cause the list to be empty, return -- @Nothing@. deleteLeft :: PointedList a -> Maybe (PointedList a) deleteLeft (PointedList [] _ [] ) = Nothing deleteLeft (PointedList (l:ls) _ rs) = Just $ PointedList ls l rs deleteLeft (PointedList [] _ (r:rs)) = Just $ PointedList [] r rs -- | Possibly delete the element at the focus, then move the element on the -- right to the focus. If no element is on the right, focus on the element to -- the left. If the deletion will cause the list to be empty, return -- @Nothing@. deleteRight :: PointedList a -> Maybe (PointedList a) deleteRight (PointedList [] _ [] ) = Nothing deleteRight (PointedList ls _ (r:rs)) = Just $ PointedList ls r rs deleteRight (PointedList (l:ls) _ []) = Just $ PointedList ls l [] -- | The length of the list. length :: PointedList a -> Int length = foldr (const (+1)) 0 -- | Whether the focus is the first element. atStart :: PointedList a -> Bool atStart (PointedList [] _ _) = True atStart _ = False -- | Whether the focus is the last element. atEnd :: PointedList a -> Bool atEnd (PointedList _ _ []) = True atEnd _ = False -- | Create a @PointedList@ of variations of the provided @PointedList@, in -- which each element is focused, with the provided @PointedList@ as the -- focus of the sets. positions :: PointedList a -> PointedList (PointedList a) positions p@(PointedList ls x rs) = PointedList left p right where left = unfoldr (\p -> fmap (join (,)) $ previous p) p right = unfoldr (\p -> fmap (join (,)) $ next p) p -- | Map over the @PointedList@s created via 'positions', such that @f@ is -- called with each element of the list focused in the provided -- @PointedList@. An example makes this easier to understand: -- -- > contextMap atStart (fromJust $ fromList [1..5]) contextMap :: (PointedList a -> b) -> PointedList a -> PointedList b contextMap f z = fmap f $ positions z -------------------------------------------------------- -- DERIVES GENERATED CODE -- DO NOT MODIFY BELOW THIS LINE -- CHECKSUM: 1323105363 instance Binary t1 => Binary (PointedList t1) where put (PointedList x1 x2 x3) = return () >> (put x1 >> (put x2 >> put x3)) get = case 0 of 0 -> ap (ap (ap (return PointedList) get) get) get