\begin{code}
module EventPrim (module EventPrim,module WirePrim,
		  module ListenerOps,module TermE) where
import ListenerOps
import Remover
import IOExts
import MutSet
import TermE
import Monad
import Maybe
import Utils
import Compatibility
import Weak hiding (mkWeakPtr)
import FranTime
import Array
import BaseTypes
import WirePrim

infixr 1 `switcherE`,`switcherE'`,`manyE`,`manyE'`


infixl 3 `withElemE`
\end{code}

This implementation has a major advantage. We an use event listener duality 
to implement the event combinators. When  adding a listener to an event, 
we can either alter the event with an event combinator, or the listener 
using a listener combinator. We first define a  simple a primitive event 
combinator, which maps a listener combinator across an event. When we add a 
listener to the event, we first apply the listener combinator to the argument 
listener, before adding the resulting listener to the internal event. 
Clearly given a never event we need do nothing.

\begin{code}
mapLE :: (Listener b -> Listener a) -> Event a -> Event b
mapLE _ NeverE = NeverE
mapLE f (Event add term) = Event (\l -> add (f l)) term
\end{code}

The above event representation is very elegant. However, it suffers from a 
serious efficiency problem.  We are applying combinators to listeners
rather than to the event. This means that on every event occurrence, 
a combinator will be applied once per listener, rather than once only. 
This results in a potentially mild performance problem with mapE, but in a 
potentially very significant performance reduction for filterE. 
A filter will be redundantly applied to every listener of an event. 
If an event has a large number of listeners, this will result in a lot of 
unnecessary work. We need to introduce some mechanism to guarantee that 
filters are only applied once per event occurrence.

We can solve this problem by introducing caching. We can define a simple 
cache action that creates a new wire, and makes the old event talk to the 
new one. (Again we optimise when the event is a never event.)

\begin{code}

cacheIO :: Event a -> IO (Event a)
cacheIO NeverE = return NeverE
cacheIO e = do
 w <- primNewWire' (return ()) (return ()) (return ()) (termE e)
 addListener e (wireInput w)
 return (wireEvent w)

cache :: Event a -> Event a
cache e = unsafePerformIO (cacheIO e) 

-- caching without need to create whole new event

mapShareE :: (Listener b -> Listener a) -> Event a -> Event b
mapShareE f e = unsafePerformIO $ mapShareE' f e 

mapShareE' :: (Listener b -> Listener a) -> Event a -> IO (Event b)
mapShareE' _  NeverE = return NeverE
mapShareE' f e = do
 -- make the caching ref 
 ref <- newIORef (error "nothing cached")

 -- now add a single listener that updates this ref, when
 -- the event fires, applying f. 
 -- Note: that because listeners are handled in FIFO order
 -- this is safe. It's the first thing to get done with the
 -- cached event.
 e <- cacheIO e
 let setcache ref a = writeIORef ref a
 addWeakListener (mapLE f e) setcache ref

 -- finally return an event, based on the old one that reads
 -- the value of the cache
 return $ flip mapLE e $ comapIOL (const $ readIORef ref)
\end{code}


Using this approach we can define mapE, filterE etc

\begin{code}
-- map over events
mapE :: (a -> b) -> Event a -> Event b
mapE f = mapShareE (comapL f)

-- filter an event based on a boolean predicate
filterE :: (a -> Bool) -> Event a -> Event a
filterE f = cache . mapLE (filterL f)

-- an event version of mapMaybe, only pass on when f generates Just b
mapMaybeE :: (a -> Maybe b) -> Event a -> Event b
mapMaybeE f = cache . mapLE (comapMaybeL f)

-- like mapMaybeE but generating a list of values not just one
mapEs :: (a -> [b]) -> Event a -> Event b
mapEs f e = cache $ mapLE (comapLs f) e

-- Event filtering. Turn an occurrence with a list of values into a list of
-- occurrences, using fromListL.

fromListE :: Event [a] -> Event a
fromListE e = cache $ mapLE fromListL e

-- get the time of the event occurrence
withTimeE :: Event a -> Event (a, Time)
withTimeE = mapShareE withTimeL

-- only accept occurrences strictly after time t
afterTimeE :: Event a -> Time -> Event a
afterTimeE e t = cache $ mapLE (flip afterTimeL t) e

-- mapping an IO function over event occurrences, uses mapIOL
withIOE :: Event a -> (a -> IO b) -> Event b
withIOE e f = mapShareE (comapIOL f) e
\end{code}

Tracing
\begin{code}
traceE :: Show a => Event a -> String -> Event a
e `traceE` prefix = 
  let f a = do
       t <- getFranTime
       putStrLn (prefix ++ ": " ++ show (t,a))
       return a
  in
  withIOE e f
\end{code}


Efficiently reroute event through an array

\begin{code}
arrayE :: Ix a => (a,a) -> Event (a,b) -> Array a (Event b)
arrayE bounds e = unsafePerformIO $ do
 let pair (Wire l e) = (l,e)
 (ls,bEvs) <- fmap unzip $ mapM (fmap pair . id) $ replicate size newWire
 let evArr = array bounds (zip as bEvs)
     lArr = array bounds (zip as ls)
 addListener e (arrayL bounds lArr)
 return evArr
  where
   as = range bounds
   size = rangeSize bounds
\end{code}


This approach breaks down with mergeE, because though there is an equivalent 
listener operation (mergeL), there is no simple relationship between the two. 
We can, however, still provide a simple and elegant definition of merge on 
events. When adding a listener to two events, we add the listener to both 
and combine the remove actions. We can again optimise by using the knowledge 
that NeverE is a left and right identity.

\begin{code}
mergeE :: Event a -> Event a -> Event a
mergeE NeverE e = e
mergeE e NeverE = e
mergeE e1 e2 = Event (merge e1 e2) 
                     (mergeTerm (termE e1) (termE e2))
 where 
  merge e1 e2 = \l -> do 
   rm1 <- addListener e1 l;rm2 <- addListener e2 l;return (rm1 >> rm2)
\end{code}



We now come to the other problem with this representation.

Consider the following definition of scanlE. This creates an event that
accumulates a value, based on a function, an initial value and an event.

 scanlE :: (a -> b -> a) -> a -> Event b -> Event a
 scanlE f a e = mapLE (scanlL f a) e

Every time a listener is added to the event, it will begin to separately 
accumulate its own value. Two listeners added at different times would 
therefore consume different values. For instance, consider the following 
example.

testscan1 = do
 w <- newWire
 op <- getListener (input w)
 let l1 = (mkL (\x -> print ("one",x)))
     l2 = (mkL (\x -> print ("two",x)))
 let e :: Event String
     e = scanlE (++) "" (event w)
 addListener e l1
 op (0,"a")
 addListener e l2
 op (1,"b")

This will produce the output shown below (left). The expected output, based 
on the FRP semantics is shown on the right.
("one","a") 	("one","a")
("one","ab")	("one","ab")
("two","b")	("two","ab")

Why? We add the first listener. It will create its own internal state, 
to hold the current accumulated value. We then fire op, causing the first 
listener to print "a". Now we add the second listener. This now
creates its own internal state, to hold its accumulated value. When we fire 
op a second time, listener one will have accumulated a second value, 
producing "ba". However, listener two will only have heard the 
"b" value, as it will not know about the event history. That is, 
it will not know about the occurrences that have been produced before 
it was added. This combinator again does not satisfy the FRP semantics.

When we add the caching mechanism, we get an alternative problem. 
Consider a cached implementation of scanlE.

scanlE f a e = cache (mapLE (scanlL f a) e)

When evaluated this will create a cached event, adding a listener to e 
that accumulates a value. 

Listeners added to the scan event will now listen to the cached event. Each listener will therefore hear the same value. This appears to be an improvement. 
The testscan1 example will now produce the correct FRP output.
However, this implementation is in fact unsafe, as it is not referentially 
transparent. If we were to rewrite testscan, so that the first listener was 
added after op was first fired, this would again produce the alternative, 
incorrect output. Here the order of evaluation has changed the result of our
program. In contrast, if we were using a strict language then at least in 
this instance if e were to be evaluated strictly we would get the correct 
result.

testscan2 = do 
 let e = scanlE ...
 op (0,"a")
 addListener e l1
 addListener e l2
 op (1,"b")


However, we could easily imagine rewriting the testscan function as shown
below. Here we have replaced each use of e with the full scanlE based 
definition. Now this would again produce the incorrect output described above.
These two definitions again produce different results. Unfortunately,
in a referentially transparent language, these two definitions should be
equivalent. In fact an optimising compiler might replace either definition 
with the other, during either an inlining process, or if it were to
perform some form of common sub-expression elimination.

testscan3 = do
 w <- newWire
 op <- getListener (input w)
 addListener (scanlE (++) "" (event w))
             (mkL (\x -> print ("one",x)))
 op (0,"a")
 addListener (scanlE (++) "" (event w))
             (mkL (\x -> print ("two",x)))
 op (1,"b")
We therefore have a fundamental caching problem. 
The use of caching is only safe when used with combinators that do not 
rely on an event's history.

To fix this we must move all history based combinators into the IO monad.

\begin{code}
-- Make an event only occur once
onceE' :: Event a -> Event a
onceE' = mapLE onceL  

onceE :: Event a -> IO (Event a)
onceE = cacheIO . onceE'

-- An event version of scanl
scanlE' :: (a -> b -> a) -> a -> Event b -> Event a
scanlE' f a e = mapLE (scanlL f a) e

scanlE :: (a -> b -> a) -> a -> Event b -> IO (Event a)
scanlE f a e = mapShareE' (scanlL f a) (cache e)

-- filter out duplicated values
distinctEWith' :: (a -> a -> Bool) -> (a -> Bool) -> Event a -> Event a
distinctEWith' f p = mapLE (distinctLWith f p)

distinctEWith :: (a -> a -> Bool) -> (a -> Bool) -> Event a -> IO (Event a)
distinctEWith f p = mapShareE' (distinctLWith f p)

-- accumulate a value on an event
accumE' :: a -> Event (a -> a) -> Event a
accumE' a e = mapLE (accumL a) e

accumE :: a -> Event (a -> a) -> IO (Event a)
accumE a e = mapShareE' (accumL a) (cache e)

-- accumIOE is like accumE except that it uses an IO based action
-- be careful with this
accumIOE' :: a -> Event (a -> IO a) -> Event a
accumIOE' x0 = mapLE (accumIOL x0)

accumIOE :: a -> Event (a -> IO a) -> IO (Event a)
accumIOE x0 = mapShareE' (accumIOL x0)

-- associate list of values with occurrences of an event
withElemE' :: Event a -> [b] -> Event (a,b)
withElemE' e bs = mapLE (withElemL bs) e

withElemE :: Event a -> [b] -> IO (Event (a,b))
withElemE e bs = mapShareE' (withElemL bs) e

\end{code}

One other combinator that cannot simply be defined in terms of its listener 
equivalent is switcherE, the event level switcher.

We must instead define a new listener combinator, switchL. This takes an 
event and a listener. It produces a listener that consumes events. It starts 
by adding l to e. Every time the composite listener is told of a new event, 
it switches l's interest to the new event, and drops its interest in the old 
one.

Note that this passes its argument listener a remover that will delete it 
from the current event, rather than the remove action which will delete it 
from the switching event

\begin{code}
switchL :: Event a -> Listener a -> Listener (Event a)
switchL e l' = mkPrimL $ \rm -> do
 removerRef <- newIORef (return ())
 (rmn,op) <- getPrimListener l' (callRemover removerRef (return ()))
 let l = mkL' $ \_ -> return op
 rm <- addListener e l
 writeIORef removerRef rm
 let f (_,newEv) = do
       rmnew <- addListener newEv l
       callRemover removerRef rmnew
 return (rmn >> callRemover removerRef (return ()),f )
\end{code}

This creates a new event, which whenever a listener is added begins initially
listening to e. It also adds a separate listener to ee. Whenever this 
event-valued event occurs, it drops l's interest in the old event
and adds l as a listener to the new one.

\begin{code}
switcherE' :: Event a -> Event (Event a) -> Event a
switcherE' e ee = Event ( \l -> do
 removerRef <- addListener e l >>= newIORef
 let f newEv = do
       rms <- readIORef removerRef
       rm <- addListener newEv l
       rms
       writeIORef removerRef rm
       return ()
 rm <- addListener ee $ mkL f
 return (do rm 
            readIORef removerRef >>= id 
            writeIORef removerRef (return ()))) neverTermE  

--switcherE' e = mapLE (switchL e) 

switcherE :: Event a -> Event (Event a) -> IO (Event a)
switcherE e ee = cacheIO (switcherE' e ee)
\end{code}
Like switcherE but doesn't lose interest

\begin{code}
manyE' :: Event a -> Event (Event a) -> Event a
manyE' e ee = Event ( \l -> do
 removerRef <- addListener e l >>= newIORef
 let f newEv = do
       rms <- readIORef removerRef
       rm <- addListener newEv l
       writeIORef removerRef (rm >> rms)
       return ()
 rm <- addListener ee $ mkL f
 return (do rm 
            readIORef removerRef >>= id 
            writeIORef removerRef (return ()))) neverTermE  
--manyE' e = mapLE (manyL e) 

manyE ::  Event a -> Event (Event a) -> IO (Event a)
manyE e ee = cacheIO $ manyE' e ee

manyL :: Event a -> Listener a -> Listener (Event a)
manyL e l' = mkPrimL $ \rm -> do
 removerRef <- newIORef (return ())
 (rmn,op) <- getPrimListener l' (callRemover removerRef (return ()))
 let l = mkL' $ \_ -> return op
 rm <- addListener e l
 writeIORef removerRef rm
 let f (_,newEv) = do
       rms <- readIORef removerRef
       rmnew <- addListener newEv l
       writeIORef removerRef (rms >> rmnew)
 return (rmn >> callRemover removerRef (return ()),f )
\end{code}


A listener level switcher. 
We can implement this correctly using event termination. We use a variable to 
store the current listener's information. This contains either (Just (rm,op))
if there is a current listener, where the pair represents the listeners own 
remove action, and consumer action. The current listener is passed a remove 
action that checks whether the switching event has terminated. If so it
removes itself; if not it sets the current listener variable to Nothing. 
When the switching event terminates, if the listener variable contains 
Nothing we perform the remove action. On every event occurrence, we change the
current listener information. We store the new listener remove and consume 
action, and then perform the remove action for the old listener, to stop 
it doing any extra work. The consume action for this composite listener, 
consists of reading the current opvar, and applying the current operation 
to its argument, when there is a valid listener contained inside. Finally, 
we return remove actions to delete the terminate and event listener, 
along with the actual operation.

\begin{code}

switcherL :: Listener a -> Event (Listener a) -> Listener a
switcherL l NeverE = l
switcherL l ee = mkPrimL $ \rmReal -> do
 opvar <- newIORef Nothing

 let dieL = do {b <- isTerminatedE ee;
               if b then rmReal else writeIORef opvar Nothing}
 
     dieEE = do {mb <- readIORef opvar;
                 when (not (isJust mb)) rmReal}   

 val <- getPrimListener l dieL
 writeIORef opvar (Just val)

 let f l = do
      val' <- getPrimListener l dieL
      mb <- readIORef opvar
      maybe (return ()) fst mb
      writeIORef opvar (Just val')

 rmEE <- addListener ee (mkL f)
 rmT <- onTerminateE ee (mkL_ dieEE) 
 let tell occ = do {mb <- readIORef opvar;
                    maybe (return ()) (($ occ) . snd) mb} 
 return (rmEE >> rmT,tell)

\end{code}


We need to be able to add a listener and prevent it from doing unneccessary 
work. We can do this by introducing an addWeakListener function. This adds a
listener that remains only as long as its client (IORef) is alive. Note that 
the listener does not keep the client alive. When the client dies we delete 
the listener from the event. As we now have a general class of functions 
with listeners, the addWeakListener function simply works with members of 
this class.

\begin{code}
addWeakListener = addWeakListener' addListener

addWeakListener' :: (c a -> Listener a -> IO Remover)
	         -> c a -> (IORef b -> a -> IO ()) -> IORef b
                 -> IO Remover
addWeakListener' addListener e lisf client = fixIO $ \ remLis -> do
 wp <- mkWeakPtr client remLis
 remLis <- addListener e $ mkL $ \x -> do
 		mbClient <- deRefWeak wp
 		case mbClient of
  		 Nothing -> remLis
  		 Just client -> (lisf client) x
 return remLis
\end{code}

\begin{code}

franTick :: Event ()
tickListen :: Listener ()
(Wire tickListen franTick) = unsafePerformIO newWire

tellTick :: Time -> IO ()
tellTick = unsafePerformIO $ do
 op <- getListener' tickListen (return ())
 return $ \t -> op (t,())

-- Simple implementation of alarmE 

alarmE :: Time -> DTime -> Event ()
alarmE t0 dt = flip mapLE franTick $ \l -> mkL' $ \rm -> do
  op <- getListener' l rm
  v <- newIORef t0
  let f (te,_) = do
        tl <- readIORef v
        if te - tl > dt then do
            writeIORef v te
            op (te,())
         else
            return ()
  return f


\end{code}
