Trivial catenable sequence with amortized O(1) uncons and unsnoc

Catenable.hs

module Catenable (Catenable, empty, singleton, toList, fromList, uncons, unsnoc) where

import Data.List (foldl')
import Control.Monad

-- | Trivial catenable sequence. Supports O(1) append, and (amortized)
-- O(1) `uncons`, and `unsnoc`, such that walking the sequence via
-- N successive `uncons` steps or N `unsnoc` steps takes O(N). Like a
-- difference list, conversion to a `[a]` takes linear time, regardless
-- of how the sequence is built up.
--
-- Walking the sequence by alternating `unsnoc` and `uncons` is a worst-case
-- for this data structure and takes quadratic time.
data Catenable a = Empty | Single a | Append (Catenable a) (Catenable a)

instance Ord a => Ord (Catenable a) where
  a `compare` b = toList a `compare` toList b

instance Eq a => Eq (Catenable a) where
  a == b = toList a == toList b

instance Functor Catenable where
  fmap = liftM

instance Applicative Catenable where
  pure = return
  (<*>) = ap

instance Monad Catenable where
  return = Single
  a >>= f = case a of
    Single a -> f a
    Empty -> Empty
    Append l r -> Append (l >>= f) (r >>= f)

-- | Totally legit, since constructors not exposed and all operations
-- quotient out the internal grouping structure of the `Catenable`.
instance Monoid (Catenable a) where
  mempty = Empty
  mappend = Append

empty :: Catenable a
empty = Empty

singleton :: a -> Catenable a
singleton = Single

toList :: Catenable a -> [a]
toList c = go c [] where
  go Empty [] = []
  go Empty (hd:rights) = go hd rights
  go (Single a) rights = a : go Empty rights
  go (Append l r) rights = go l (r : rights)

fromList :: [a] -> Catenable a
fromList = foldr (\hd tl -> Single hd `Append` tl) Empty

uncons :: Catenable a -> Maybe (a, Catenable a)
uncons c = go c [] where
  go Empty [] = Nothing
  go Empty (hd:rights) = go hd rights
  go (Single a) rights = Just (a, foldr Append Empty rights)
  go (Append l r) rights = go l (r : rights)

unsnoc :: Catenable a -> Maybe (Catenable a, a)
unsnoc c = go c [] where
  go Empty [] = Nothing
  go Empty (hd:lefts) = go hd lefts
  go (Single a) lefts = Just (foldl' Append Empty lefts, a)
  go (Append l r) lefts = go r (l : lefts)