\begin{code}
module ListenerOps (module ListenerOps,module ListenerPrim) where
-- The listener implementation
import ListenerPrim

import Maybe
import BaseTypes
import IOExts
import FranTime
import Monad (when)
import Array
\end{code}

Just making listeners with Occ a operations

\begin{code}
mkLOcc :: (Occ a -> IO ()) -> Listener a
mkLOcc f = mkL' $ \_ -> return f
\end{code}

Making a simple listener from an IO action

\begin{code}
mkL :: (a -> IO ()) -> Listener a
mkL f = mkLOcc $ \(_,a) -> f a

mkL_ :: IO () -> Listener a
mkL_ f = mkL (const f)
\end{code}



   Based on these we can have an algebra for listeners. 
   Note the apparently backwards nature of all the operators.
   For instance, comapL :: (a -> b) -> Listener b -> Listener a.
   This takes a listener and an inverse function. It makes a 
   new listener that applies the inverse function to any given
   value before passing them to the old listener

   listener b <--- <--- listener a
                  |
   f inverse -----| 
   (a -> b)


\begin{code}

-- merge two listeners so that they are both applied to given
-- values
mergeL :: Listener a -> Listener a -> Listener a 
mergeL l1 l2 | isNeverL l1 = l2
mergeL l1 l2 | isNeverL l2 = l1
mergeL l1 l2 = liftL2 (\act1 act2 val -> do act1 val;act2 val) 
                      l1 l2

-- merge a list of listeners
allL :: [Listener a] -> Listener a
allL = foldr mergeL neverL

-- given a listener and a value, make a listener that ignores its argument and 
-- applies the value 

tellL :: Listener a -> a -> Listener b
tellL l a = comapL (const a) l

-- map values to a listener with an inverse function as discussed above
comapL :: (a -> b) -> Listener b -> Listener a
comapL f = liftL1 (\op (t,a) -> op (t,f a))

-- as for mapL except performing an IO action to get the new value
comapIOL :: (a -> IO b) -> Listener b -> Listener a
comapIOL f = liftL1 (\op (t,a) -> do {b <- f a;op (t,b)})


-- make a listener do nothing until strictly after time t
afterTimeL :: Listener a -> Time -> Listener a
afterTimeL l t = liftL1 (\op occ@(t',_) -> when (t' > t) $ op occ) l

-- listener with current time
withTimeL :: Listener (a,Time) -> Listener a
withTimeL = liftL1 (\op (t,a) -> op (t,(a,t))) 

-- listener equivalent of mapMaybe
comapMaybeL :: (a -> Maybe b) -> Listener b -> Listener a
comapMaybeL f = liftL1 (\op (t,a) -> maybe (return ()) (op . pair t) (f a)) 


-- listener equivalent of mapMaybe for IO actions
comapMaybeIOL :: (a -> IO (Maybe b)) -> Listener b -> Listener a
comapMaybeIOL f = liftL1 (\op (t,a) -> f a >>= maybe (return ()) (op . pair t)) 

-- listener equivalent of filter
filterL :: (a -> Bool) -> Listener a -> Listener a
filterL f l = comapMaybeL (\a -> if f a then Just a else Nothing) l

-- make a listener that hears a value, applies f to get a
-- lists of values and applies the given listener to each value
comapLs :: (a -> [b]) -> Listener b -> Listener a 
comapLs f = liftL1 (\op (t,a) -> mapM_ (op . pair t) (f a))

-- make a listener the hears maybes but only consumes the Just a...
isJustL :: Listener a -> Listener (Maybe a)
isJustL = comapMaybeL id

-- turn a list of values into individual value consumptions
fromListL :: Listener a -> Listener [a]
fromListL = comapLs id

-- make a listener that consumes only 1 value ever
onceL :: Listener a -> Listener a
onceL = liftLIO $ \ rm op ->
 return $ \occ -> do rm;op occ

-- make a listener equivalent of scanl (Discussed in intro at top of module)
scanlL :: (a -> b -> a) -> a -> Listener a -> Listener b
scanlL f a = liftLIO $ \_ act -> do
  ref <- newIORef a
  let tell (t,b) = do
       a <- readIORef ref
       let a' = f a b
       writeIORef ref a'
       act (t,a')
  return tell

-- accumulate value based on initial and consumed update functions
accumL :: a -> Listener a -> Listener (a -> a)
accumL x0 = liftLIO $ \ _ op -> do
  xRef <- newIORef x0
  let f (t,g) = do
        x <- readIORef xRef
        let x' = g x
        -- Don't allow delayed accumulation.
        x' `seq` return ()
        writeIORef xRef x'
        op (t,x')
  return f  

-- only consume distinct values.
-- parameters f - The comparison function for two values
--            p - Do we ignore the initial value heard,(True - yes, False - no)
distinctLWith :: (a -> a -> Bool) -> (a -> Bool) -> Listener a -> Listener a
distinctLWith f p = liftLIO $ \ _ op -> do
 v <- newIORef p
 let act (t,x) = do
        p <- readIORef v
        if not $ p x then do
          writeIORef v (f x)
          op (t,x)
         else
          return ()
 return act

-- accumIOE is like accumE except that it uses an IO based action
accumIOL :: a -> Listener a -> Listener (a -> IO a)
accumIOL x0  = liftLIO $ \ _ op -> do
  xRef <- newIORef x0
  let f (t,g) = do
        x <- readIORef xRef
        x' <- g x
        -- Don't allow delayed accumulation.
        x' `seq` return ()
        writeIORef xRef x'
        op (t,x')
  return f

-- Pair up event occurrence values with successive list members
withElemL :: [b] -> Listener (a,b) -> Listener a
withElemL bs = liftLIO $ \rm op -> do
  valsRef <- newIORef bs
  let f (t,a) = do
        vals <- readIORef valsRef
        case vals of
          [] -> do rm ; return ()
          (v : vals') -> do
		writeIORef valsRef vals'
		op (t,(a,v))
  return f


withElemL_ :: [b] -> Listener b  -> Listener a
withElemL_ bs l = withElemL bs (comapL snd l) 



wrapIOL :: (IO () -> IO ()) -> Listener a -> Listener a
wrapIOL f l = liftL1 (\op occ -> f (op occ)) l

\end{code}

