Signal

Signal.hs

import Control.Applicative
import Control.Monad
import Data.Monoid

data SignalT m a
    = Skip   (m (SignalT m a))
    | Emit a (m (SignalT m a))
    
instance Monad m => Functor (SignalT m) where
    fmap f = go
        where go (Skip   m) = Skip       (liftM go m)
              go (Emit a m) = Emit (f a) (liftM go m)
              
-- TODO
instance Monad m => Applicative (SignalT m) where
    pure a = Emit a (return (pure a))
    sf <*> sx = go sf
        where go (Skip   m) = Skip (liftM go m)
              go (Emit f m) = fmap f sx

-- TODO            
instance Monad m => Monad (SignalT m) where
    return = pure
    s0 >>= f = go s0
        where go (Skip   m) = Skip (liftM go m)
              go (Emit a m) = f a
              
instance (Monad m, Monoid a) => Monoid (SignalT m a) where
    mempty = never
    Skip   m `mappend` Skip   n = Skip   (liftM2 mappend m n)
    Skip   m `mappend` Emit a n = Emit a (liftM2 mappend m n)
    Emit a m `mappend` Skip   n = Emit a (liftM2 mappend m n)
    Emit a m `mappend` Emit b n = Emit (a `mappend` b) (liftM2 mappend m n)
    
never :: Monad m => SignalT m a
never = Skip (return never)

once :: Monad m => a -> SignalT m a
once a = Emit a (return never)

always :: Monad m => a -> SignalT m a
always a = Emit a (return (always a))

every :: Monad m => Int -> a -> SignalT m a
every n a = go n
    where go 1 = Emit a (return (go n))
          go x = Skip   (return (go (x - 1)))
          
delay :: Monad m => SignalT m a -> SignalT m a
delay = Skip . return

hold :: Monad m => SignalT m a -> SignalT m a
hold (Skip   m) = Skip (m >>= return . hold)
hold (Emit a m) = always a

switch :: Monad m => SignalT m a -> SignalT m a -> SignalT m a
switch l r = go l
    where go (Skip   _) = r
          go (Emit a m) = Emit a (m >>= return . go)

scan :: Monad m => (a -> b -> b) -> b -> SignalT m a -> SignalT m b
scan f = go
    where go z (Skip   m) = Skip (m >>= return . go z)
          go z (Emit a m) =
            let b = f a z in Emit b (m >>= return . go b)
          
toList :: Monad m => SignalT m a -> m [a]
toList (Skip   m) = m >>= toList
toList (Emit a m) = m >>= toList >>= \xs -> return (a : xs)

--main = toList (always 'a') >>= print . take 10
--main = toList ((+) <$> always 4 <*> always 5) >>= print . take 10