Cumulative monoidal append

cumulative1.hs

module Cumulative
  ( makeCumulative
  , makeCumulativeReverse
  ) where

import Data.Traversable
import Data.Monoid

-- | Make a traversable data structure cumulative by performing a left-biased
-- partial sum (actually a monoidal append). Linear time.
--
-- >>> makeCumulative (M.fromList [(1, "one"), (3, "three"), (2, "two")])
-- fromList [(1,"one"),(2,"onetwo"),(3,"onetwothree")]
makeCumulative :: (Monoid w, Traversable t) => t w -> t w
makeCumulative = snd . mapAccumL (\acc a -> let !r = acc <> a in (r, r)) mempty

-- | Like 'makeCumulative' but in reverse. Also linear time.
--
-- >>> makeCumulativeReverse (M.fromList [(1, "one"), (3, "three"), (2, "two")])
-- fromList [(1,"onetwothree"),(2,"twothree"),(3,"three")]
makeCumulativeReverse :: (Monoid w, Traversable t) => t w -> t w
makeCumulativeReverse = snd . mapAccumR (\acc a -> let !r = a <> acc in (r, r)) mempty

cumulative2.hs

{-# LANGUAGE DeriveFunctor #-}
module Cumulative
  ( makeCumulative
  , makeCumulativeReverse
  ) where

import Control.Monad.State
import Data.Monoid

-- | Make a traversable data structure cumulative by performing a left-biased
-- partial sum (actually a monoidal append). Linear time.
--
-- >>> makeCumulative (M.fromList [(1, "one"), (3, "three"), (2, "two")])
-- fromList [(1,"one"),(2,"onetwo"),(3,"onetwothree")]
makeCumulative :: (Monoid w, Traversable t) => t w -> t w
makeCumulative t = evalState (traverse (\b -> state $ \s -> let !r = s <> b in (r, r)) t) mempty

-- | Like 'makeCumulative' but in reverse. Also linear time.
--
-- >>> makeCumulativeReverse (M.fromList [(1, "one"), (3, "three"), (2, "two")])
-- fromList [(1,"onetwothree"),(2,"twothree"),(3,"three")]
makeCumulativeReverse :: (Monoid w, Traversable t) => t w -> t w
makeCumulativeReverse t = evalReverseState (traverse (\b -> ReverseState $ \s -> let r = b <> s in (r, r)) t) mempty

-- | Like the state monad, but the state is sequenced in reverse, i.e. the bind
-- operator allows you to get the /future/ state and compute the /past/ state.
-- Pretty irritating; perhaps that's why this isn't included by default in
-- transformers.
newtype ReverseState s a = ReverseState
  { runReverseState :: s -> (a, s)
  } deriving Functor

evalReverseState :: ReverseState s a -> s -> a
evalReverseState m s = fst (runReverseState m s)

instance Applicative (ReverseState s) where
  pure x = ReverseState $ (,) x
  mf <*> mx =
    ReverseState $ \s ->
      let (f, past) = runReverseState mf now
          (x, now) = runReverseState mx s
      in (f x, past)

instance Monad (ReverseState s) where
  mx >>= f =
    ReverseState $ \s ->
      let (a, past) = runReverseState mx future
          (b, future) = runReverseState (f a) s
      in (b, past)