Reifying case expressions on lists

gistfile1.hs

{-----------------------------------------------------------------------------
    Re: Reifying case expressions [on lists]
    
    A version of  ListTo  that can handle lazy results.
    See http://article.gmane.org/gmane.comp.lang.haskell.cafe/94953
    and follow-up discussion.
------------------------------------------------------------------------------}
{-# LANGUAGE GADTs #-}
module ListTo (ListTo, caseOf, interpret, idL, takeL, andL, testId, testTake, testAnd) where

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

-- representation of functions  [a] -> b
data ListTo a b where
    Fmap   :: (b -> c) -> ListTo a b -> ListTo a c
    CaseOf :: b -> (a -> 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 (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

-- 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)

-- examples
idL :: ListTo a [a]
idL = caseOf [] $ \x -> (x:) <$> idL

takeL :: Int -> ListTo a [a]
takeL 0 = pure []
takeL n = caseOf [] $ \x -> (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)