Applicative Fold

applicative-fold.hs

import Control.Applicative
import Control.Arrow

-- foldr-version of http://squing.blogspot.com/2008/11/beautiful-folding.html
data Fold a c = forall b. Fold (a -> b -> b) b (b -> c)

runFold :: Fold a c -> [a] -> c
runFold (Fold cons nil c) ls = c . foldr cons nil $ ls

both :: Fold a c -> Fold a c' -> Fold a (c,c')
both (Fold cons nil c) (Fold cons' nil' c')
  = Fold (liftA2 (***) cons cons') (nil,nil') (c *** c')

after :: Fold a c -> (c -> d) -> Fold a d
after (Fold cons nil c) f = Fold cons nil (f . c)

bothWith :: (c -> c' -> d) -> Fold a c -> Fold a c' -> Fold a d
bothWith f fold fold' = after (both fold fold') (uncurry f)

sumF :: (Num n) => Fold n n
sumF = Fold (+) 0 id

productF :: (Num n) => Fold n n
productF = Fold (*) 1 id

lengthF :: Fold n Int
lengthF = Fold (const succ) 0 id

meanF :: (Fractional n) => Fold n n
meanF = liftA2 (/) sumF (fmap fromIntegral lengthF)

constF :: c -> Fold a c
constF c = Fold cons el (const c)
  where cons = cons; el = el

instance Functor (Fold a) where
  fmap = flip after

instance Applicative (Fold a) where
  pure = constF
  f <*> g = bothWith ($) f g