Space-efficient, composable list transformers

gistfile1.hs

{-----------------------------------------------------------------------------
    Re: Space-efficient, composable list transformers
    
    A version of  ListTo
    that can handle lazy results and sequential compositon.
    See http://article.gmane.org/gmane.comp.lang.haskell.cafe/95027
    and follow-up discussion.
------------------------------------------------------------------------------}
{-# LANGUAGE GADTs #-}

import Control.Applicative
import Control.Arrow (first,second)

-- representation of functions  [a] -> b
data ListTo a b where
    CaseOf   :: b ->  (a -> ListTo a b)  -> ListTo a b
    Fmap     :: (b -> c) -> ListTo a b   -> ListTo a c
    FmapCons ::        b -> ListTo a [b] -> ListTo a [b]

caseOf = CaseOf

-- from Control.Monad.Instances
-- instance Functor ((->) a) where fmap = (.)

-- interpreter homomorphism
interpret :: ListTo a b -> ([a] -> b)
interpret (Fmap f g)        = fmap f (interpret g)
interpret (FmapCons x g)    = fmap (x:) (interpret g)
interpret (CaseOf nil cons) = \ys -> case ys of
    []     -> nil
    (x:xs) -> interpret (cons x) xs

-- functor instance
instance Functor (ListTo a) where
    fmap f = normalize . Fmap f

normalize :: ListTo a b -> ListTo a b
normalize (Fmap a (Fmap b c)) = normalize $ Fmap (a . b) c
normalize x = x

-- sequential composition
-- interpret (a <. b) = interpret $ interpret a <$> b
(<.) :: ListTo b c -> ListTo a [b] -> ListTo a c
(CaseOf _ cons) <. (FmapCons y b) = cons y <. b
(Fmap f a)      <. (FmapCons y b) = Fmap f      $ a <. (FmapCons y b)
(FmapCons x a)  <. (FmapCons y b) = FmapCons x  $ a <. (FmapCons y b)
a <. (CaseOf nil cons) = CaseOf (interpret a nil) ((a <.) . cons)
a <. (Fmap f b)        = fmap (interpret a . f) b

-- applicative instance, lock-step evaluation
instance Applicative (ListTo a) where
    pure b   = fmap (const b) $ caseOf b (const $ pure b)
    f <*> x  = fmap (uncurry ($)) $ pair f x

pair :: ListTo a b -> ListTo a c -> ListTo a (b,c)
pair (CaseOf a1 b1) (CaseOf a2 b2) = CaseOf (a1,a2) (\x -> pair (b1 x) (b2 x))
pair (Fmap f b)     c              = fmap (first  f) (pair b c)
pair b              (Fmap f c)     = fmap (second f) (pair b c)
pair (FmapCons x b) c              = pair (Fmap (x:) b) c
pair b              (FmapCons x c) = pair b (Fmap (x:) c)

-- examples
idL :: ListTo a [a]
idL = caseOf [] $ \x -> FmapCons x idL

takeL :: Int -> ListTo a [a]
takeL 0 = pure []
takeL n = caseOf [] $ \x -> FmapCons x $ takeL (n-1)

andL :: ListTo Bool Bool
andL = caseOf True $ \b -> (\c -> if b then c else False) <$> andL

testId    = interpret idL [1..]
testTake  = interpret (takeL 20) [1..]
testAnd   = interpret andL (True:False:undefined)
testTwoAnd = interpret $ liftA2 (,) (andL <. takeL 3) (andL <. idL)

-- > testTwoAnd [True,True,True,False]
-- (True,False)