PointedList.hs

-- | 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.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)

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 'deleteRight'.
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