FoldL.hs

{-# LANGUAGE ExistentialQuantification, FlexibleContexts #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.Zip.FoldL
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Zipping of non-strict left folds.
-- 
-- See <http://conal.net/blog/tag/zip>.  Inspired by "Beautiful FoldLs" by
-- Max Rabkin <http://squing.blogspot.com/2008/11/beautiful-folding.html>
----------------------------------------------------------------------

module Data.Zip.FoldL
  ( FoldL(..), cfoldl, cfoldl', unitL
  , WithCont , FoldLC , cfoldlc
  , WithCont', FoldLC', cfoldlc'
  , Zip'(..), P(..)
  ) where

import Prelude hiding (zip)

import Data.Monoid
import Control.Applicative
import Data.List (foldl')

import Data.Zip

import Data.WithCont

-- foldl :: (a -> b -> a) -> a -> [b] -> a

-- | Data representation of a left fold
data FoldL b a = F (a -> b -> a) a

-- TODO: merge unit into Zip.

unitL :: FoldL b ()
unitL = F const ()


-- | Interpretation of a 'FoldL' as non-strict
cfoldl :: FoldL b a -> [b] -> a
cfoldl ~(F op e) = foldl op e

-- Non-strict left-fold zipping
zipF :: FoldL b a -> FoldL b a' -> FoldL b (a,a')
~(F op e) `zipF` ~(F op' e') = F op'' (e,e')
 where
   ~(a,a') `op''` b = (a `op` b, a' `op'` b)

instance Zip (FoldL b) where zip = zipF

-- | Interpretation of a 'FoldL' as non-strict
cfoldl' :: FoldL b a -> [b] -> a
cfoldl' (F op e) = foldl' op e

-- Strict left-fold zipping
zipF' :: FoldL b a -> FoldL b a' -> FoldL b (P a a')
~(F op e) `zipF'` ~(F op' e') = F op'' (P e e')
 where
   P a a' `op''` b = P (a `op` b) (a' `op'` b)


instance Zip' (FoldL b) where zip' = zipF'


-- | Non-strict left fold with continuation.
type FoldLC b = WithCont (FoldL b)

-- | Interpretation of a 'FoldLC'
cfoldlc :: FoldLC b a -> [b] -> a
cfoldlc (WC f k) = fmap k (cfoldl f)



-- | Like 'WithCont' but with pair-strict '(<*>)'
data WithCont' z c = forall a. WC' (z a) (a -> c)

instance Functor (WithCont' z) where
  fmap g (WC' f k) = WC' f (fmap g k)


instance Zip' z => Applicative (WithCont' z) where
  pure a = WC' (error "unneeded pre-cont") (pure a)
  WC' hf hk <*> WC' xf xk =
    WC' (hf `zip'` xf) (\ (P a a') -> (hk a) (xk a'))

-- | Strict left fold with continuation.
type FoldLC' b = WithCont' (FoldL b)

-- | Interpretation of a 'FoldLC'
cfoldlc' :: FoldLC' b a -> [b] -> a
cfoldlc' (WC' f k) = fmap k (cfoldl' f)


----

-- | Strict pairs
data P c c' = P !c !c'

-- | Strict generalized zip
class Zip' f where
  zip' :: f a -> f b -> f (P a b)

instance             Zip' []       where zip' = liftA2 P
instance Monoid u => Zip' ((,)  u) where zip' = liftA2 P
instance             Zip' ((->) u) where zip' = liftA2 P
instance             Zip' IO       where zip' = liftA2 P