Lazy functions on lists with parallel and sequential composition using standard type classes.

ListTransformer.hs

module ListTransformer where

import Control.Applicative

import Control.Arrow
import Control.Category
import Prelude hiding ( id, (.) )

data ListConsumer a b
  = Done b
  | Continue b (a -> ListConsumer a b)

consumeList :: ListConsumer a b -> [a] -> b
consumeList (Done b)       _      = b
consumeList (Continue b _) []     = b
consumeList (Continue _ f) (x:xs) = consumeList (f x) xs

instance Functor (ListConsumer a) where
  fmap f g = pure f <*> g

instance Applicative (ListConsumer a) where
  pure x = Done x

  Done f        <*> Done x        = Done $ f x
  Done f        <*> Continue x xs = Continue (f x) (\a -> Done f <*> xs a)
  Continue f fs <*> Done x        = Continue (f x) (\a -> fs a <*> Done x)
  Continue f fs <*> Continue x xs = Continue (f x) (\a -> fs a <*> xs a)

headC :: ListConsumer a a
headC = Continue (error "head of empty list") Done

takeC :: Int -> ListConsumer a [a]
takeC n | n <= 0    = Done []
        | otherwise = Continue [] (\x -> (x:) <$> takeC (n-1))

foldl'C :: (b -> a -> b) -> b -> ListConsumer a b
foldl'C f e = Continue e (\x -> foldl'C f $! f e x)

sumC :: Num n => ListConsumer n n
sumC = foldl'C (+) 0

lengthC :: Num n => ListConsumer a n
lengthC = foldl'C (const . (+1)) 0

averageC :: Fractional n => ListConsumer n n
averageC = (/) <$> sumC <*> lengthC

idC :: ListConsumer a [a]
idC = Continue [] (\x -> (x:) <$> idC)


data ListTransformer a b
  = Cut
  | Put b (ListTransformer a b)
  | Get (a -> ListTransformer a b)

transformList :: ListTransformer a b -> [a] -> [b]
transformList Cut       _      = []
transformList (Put b t) xs     = b : transformList t xs
transformList (Get _)   []     = []
transformList (Get f)   (x:xs) = transformList (f x) xs

instance Category ListTransformer where
  id = Get (\x -> Put x id)

  Cut       . _       = Cut
  Put x t   . u       = Put x (t . u)
  Get _     . Cut     = Cut
  Get f     . Put x t = f x . t
  t@(Get _) . Get f   = Get (\x -> t . f x)

instance Functor (ListTransformer a) where
  fmap _ Cut       = Cut
  fmap f (Put x t) = Put (f x) (fmap f t)
  fmap f (Get g)   = Get (fmap f . g)

instance Applicative (ListTransformer a) where
  pure x = Put x $ pure x

  Cut         <*> _           = Cut
  _           <*> Cut         = Cut
  Put f t     <*> Put x u     = Put (f x) (t <*> u)
  Get f       <*> Get g       = Get (\x -> f x <*> g x)
  t@(Put _ _) <*> Get g       = Get (\x -> t . Put x id <*> g x)
  Get f       <*> t@(Put _ _) = Get (\x -> f x <*> t . Put x id)

instance Arrow ListTransformer where
  arr f   = f <$> id
  first t = (,) <$> t . arr fst <*> arr snd

pairsT :: ListTransformer a (a,a)
pairsT = Get (\x -> Get (\y -> Put (x,y) pairsT))

chunksT :: Int -> ListTransformer a [a]
chunksT n = grab n
 where
  grab 0 = Put [] (chunksT n)
  grab m = Get (\x -> grab (m-1) >>> Get (\xs -> Put (x:xs) id))

tailT :: ListTransformer a a
tailT = Get $ const id

takeT :: Int -> ListTransformer a a
takeT n | n <= 0    = Cut
        | otherwise = Get (\x -> Put x (takeT (n-1)))

dropT :: Int -> ListTransformer a a
dropT n | n <= 0    = id
        | otherwise = Get $ const (dropT (n-1))

takeWhileT :: (a -> Bool) -> ListTransformer a a
takeWhileT p = Get (\x -> if p x then Put x (takeWhileT p) else Cut)

dropWhileT :: (a -> Bool) -> ListTransformer a a
dropWhileT p = Get (\x -> if p x then dropWhileT p else Put x id)

filterT :: (a -> Bool) -> ListTransformer a a
filterT p = Get (\x -> if p x then Put x (filterT p) else filterT p)


infixr 4 <.
(<.) :: ListConsumer b c -> ListTransformer a b -> ListConsumer a c
Done c       <. _       = Done c
Continue c _ <. Cut     = Done c
Continue _ f <. Put x t = f x <. t
Continue c f <. Get g   = Continue c (\a -> Continue c f <. g a)

ListTransformerTests.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

import ListTransformer

import Control.Applicative

import Control.Arrow
import Control.Category
import Prelude hiding ( id, (.) )

import Test.QuickCheck
import Test.QuickCheck.Function

import Data.List ( isPrefixOf )


-- Functor laws for ListConsumer

propCFunctorId :: ListConsumer Int Int -> [Int] -> Bool
propCFunctorId c l =
  consumeList (fmap id c) l ==
  consumeList c l

propCFunctorComp :: Fun Int Int -> Fun Int Int
                 -> ListConsumer Int Int -> [Int] -> Bool
propCFunctorComp (Fun _ f) (Fun _ g) c l =
  consumeList (fmap (f . g) c) l ==
  consumeList ((fmap f . fmap g) c) l

propCFunctorMorph :: Fun Int Int -> ListConsumer Int Int -> [Int] -> Bool
propCFunctorMorph (Fun _ f) c l =
  consumeList (fmap f c) l ==
  fmap f (consumeList c) l


-- Applicative Laws for ListConsumer

propCAppId :: ListConsumer Int Int -> [Int] -> Bool
propCAppId c l =
  consumeList (pure id <*> c) l ==
  consumeList c l

propCAppPure :: Fun Int Int -> Int -> [Int] -> Bool
propCAppPure (Fun _ f) x l =
  consumeList (pure f <*> pure x) l ==
  consumeList (pure (f x)) l

propCAppFMap :: Fun Int Int -> ListConsumer Int Int -> [Int] -> Bool
propCAppFMap (Fun _ f) c l =
  consumeList (pure f <*> c) l ==
  consumeList (fmap f c) l

propCAppAssoc :: ListConsumer Int (Int -> Int)
              -> ListConsumer Int (Int -> Int)
              -> ListConsumer Int Int
              -> [Int] -> Bool
propCAppAssoc x y z l =
  consumeList (x <*> (y <*> z)) l ==
  consumeList (pure (.) <*> x <*> y <*> z) l

propCAppSwap :: ListConsumer Int (Int -> Int) -> Int -> [Int] -> Bool
propCAppSwap c x l =
  consumeList (c <*> pure x) l ==
  consumeList (pure ($x) <*> c) l

propCAppMorphPure :: Int -> [Int] -> Bool
propCAppMorphPure x l =
  consumeList (pure x) l ==
  pure x l

propCAppMorphApply :: ListConsumer Int (Int -> Int)
                   -> ListConsumer Int Int -> [Int] -> Bool
propCAppMorphApply x y l =
  consumeList (x <*> y) l ==
  (consumeList x <*> consumeList y) l


-- Examples for ListConsumer

propHeadC :: [Int] -> Property
propHeadC l =
  not (null l) ==>
    consumeList headC l ==
    head l

propTakeC :: Int -> [Int] -> Bool
propTakeC n l =
  consumeList (takeC n) l ==
  take n l

propSumC :: [Int] -> Bool
propSumC l =
  consumeList sumC l ==
  sum l

propLengthC :: [Int] -> Bool
propLengthC l =
  consumeList lengthC l ==
  length l

propAverageC :: [Double] -> Property
propAverageC l =
  not (null l) ==>
    consumeList averageC l ==
    sum l / fromIntegral (length l)

propIdC :: [Int] -> Bool
propIdC l =
  consumeList idC l ==
  l


-- Category laws for ListTransformer

propTCatIdL :: ListTransformer Int Int -> [Int] -> Bool
propTCatIdL c l =
  transformList (id . c) l ==
  transformList c l

propTCatIdR :: ListTransformer Int Int -> [Int] -> Bool
propTCatIdR c l =
  transformList (c . id) l ==
  transformList c l

propTCatAssoc :: ListTransformer Int Int
              -> ListTransformer Int Int
              -> ListTransformer Int Int
              -> [Int] -> Bool
propTCatAssoc x y z l =
  transformList ((x . y) . z) l ==
  transformList (x . (y . z)) l

propTCatMorphId :: [Int] -> Bool
propTCatMorphId l =
  transformList id l ==
  id l

propTCatMorphComp :: ListTransformer Int Int
                  -> ListTransformer Int Int
                  -> [Int] -> Bool
propTCatMorphComp x y l =
  transformList (x . y) l ==
  (transformList x . transformList y) l


-- Functor laws for ListTransformer

propTFunctorId :: ListTransformer Int Int -> [Int] -> Bool
propTFunctorId t l =
  transformList (fmap id t) l ==
  transformList t l

propTFunctorComp :: Fun Int Int -> Fun Int Int
                 -> ListTransformer Int Int
                 -> [Int] -> Bool
propTFunctorComp (Fun _ f) (Fun _ g) t l =
  transformList (fmap (f . g) t) l ==
  transformList ((fmap f . fmap g) t) l

propTFunctorMorph :: Fun Int Int -> ListTransformer Int Int -> [Int] -> Bool
propTFunctorMorph (Fun _ f) t l =
  transformList (fmap f t) l ==
  fmap (map f) (transformList t) l


-- Applicative laws for ListTransformer

propTAppId :: ListTransformer Int Int -> [Int] -> Bool
propTAppId t l =
  transformList (pure id <*> t) l ==
  transformList t l

propTAppPure :: Fun Int Int -> Int -> [Int] -> Bool
propTAppPure (Fun _ f) x l =
  take 100 (transformList (pure f <*> pure x) l) ==
  take 100 (transformList (pure (f x)) l)

propTAppFMap :: Fun Int Int -> ListTransformer Int Int -> [Int] -> Bool
propTAppFMap (Fun _ f) t l =
  transformList (pure f <*> t) l ==
  transformList (fmap f t) l

propTAppAssoc :: ListTransformer Int (Int -> Int)
              -> ListTransformer Int (Int -> Int)
              -> ListTransformer Int Int
              -> [Int] -> Bool
propTAppAssoc x y z l =
  transformList (x <*> (y <*> z)) l ==
  transformList (pure (.) <*> x <*> y <*> z) l

propTAppSwap :: ListTransformer Int (Int -> Int) -> Int -> [Int] -> Bool
propTAppSwap t x l =
  transformList (t <*> pure x) l ==
  transformList (pure ($x) <*> t) l

propTAppMorphPure :: Int -> [Int] -> Bool
propTAppMorphPure x l =
  take 100 (transformList (pure x) l) ==
  take 100 (pure (repeat x) l)

propTAppMorphApply :: ListTransformer Int (Int -> Int)
                   -> ListTransformer Int Int -> [Int] -> Bool
propTAppMorphApply x y l =
  transformList (x <*> y) l ==
  (zipWith ($) . transformList x <*> transformList y) l


-- Applicative/Category laws for ListTransformer

propTAppCatConst :: ListTransformer Int Int -> [Int] -> Property
propTAppCatConst t l =
  expectFailure $ -- Put (const 1) Cut <*> id /= Put 1 Cut
    transformList (pure const <*> t <*> id) l ==
    transformList t l

propTAppCatDup :: ListTransformer Int (Int -> Int -> Int) -> [Int] -> Bool
propTAppCatDup t l =
  transformList (t <*> id <*> id) l ==
  transformList (pure dup <*> t <*> id) l

dup :: (a -> a -> b) -> a -> b
dup f x = f x x

propTAppCatArrPure :: Fun Int Int -> ListTransformer Int Int -> [Int] -> Bool
propTAppCatArrPure (Fun _ f) t l =
  transformList (arr f . t) l ==
  transformList (pure f <*> t) l

propTAppCatArrDistr :: ListTransformer Int (Int -> Int)
                    -> ListTransformer Int Int
                    -> Fun Int Int -> [Int] -> Bool
propTAppCatArrDistr u v (Fun _ f) l =
  transformList ((u <*> v) . arr f) l ==
  transformList (u . arr f <*> v . arr f) l


-- Arrow laws for ListTransformer

propTArrId :: [Int] -> Bool
propTArrId l =
  transformList (arr id) l ==
  transformList id l

propTArrComp :: Fun Int Int -> Fun Int Int -> [Int] -> Bool
propTArrComp (Fun _ f) (Fun _ g) l =
  transformList (arr (f . g)) l ==
  transformList (arr f . arr g) l

propTArrFirstComp :: ListTransformer Int Int -> ListTransformer Int Int
                 -> [(Int,Int)] -> Property
propTArrFirstComp f g l =
  expectFailure $ -- first (Put 1 id) . first Cut /= first (Put 1 id . Cut)
    transformList (first (f . g)) l ==
    transformList (first f . first g) l

propTArrFirstArr :: Fun Int Int -> [(Int,Int)] -> Bool
propTArrFirstArr (Fun _ f) l =
  transformList (first (arr f)) l ==
  transformList (arr (f `cross` id)) l

cross :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)
(f `cross` g) (x,y) = (f x, g y)

propTArrFirstArrSwap :: ListTransformer Int Int
                     -> Fun Int Int -> [(Int,Int)] -> Bool
propTArrFirstArrSwap f (Fun _ g) l =
  transformList (first f . arr (id `cross` g)) l ==
  transformList (arr (id `cross` g) . first f) l

propTArrDropFirst :: ListTransformer Int Int -> [(Int,Int)] -> Property
propTArrDropFirst f l =
  expectFailure $ -- arr fst . first (Put 0 Cut) /= Put 0 Cut . arr fst
    transformList (arr fst . first f) l ==
    transformList (f . arr fst) l

propTArrFirstAssoc :: ListTransformer Int Int -> [((Int,Int),Int)] -> Bool
propTArrFirstAssoc f l =
  transformList (first f . arr assoc) l ==
  transformList (arr assoc . first (first f)) l

assoc :: ((a,b),c) -> (a,(b,c))
assoc ((x,y),z) = (x,(y,z))


-- Examples for ListTransformer

propTailT :: [Int] -> Property
propTailT l =
  not (null l) ==>
    transformList tailT l ==
    tail l

propTakeT :: Int -> [Int] -> Bool
propTakeT n l =
  transformList (takeT n) l ==
  take n l

propDropT :: Int -> [Int] -> Bool
propDropT n l =
  transformList (dropT n) l ==
  drop n l

propTakeWhileT :: Fun Int Bool -> [Int] -> Bool
propTakeWhileT (Fun _ p) l =
  transformList (takeWhileT p) l ==
  takeWhile p l

propDropWhileT :: Fun Int Bool -> [Int] -> Bool
propDropWhileT (Fun _ p) l =
  transformList (dropWhileT p) l ==
  dropWhile p l

propFilterT :: Fun Int Bool -> [Int] -> Bool
propFilterT (Fun _ p) l =
  transformList (filterT p) l ==
  filter p l


-- Composition of Consumer and Transformer

propConsTrans :: ListConsumer Int Int
              -> ListTransformer Int Int
              -> [Int] -> Bool
propConsTrans c t l =
  consumeList (c <. t) l ==
  (consumeList c . transformList t) l


-- Incrementality of transformers

propTransIncr :: ListTransformer Int Int -> [Int] -> [Int] -> Bool
propTransIncr t xs ys =
  transformList t xs `isPrefixOf` transformList t (xs++ys)


-- all tests

main :: IO ()
main = do
  putStrLn "checking Functor laws for ListConsumer.."
  quickCheck propCFunctorId
  quickCheck propCFunctorComp
  quickCheck propCFunctorMorph

  putStrLn "\nchecking Applicative laws for ListConsumer.."
  quickCheck propCAppId
  quickCheck propCAppPure
  quickCheck propCAppFMap
  quickCheck propCAppAssoc
  quickCheck propCAppSwap
  quickCheck propCAppMorphPure
  quickCheck propCAppMorphApply

  putStrLn "\nchecking Examples for ListConsumer.."
  quickCheck propHeadC
  quickCheck propTakeC
  quickCheck propSumC
  quickCheck propLengthC
  quickCheck propAverageC
  quickCheck propIdC

  putStrLn "\nchecking Category laws for ListTransformer.."
  quickCheck propTCatIdL
  quickCheck propTCatIdR
  quickCheck propTCatAssoc
  quickCheck propTCatMorphId
  quickCheck propTCatMorphComp

  putStrLn "\nchecking Functor laws for ListTransformer.."
  quickCheck propTFunctorId
  quickCheck propTFunctorComp
  quickCheck propTFunctorMorph

  putStrLn "\nchecking Applicative laws for ListTransformer.."
  quickCheck propTAppId
  quickCheck propTAppPure
  quickCheck propTAppFMap
  quickCheck propTAppAssoc
  quickCheck propTAppSwap
  quickCheck propTAppMorphPure
  quickCheck propTAppMorphApply

  putStrLn "\nchecking Applicative/Category laws for ListTransformer.."
  -- http://cdsmith.wordpress.com/2011/08/13/arrow-category-applicative-part-iia/
  quickCheck propTAppCatConst
  quickCheck propTAppCatDup
  quickCheck propTAppCatArrPure
  quickCheck propTAppCatArrDistr

  putStrLn "\nchecking Arrow laws for ListTransformer.."
  quickCheck propTArrId
  quickCheck propTArrComp
  quickCheck propTArrFirstComp
  quickCheck propTArrFirstArr
  quickCheck propTArrFirstArrSwap
  quickCheck propTArrDropFirst
  quickCheck propTArrFirstAssoc

  putStrLn "\nchecking Examples for ListTransformer.."
  quickCheck propTailT
  quickCheck propTakeT
  quickCheck propDropT
  quickCheck propTakeWhileT
  quickCheck propDropWhileT
  quickCheck propFilterT

  putStrLn "\nchecking composition of consumer and transformer.."
  quickCheck propConsTrans

  putStrLn "\nchecking incrementality of transformers.."
  quickCheck propTransIncr


-- boilerplate

instance Show (ListConsumer Int Int) where
  show (Done b)       = "(Done " ++ show b ++ ")"
  show (Continue b _) =
    "(Continue " ++ show b ++ " " ++ "..." ++ ")"

instance Show (ListConsumer Int (Int -> Int)) where
  show (Done _)       = "(Done " ++ "..." ++ ")"
  show (Continue _ _) =
    "(Continue " ++ "..." ++ " " ++ "..." ++ ")"

instance Show (ListTransformer Int Int) where
  show Cut       = "Cut"
  show (Put b t) = "(Put " ++ show b ++ " " ++ show t ++ ")"
  show (Get _)   = "(Get " ++ "..." ++ ")"

instance Show (ListTransformer Int (Int -> Int)) where
  show Cut       = "Cut"
  show (Put _ t) = "(Put " ++ "..." ++ " " ++ show t ++ ")"
  show (Get _)   = "(Get " ++ "..." ++ ")"

instance Show (ListTransformer Int (Int -> Int -> Int)) where
  show Cut       = "Cut"
  show (Put _ t) = "(Put " ++ "..." ++ " " ++ show t ++ ")"
  show (Get _)   = "(Get " ++ "..." ++ ")"

instance (CoArbitrary a, Arbitrary b) => Arbitrary (ListConsumer a b) where
  arbitrary =
    frequency [(1,Done <$> arbitrary),
               (1,Continue <$> arbitrary <*> arbitrary)]

  shrink (Done x)       = [Done y | y <- shrink x]
  shrink (Continue x f) = Done x : shrink (Done x) ++
                          [Continue y g | y <- shrink x, g <- shrink f]

instance (CoArbitrary a, Arbitrary b) => Arbitrary (ListTransformer a b) where
  arbitrary =
    frequency [(1,pure Cut),
               (1,Put <$> arbitrary <*> arbitrary),
               (1,Get <$> arbitrary)]

  shrink Cut       = []
  shrink (Put x t) = t : shrink t ++ [Put y u | y <- shrink x, u <- shrink t]
  shrink (Get f)   = [Get g | g <- shrink f]