{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}

{-----------------------------------------------------------------------------

    TODO:
    What should we do with the variants involving time-varying functions?
    Should they get the same, or a different name?
    
    For example:
    
    map   ::          (a -> b) -> Event a -> Event b
    apply :: Behavior (a -> b) -> Event a -> Event b 
    
    filter  ::          (a -> Bool) -> Event a -> Event a
    filterB :: Behavior (a -> Bool) -> Event a -> Event a 


    accumulate  doesn't need a  Behavior  variant!
    ->  accumulate ($) b $ apply behavior event

    TODO:
    At some point, we probably need a function to dynamically switch
    between events, something like this
    
        join :: Event (Event a) -> Event a

    Not sure about this particular functions,
    but the point is that event handlers are being registered,
    and also *unregisterered* while the program is running.
    At the moment, everything is set up statically.

------------------------------------------------------------------------------}

module Reactive.Core (
    -- * Events
    -- $Event
    Event, never, fromEventSource, reactimate,
    mapIO, filter, filterChanges,
    union, merge, orderedDuplicate,
    traceEvent,
    
    -- * Behaviors
    -- $Behavior
    Behavior, behavior, always, initial, changes, apply,
    accumulate', accumulateChange, accumulateIO, accumulateIOChange,
    mapAccum,
    
    -- * The @Change@ data type
    Change(..), isChange, isKeep,
    
    -- * Event Sources
    -- $EventSource
    EventSource(..), Prepare, newEventSource, fire,
    
    -- * Internal
    testCounter, testApply
    ) where

import Prelude hiding (map, filter)
import Control.Applicative
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.Monoid
import System.IO.Unsafe
import System.IO

import Debug.Trace

{-----------------------------------------------------------------------------  
    Prepare
------------------------------------------------------------------------------}

-- | The 'Prepare' monad is just a type synonym for 'IO'.
-- The idea is that the event flow is set up in the 'Prepare' monad;
-- all 'Prepare' actions should be called
-- during the program initialization, but not while the event loop
-- is running.
type Prepare a = IO a

{-----------------------------------------------------------------------------  
    EventSource - "I'll call you back"
------------------------------------------------------------------------------}
{-$EventSource
    
    After having read all about 'Event's and 'Behavior's,
    you want to hook things up to an existing event-based framework,
    like @wxHaskell@ or @Gtk2Hs@.
    How do you do that?
    
    'EventSource's are a small bookkeeping device that helps you with that.
    Basically, they store event handlers. Often, you can just obtain them from
    corresponding bookkeeping devices from your framework,
    but sometimes you have to create your own 'EventSource'
    and use the 'fire' function to hook it into the framework.
    Event sources are also useful for testing.
    
    After creating an 'EventSource',
    you can finally obtain an 'Event' via the `fromEventSource' function.
-}


-- | An 'EventSource' is a facility where you can register
-- callback functions, aka event handlers.
-- 'EventSource's are the precursor of proper 'Event's.
data EventSource a = EventSource {
                    -- | Replace all event handlers by this one.
                      setEventHandler :: (a -> IO ()) -> Prepare ()
                    -- | Retrieve the currently registered event handler.
                    , getEventHandler :: Prepare (a -> IO ()) }

-- add an additional event handler to the source
addEventHandler :: EventSource a -> (a -> IO ()) -> Prepare ()
addEventHandler es f = do
    g <- getEventHandler es
    setEventHandler es (\a -> g a >> f a)


-- | Fire the event handler of an event source manually.
-- Useful for hooking into external event sources.
fire :: EventSource a -> a -> IO ()
fire es a = getEventHandler es >>= ($ a)
    -- here, the purpose of the Prepare monad is intentionally violated

-- | Create a new store for callback functions.
-- They have to be fired manually with the 'fire' function.
newEventSource :: Prepare (EventSource a)
newEventSource = do
    handlerRef <- newIORef (const $ return ())
    return $ EventSource
        { setEventHandler = writeIORef handlerRef
        , getEventHandler = readIORef handlerRef }

{-----------------------------------------------------------------------------
    Event
------------------------------------------------------------------------------}
{-$Event

The 'Event' type constructor is one of the cornerstones of the present
approach to functional reactive programmings.
It represents a stream of values as they occur in time.

-}


-- who would have thought that the implementation is this simple
type AddHandler a = (a -> IO ()) -> Prepare ()

{- | @Event a@ represents a stream of events as they occur in time.
Semantically, you can think of @Event a@ as an infinite list of values
that are tagged with their corresponding time of occurence,

> type Event a = [(Time,a)]

Note that this is a semantic model;
the type is not actually implement that way,
but you can often treat it as if it where.
In particular, most of the subsequent operations
will be explained in terms of this model.

-}
data Event a      = Never
                  | Event { addHandler :: AddHandler a }

-- smart constructor, ensures proper sharing
mkEvent :: AddHandler a -> Event a
mkEvent =
    -- What happens when  unsafePerformIO  is accidentally exectued twice?
    -- In that case, work will be duplicated as there will be two
    -- buffers (event sources) for one and the same event.
    -- But this is the same as the situation without any sharing at all,
    -- so there's no harm done.
    -- There might be a problem with executing IO actions twice, though.
    \h -> unsafePerformIO $ share $ Event { addHandler = h }
    where
    -- Cache the value of an event,
    -- so that it's not recalculated for multiple consumers
    share :: Event a -> Prepare (Event a)
    share e1 = do
        es2 <- newEventSource
        addHandler e1 (fire es2) -- sharing happens through call-by-need
        return $ fromEventSource es2

-- | Derive an 'Event' from an 'EventSource'.
-- Apart from 'never', this is the only way to construct events.
fromEventSource :: EventSource a -> Event a
fromEventSource s = Event { addHandler = addEventHandler s }

-- | Schedule an IO event to be executed whenever it happens.
-- This is the only way to observe events.
-- Semantically, you could write it as something like this
--
-- > reactimate ((time,action):es) = atTime time action >> reactimate es 
-- 
-- The 'Prepare' monad indicates that you should call this function
-- during program initialization only.
reactimate :: Event (IO ()) -> Prepare ()
reactimate Never = return ()
reactimate e     = addHandler e id

-- | The value 'never' denotes the event that never happens.
-- We can model it as the empty stream of events, @never = []@.
never :: Event a
never = Never

-- | The 'Functor' instance allows you to map the values of type 'a'.
-- Semantically,
-- 
-- > fmap f ((time,a):es) = (time, f a) : fmap f es
instance Functor Event where
    fmap f Never = Never
    fmap f e     = mkEvent addHandler'
        where addHandler' g = addHandler e (g . f)

-- | Version of 'fmap' that performs an 'IO' action for each event occurence.
mapIO :: (a -> IO b) -> Event a -> Event b
mapIO f Never = Never
mapIO f e     = mkEvent addHandler'
    where addHandler' g = addHandler e (g <=< f)


-- | Merge two event streams of the same type. Semantically, we have
-- 
-- > union ((time1,a1):es1) ((time2,a2):es2)
-- >    | time1 < time2 = (time1,a1) : union es1 ((time2,a2):es2)
-- >    | time1 > time2 = (time2,a2) : union ((time1,a1):es1) es2
-- >    | otherwise     = ... -- either of the previous two cases
-- 
-- Note that the order of events that happen simultaneously is /undefined/.
-- This is not a problem most of the time,
-- but sometimes you have to force a certain order.
-- In that case, you have to combine this with the 'orderedDuplicate' function. 
union :: Event a -> Event a -> Event a
union Never e2    = e2
union e1    Never = e1
union e1    e2    = mkEvent addHandler'
    where addHandler' g = addHandler e1 g >> addHandler e2 g

-- | The 'Monoid' instance allows you to merge event streams,
-- see the 'union' function below.
-- 
-- > mempty  = never
-- > mappend = union
instance Monoid (Event a) where
    mempty  = never
    mappend = union

-- | Merge two event streams that have differen types. Semantically, we have
-- 
-- > merge e1 e2 = fmap Left e1 `union` fmap Right e2
merge :: Event a -> Event b -> Event (Either a b)
merge e1 e2 = fmap Left e1 `union` fmap Right e2


-- | Duplicate an event stream while paying attention to ordering.
-- Events from the first duplicate (and anything derived from them)
-- will always happen
-- before the events from the second duplicate.
-- Use this function to fine-tune the order of events.
orderedDuplicate :: Event a -> (Event a, Event a)
orderedDuplicate Never = (never, never)
orderedDuplicate e     =
    unsafePerformIO $ do      -- should be safe, though, only for sharing
        es1 <- newEventSource
        es2 <- newEventSource
        addHandler e $ \a -> fire es1 a >> fire es2 a
        return (fromEventSource es1, fromEventSource es2)

-- | Pass all events that fulfill the predicate, discard the rest. Semantically,
-- 
-- > filter p es = [(time,a) | (time,a) <- es, p a]
filter :: (a -> Bool) -> Event a -> Event a
filter p Never = Never
filter p e     = mkEvent addHandler'
    where addHandler' g = addHandler e $ \a -> when (p a) (g a)

-- | Unpacks event values of the form @Change _@ and discards
-- everything else.
filterChanges :: Event (Change a) -> Event a
filterChanges = fmap (\(Change x) -> x) . filter isChange


-- | Debugging helper. Prints the first argument and the value of the event
-- whenever it happens to 'stderr'.
traceEvent :: Show a => String -> Event a -> Event a
traceEvent s = mapIO (\a -> hPutStrLn stderr (s ++ " : " ++ show a) >> return a)

{-----------------------------------------------------------------------------
    Behavior
------------------------------------------------------------------------------}
{-
FIXME: exporting  initial  to users might cause space leaks
where the initial value is retained long beyond the point where
it was consumed.
However, if we want the user to implement optimized behaviors
himself, like  TimeGraphic , we have to provide a mechanism
similar to this one.
Alternative: keep current value in a IORef. This will eliminate
this particular space leak? Probably not. I think it's fine the way it is.
-}

{-$Behavior

The 'Behavior' type constructor is the other cornerstone of the
present approach to functional reactive programming.
It represents a value that changes with time.

-}

{-| @Behavior a@ represents a value in time. Think of it as

> type Behavior a = Time -> a

However, note that this model misses an important point:
we only allow /piecewise constant/ functions.
Continuous behaviors like

> badbehavior = \time -> 2*time

cannot be implemented.

-}
data Behavior a = Behavior {
    initial :: a,       -- ^ The value that the behavior initially has.
    changes :: Event a
        -- ^ An event stream recording how the behavior changes
        -- Remember that behaviors are piecewise constant functions.
    }

-- | Smart constructor. Supply an initial value and a sequence of changes.
-- In particular,
-- 
-- > initial (behavior a es) = a
-- > changes (behavior a es) = es
behavior :: a -> Event a -> Behavior a
behavior = Behavior

-- | The constant behavior. Semantically,
-- 
-- > always a = \time -> a
always :: a -> Behavior a
always a = Behavior { initial = a, changes = never }

    -- trigger an event whenever the value changes.
-- changes :: Behavior a -> Event a

-- | Version of 'accumulate' that involves the 'Change' data type
-- and performs an 'IO' action to update the value.
-- 
-- It is recommended that you use the 'accumulate' function from
-- 'Reactive.Classes' to pick types automatically.
accumulateIOChange :: (b -> a -> IO (Change a)) -> a -> Event b -> Behavior a
accumulateIOChange f a Never = always a
accumulateIOChange f a eb    =
    Behavior { initial = a , changes = mkEvent addHandler' }
    where
    addHandler' g = addHandler eb (handler g)
    
    -- we need a global state
    -- FIXME: NOINLINE pragma!
    ref = unsafePerformIO $ newIORef a
    handler g = \b -> do
        a   <- readIORef ref    -- read old value
        ma' <- f b a            -- accumulate
        case ma' of
            Keep      -> return ()
            Change a' -> do
                writeIORef ref $! a'    -- use new value
                g a'

{- | The most important way to create behaviors.
The 'accumulate'' function is similar to a strict left fold, 'foldl''.
It starts with an initial value and combines it with incoming events.
For example, semantically
 
> accumulate' (++) "x" [(time1,"y"),(time2,"z")]
>    = behavior "x" [(time1,"yx"),(time2,"zyx")]
 
Note that the accumulated value is evaluated /strictly/.
This prevents space leaks.

It is recommended that you use the 'accumulate' function from
'Reactive.Classes' to pick types automatically.
-}
accumulate' :: (b -> a -> a) -> a -> Event b -> Behavior a
accumulate' f = accumulateIOChange (\b a -> return . Change $ f b a)

-- | Version of 'accumulate' that involves the 'Change' data type.
-- Use the 'Keep' constructor to indicate that the incoming event 
-- hasn't changed the value. No change event will be propagated in that case.
-- 
-- It is recommended that you use the 'accumulate' function from
-- 'Reactive.Classes' to pick types automatically.
accumulateChange :: (b -> a -> Change a) -> a -> Event b -> Behavior a
accumulateChange f = accumulateIOChange (\b a -> return $ f b a)


-- | Version of 'accumulate' that performs an 'IO' action to update the value.
--     
-- It is recommended that you use the 'accumulate' function from
-- 'Reactive.Classes' to pick types automatically.
accumulateIO :: (b -> a -> IO a) -> a -> Event b -> Behavior a
accumulateIO f = accumulateIOChange (\b a -> fmap Change $ f b a)
    -- Note: IO would be unsound without sharing!


-- | The 'Functor' instance allows you to map the values of type @a@.
-- Semantically, 
-- 
-- > fmap f behavior = \time -> f (behavior time)
instance Functor Behavior where
    fmap f b = Behavior
        { initial = f (initial b), changes = fmap f (changes b) }

-- | The 'Applicative' instance is one most of the most important ways
-- to combine behaviors. Semantically,
-- 
-- > pure a    = always a
-- > bf <*> bx = \time -> bf time $ bx time 
instance Applicative Behavior where
    pure a    = always a
    
    -- optimize the cases where the event never fires
    (Behavior f Never) <*> bx = fmap (f $) bx
    bf <*> (Behavior x Never) = fmap ($ x) bf
    bf <*> bx                 = fmap (uncurry ($)) $
        accumulate' go (initial bf, initial bx) (changes bf `merge` changes bx)
        where
        go (Left  f') (f,x) = (f',x)
        go (Right x') (f,x) = (f,x')

    -- store the occurences of an event in a behavior
-- latch :: Event a -> Behavior (Maybe a)
-- latch = accumulate' (\a _ -> Just a) Nothing

-- | Map events while threading state.
-- Similar to the standard 'mapAccumL' function.
mapAccum :: (acc -> x -> (acc,y)) -> acc -> Event x -> (Behavior acc, Event y)
mapAccum f acc Never = (always acc, never) 
mapAccum f acc xs    =
    (fmap fst result, fmap snd $ changes result)
    where
    result = accumulate' (\x (acc,_) -> f acc x) (acc,undefined) xs

-- | The most important way to combine behaviors and events.
-- The 'apply' function applies a time-varying function to a stream of events.
-- Semantically,
-- 
-- > apply bf es = [(time, bf time a) | (time, a) <- es]
-- 
-- (Theoretically inclined people might
-- be wondering whether we could achieve the same effect with
-- the 'Applicative' instance. The answer is no, the semantics of
-- 'apply' and '<*>' are subtly different. That's why we need to distinguish
-- between behaviors and events.)
apply :: Behavior (a -> b) -> Event a -> Event b
apply (Behavior f Never) ex    = fmap f ex
apply bf                 Never = Never
apply bf                 ex    =
    filterChanges . snd . mapAccum go (initial bf) $ changes bf `merge` ex
    where
    go _ (Left  f) = (f, Keep)
    go f (Right x) = (f, Change $ f x)

{-----------------------------------------------------------------------------
    Change
------------------------------------------------------------------------------}
{- | Data type to indicate that a value has changed.
Used in conjunction with the 'accumulate' functions.

This is basically the @Maybe@ type with a different name.
Using a different name improves program readability
and makes it easier to automatically select the right 'accumulate'
function by type, see the 'Reactive.Classes' module.
-}
data Change a =
    Keep            -- ^ Signals that the value has not changed.
    | Change a      -- ^ Indicates a change to some value of type @a@.
    deriving (Eq, Show, Read)

instance Functor Change where
    fmap _ Keep       = Keep
    fmap f (Change a) = Change (f a)

-- | The 'isChange' function returns 'True' iff its argument is of the form @Change _@.
isChange :: Change a -> Bool
isChange (Change _) = True
isChange _          = False

-- | The 'isKeep' function returns 'True' iff its argument is of the form @Keep@.
isKeep :: Change a -> Bool
isKeep Keep = True
isKeep _    = False

{-----------------------------------------------------------------------------
    Test examples
    
    The examples return event sources that you can fire.
------------------------------------------------------------------------------}
testCounter :: Prepare (EventSource Int)
testCounter = do
    es <- newEventSource
    let e = fromEventSource es
    reactimate . changes $ print <$> accumulate' (+) 0 e
    return es

-- test the  apply  function
testApply :: Prepare (EventSource Int, EventSource Int)
testApply = do
    es1 <- newEventSource
    let e1 = fromEventSource es1
    
    es2 <- newEventSource
    let e2 = fromEventSource es2

    reactimate . fmap print $ apply (fmap (+) (Behavior 0 e1)) e1
    return (es1, es2)