RecursiveObserver.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

{- |

The RecursiveObserver transformer (RecursiveObserverT) monad and the
Observable type class, can be used to connect a network of observable
objects and listeners (observers). The network may be recursive. When
desired events can be transmitted though the network.

By using an Event-ID it is ensured that objects call their listeners
at most once per invocation of the network. The functions
runRecursiveObserverT and runRecursiveObserverTWithNewEID are used to
execute a new invocation of the network.

Each listener should be using the RecursiveObserverT monad transformer.

Each observable object should be instance of the Observable type class.

It is the responsibility of the user of
Control.Monad.RecursiveObserver that runRecursiveObserverT and
runRecursiveObserverTWithNewEID is only called when approiate. If he
is not carefull with this, he can accidently create eternal recursion.

_Usage of RecursiveObserver_

To use this library you should create an EventID like:

> newtype EventID = EventID Int 
>     deriving (Random.Random, Show, Eq)

and Listener which contains RecursiveObserverT like:

> newtype Listener a = Listener { listener' :: RecursiveObserverT EventID IO a }
>     deriving (Monad, MonadIO, MonadEvent, Observable (ComIO b), Observable OnChangeVar)

Make sure you do not export the Listener constructor. By doing this
you control when new invocations of the network is started.

Next you should make the observable objects, in the network, instances
of Observable. Use the whenNotVisitedHelper, visitHelper, and
signalChangeHelper -functions to do this. You should also implement
some way of attaching listeners to the objects.

Finally, implement some way of doing controlled invocations of the
network.

_Alternative way to handling recursive observer/observable networks_

In some uses of observer/observable networks each observable object
contains some value. And we want to call all listeners when an
observable object changes its value. Also imagine that each observable
object has a setVal (:: a -> IO()) action, which when called changes
the value of the object.

Under these circumstances we could, each time setVal was called, check
if the new value differed from the last value and if it did signal all
its listeners. In this way we could avoid threading an EventID around.

However, we choose not to use this approch as:

* It requires that each observable object has some value.

* That the value implements Eq. This may work fine for most data
  types, but particularly data types containing functions cannot
  implement Eq.

* The comparison operation will scale linear with respect to the data
  types size, whereas the EventID approch has constant time
  complexity.

* The user could accidently make eternal recursion, if the network
  never diverges to some value.

* We may get into trouble with rounding errors. Imagine an exchange
  rate calculator from Dollars to Euros. Both values are represented
  as doubles. When we change the Dollar widget the Euros widget gets
  update, and vice versa. Let say the rate = 0.69056. And we type 127
  into the Euro-widget. Now the dollar widget is update to 127 *
  rate. The changing Dollar widget will update the Euro widget with
  127 * rate / rate = 126.99999999999! Why? because of an rounding
  error.

** The same problem can exist with RecursiveObserver. However, by
   using: whenNotVisited updateOtherWidget, we can avoid the problem.

-}

module Control.Monad.RecursiveObserver
    ( -- * Listener transformer
      ListenerT
    , MonadListener(..)
    -- ** Invocating the network
    , runListenerT, runListenerTWithNewEID
    -- * Observable class
    , Observable(..)
    -- ** Functions used to help construct Observable instances
    , whenNotVisitedHelper, visitHelper, signalChangeHelper
    )
where

import Random(randomIO, Random)

import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Unlift

-- We cannot newtype derive as the definition of ListenerT contains
-- other ListenerT-s.
newtype ListenerT eid m a =
    ListenerT { listenerT' :: ReaderT eid (WriterT [ListenerT eid m ()] m) a }

-- | Invokes the oberver/observable network, using a user supplied event-id.
runListenerT :: (Monad m) => eid -> ListenerT eid m a -> m a
runListenerT eid m =
    do (a, w) <- runWriterT $ runReaderT (listenerT' m) eid
       mapM_ (\eventT -> runListenerT eid eventT) w
       return a

-- | Invokes the oberver/observable network, using a random event-id.
-- This is a bit of a copout, as we can then get the same event-id
-- twice. On the other hand, chances are small if we choose an
-- event-id type with a large set of possible values.
--
-- If this behavior is unacceptable use `runListenerT` and together
-- with a counter (like counterFun :: IO Int).
runListenerTWithNewEID :: (Monad m, MonadIO m, Random eid) =>
                          ListenerT eid m a
                       -> m a
runListenerTWithNewEID oc =
    do eid <- liftIO randomIO
       runListenerT eid oc

getEID :: (Monad m) => ListenerT eid m eid
getEID = ListenerT ask

{- --------- MonadListener class --------- -}

class (Monad m) => MonadListener m where
    postponeEvent  :: m () -> m ()

instance Monad m => MonadListener (ListenerT eid m) where
    postponeEvent event = ListenerT $ tell [event]

instance MonadListener m => MonadListener (ReaderT r m) where
    postponeEvent e = unlift e >>= lift . postponeEvent
                         
instance (Monoid w, MonadListener m) => MonadListener (WriterT w m) where
    postponeEvent e = unlift e >>= lift . postponeEvent

{- --------- Observable class --------- -}

class (MonadListener m) => Observable o m where
    -- | Executes a monad if the observable object has not already been visited
    whenNotVisited :: o          -- ^Object to ask
                   -> m ()       -- ^Monad to execute if the object has not been visited
                   -> m ()
    -- | Mark an observable object as visited
    visit          :: o -> m ()
    -- | Tell an object to executes its listeners (observers)
    signalChange   :: o -> m ()

instance (Monad m, Observable o m) => Observable o (ReaderT r m) where
    whenNotVisited o action = unlift action >>= lift . whenNotVisited o
    visit o                 = lift $ visit o
    signalChange = lift . signalChange

instance (Monoid w, Monad m, Observable o m) => Observable o (WriterT w m) where
    whenNotVisited o action = unlift action >>= lift . whenNotVisited o
    visit o                 = lift $ visit o
    signalChange = lift . signalChange

whenNotVisitedHelper :: (Eq eid, Monad m) =>
			(o -> ListenerT eid m eid)
		     -> o
                     -> ListenerT eid m ()
		     -> ListenerT eid m ()
whenNotVisitedHelper getEventID o action =
    do currentEID  <- getEventID o
       calleeEID   <- getEID
       when (calleeEID /= currentEID) action

visitHelper :: (Monad m) =>
	       (t -> eid -> m a)
            -> t
            -> ListenerT eid m a
visitHelper setEventID o =
        do calleeEID <- getEID
           lift $ setEventID o calleeEID

signalChangeHelper :: (Observable o t) =>
		      (o -> t ())
                   -> o
                   -> t ()
signalChangeHelper signalAllListeners o = postponeEvent (whenNotVisited o signal)
    where signal = do visit o
                      signalAllListeners o

-- Common monad instances

instance (Monad m) => Monad (ListenerT eid m) where
    return x = ListenerT $ return x
    m >>= k  = ListenerT (listenerT' m >>= listenerT' . k)

instance MonadIO m => MonadIO (ListenerT eid m) where
    liftIO = ListenerT . liftIO

instance MonadTrans (ListenerT eid) where
    lift = ListenerT . lift . lift