Fold with a monoidal accumulator

folds.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative
import Data.Monoid
import Control.Monad.Trans.State.Lazy (State,runState,get,put)

-- Lazy in the monoidal accumulator. Monoidal accumulation
-- happens from left to right.
foldlMapA :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
foldlMapA f = foldr f' (pure mempty)
  where
  f' :: a -> m b -> m b
  f' x y = liftA2 mappend (f x) y

-- Lazy in the monoidal accumulator. Monoidal accumulation
-- happens from left to right.
foldrMapA :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
foldrMapA f = foldl f' (pure mempty)
  where
  f' :: m b -> a -> m b
  f' y x = liftA2 (flip mappend) (f x) y

-- Strict in the monoidal accumulator. For monads strict
-- in the left argument of bind, this will run in constant
-- space. Monoidal accumulation happens from left to right.
foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldlMapM' f xs = foldr f' pure xs mempty
  where
  f' :: a -> (b -> m b) -> b -> m b
  f' x k bl = do
    br <- f x
    let !b = mappend bl br
    k b

-- Strict in the monoidal accumulator. 
-- Monoidal accumulation happens from left to right.
foldrMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldrMapM' f xs = foldl f' return xs mempty
  where
  f' :: (b -> m b) -> a -> b -> m b
  f' k x br = do
    bl <- f x
    let !b = mappend bl br
    k b

naturals :: [Integer]
naturals = enumFrom 0

addSmallMaybe :: Integer -> Maybe (Sum Integer)
addSmallMaybe i = if i < 100000000 then Just (Sum i) else Nothing

addSmallState :: Integer -> State Integer (Sum Integer)
addSmallState i = do
  j <- if i < 30
    then fmap Sum get
    else return mempty
  put i
  return j

newtype Ap f a = Ap {getAp :: f a}
instance (Applicative f, Monoid a) => Monoid (Ap f a) where
  mempty = Ap $ pure mempty
  mappend (Ap x) (Ap y) = Ap $ liftA2 mappend x y

xs :: [Int]
xs = [2,5,9,11]

displayAndSingletonList :: Show a => a -> IO [a]
displayAndSingletonList a = do
  putStr (show a ++ ",")
  return [a]

main :: IO ()
main = do
  putStrLn "To restrict the maximum heap size, is recommended that this "
  putStrLn "be compiled and run with:"
  putStrLn "> ghc -rtsopts folds.hs"
  putStrLn "> ./folds +RTS -M100M"
  putStrLn ""
  putStrLn ("Input List: " ++ show xs)
  putStrLn ""
  putStrLn "The action taken for each elements consists of printing out the element "
  putStrLn "and then returning it as a singleton list. Since mappend is not communtative "
  putStrLn "for lists, this helps us see whether elements end up being mappended "
  putStrLn "left-to-right or right-to-left."
  putStrLn ""
  putStrLn "foldlMapA"
  foldlMapA displayAndSingletonList xs >>= putStrLn . (\s -> "\nResult: " ++ show s)
  putStrLn ""
  putStrLn "foldrMapA"
  foldrMapA displayAndSingletonList xs >>= putStrLn . (\s -> "\nResult: " ++ show s)
  putStrLn ""
  putStrLn "foldlMapM'"
  foldlMapM' displayAndSingletonList xs >>= putStrLn . (\s -> "\nResult: " ++ show s)
  putStrLn ""
  putStrLn "foldrMapM'"
  foldrMapM' displayAndSingletonList xs >>= putStrLn . (\s -> "\nResult: " ++ show s)
  putStrLn "Now, we check for some strictness-related things. We are mostly just"
  putStrLn "trying to make sure that these do not (a) leak space or (b) evaluate"
  putStrLn "unneeded elements."
  putStrLn ""
  putStrLn "Checking for space leak. This function should return Nothing."
  putStrLn "foldlMapM' (\\i -> if i < 100000000 then Just (Sum i) else Nothing) (enumFrom (0 :: Integer))"
  print (foldlMapM' addSmallMaybe naturals)
  putStrLn ""
  -- This part is currently broken.
  -- putStrLn "Checking for space leak. This function should return 5."
  -- putStrLn "runState (foldrMapA' addSmallState (enumFrom (0 :: Integer)) 0)"
  -- print (runState (foldrMapA addSmallState (enumFrom (0 :: Integer))) 0)