buster-0.99.1: App/EventBus.hs

{-# LANGUAGE TypeSynonymInstances #-}
-- | Not exactly the FRP model, but rather a model of a large application with
--   heterogenous data and many inputs and outputs.  An application is in its
--   essence a collection of widgets and behaviours and events with a bus.
--   The bus holds events and manages the event timeline.  Behaviours and
--   widgets are continuous. Widgets applied to the bus make insertions and
--   never deletions. Behaviours applied to the bus make insertions and deletions.
--
--   Behaviours are composable using combinators that set one Behaviour as either
--   behind, in front, or beside another behaviour on the bus.  The in front and
--   behind combinators  establish that the behaviour "behind" the others
--   sees the results of the other behaviours' application to the bus. The beside
--   combinator says that the combinators see the same bus.
--
module App.EventBus where

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Maybe
import Data.List (foldl')
import Data.Monoid
import qualified Data.Set as Set
import Data.Time.Clock
import qualified Data.Map as Map
import qualified Data.ByteString as B
import System.IO.Unsafe

-- generic functions for key ordering.  move somewhere else later
EQ />/ b = b
a />/ _ = a

a /</ EQ = a
_ /</ b = b

g %=> f = f `on` g

on f g a b = f (g a) (g b)

-- IO version of the <* Applicative operator
a =<<^ b = \m -> b >> a m

-- | Defines the amount of time that an event exists.
data TimeSpan =
      Persistent            -- ^ The event exists forever
    | Time DiffTime         -- ^ The event exists for a specified amount of real time
    | Iterations Int        -- ^ The event exists for a certain number of samples of time from its inception.
    deriving (Eq,Ord,Show)

seconds :: Integer -> TimeSpan
seconds = Time . secondsToDiffTime

minutes :: Integer -> TimeSpan
minutes = Time . secondsToDiffTime . (60*)

hours :: Integer -> TimeSpan
hours = Time . secondsToDiffTime . (3600*)

days :: Integer -> TimeSpan
days = Time . secondsToDiffTime . (86400*)

once :: TimeSpan
once = Iterations 1

-- | Defines time in terms of the differences from time t0 to the next instant. This is the type
--   returned by Behaviours to describe time directly after the Behaviour.
data Diff a =
      Insertion (Event a)   -- ^ Time t1 contains all events at time t0 plus this event.
    | Deletion (Event a)    -- ^ Time t1 contains all events at time t0 minus this event.


-- | Defines the data attachable to events.
data EData a =
      EString String
    | EByteString B.ByteString
    | EByteStringL [B.ByteString]
    | EChar Char
    | EDouble Double
    | EInt Int
    | EBool Bool
    | EStringL [String]
    | EDoubleL [Double]
    | EIntL [Int]
    | EBoolL [Bool]
    | EOther a
    | EOtherL [a]
    deriving (Eq, Show, Read)

-- | An discrete event in time
data Event a = Event
    { name :: String            -- ^ The unique name of an event.  Group + src + name = the fully qualified name FQN of the event.
    , group :: String           -- ^ The group of an event.
    , timespan :: TimeSpan      -- ^ The timespan from "time" that an event exists.
    , eventdata :: [EData a]    -- ^ The data attached to the event.
    , src :: String             -- ^ The behaviour or widget that assigned the event to time.
    , time :: UTCTime }         -- ^ The time of the event's inception.


instance Ord (Event a) where
    compare l r = ((src %=> compare) l r) />/
                  ((time %=> compare) l r) />/
                  ((group %=> compare) l r) />/
                  ((name %=> compare) l r)

instance Eq (Event a) where
    x == y = (name %=> (==)) x y &&
             (group %=> (==)) x y &&
             (src %=> (==)) x y

-- | The type of a discrete sample of continuous time.
data Bus a = Bus
    { nameMap :: Map.Map String (Set.Set (Event a))                     -- ^ The map of just Event.name to events.
    , srcMap :: Map.Map String (Set.Set (Event a))                      -- ^ The map of just Event.src to events.
    , groupMap :: Map.Map String (Set.Set (Event a))                    -- ^ The map of just Event.group to events.
    , fullyQualifiedMap :: Map.Map (String,String,String) (Event a) }   -- ^ The map of FQNs to events.

instance Monoid (Bus a) where
    mempty = emptyBus
    mappend (Bus n0 s0 g0 f0) (Bus n1 s1 g1 f1) = Bus (Map.union n0 n1) (Map.union s0 s1) (Map.union g0 g1) (Map.union f0 f1)

-- | The empty bus
emptyBus :: Bus a
emptyBus = Bus Map.empty Map.empty Map.empty Map.empty

-- | Add an event to time within the bus
addEvent :: Event a -> Bus a -> Bus a
addEvent edata b = b{ nameMap = Map.insertWith (Set.union) (name edata) (singleton edata) (nameMap b)
                    , srcMap = Map.insertWith (Set.union) (src edata) (singleton edata) (srcMap b)
                    , groupMap = Map.insertWith (Set.union) (group edata) (singleton edata) (groupMap b)
                    , fullyQualifiedMap = Map.insert (group edata, src edata, name edata) edata (fullyQualifiedMap b) }

-- | The type of widgets.
--   A widget is an input-only way to assign Events to time.  A mouse is a widget.  A keyboard is a
--   widget.  A webcam is a widget, and so on.
type Widget a = MVar (Bus a) -> IO ()

-- | The type of future events..
--   A behaviour doesn't know about the time that it assigns events, only that they exist
--   at some point after the time that the Behaviour sampled.
type Future a = IO (MVar a)

-- | An IO action sometime in the future.
future :: IO a -> Future a
future thunk = do
    ref <- newEmptyMVar
    forkIO $ thunk >>= putMVar ref
    return ref

-- | Obtain the final value of a Future.  Blocks until the value is available
immediate = takeMVar

-- | The type of a Behaviour.  A behaviour maps the bus to a list of differences to apply to the bus
--   before the next Behaviour's sample of time.
type Behaviour a = Bus a -> Future [Diff a]

instance Monoid (Behaviour a) where
    mempty = passthrough
    mappend = (>~>) -- x behind y

-- | The null Behaviour.  Samples the bus and adds and deletes nothing.
passthrough :: Behaviour a
passthrough a = future (return [])

-- | the in front of behaviour combinator. behaviour 1 is in front of behaviour 0, so behavour 0 will see the bus filtered through behaviour 1
(<~<) :: Behaviour a -> Behaviour a -> Behaviour a
behaviour1 <~< behaviour0 = \m -> behaviour0 m >>= applyDiff m >>= behaviour1

-- | the behind behaviour combinator. behaviour 0 is behind behaviour 1, so behaviour 0 will see the bus filtered through behaviour 1
(>~>) :: Behaviour a -> Behaviour a -> Behaviour a
behaviour0 >~> behaviour1 = \m -> behaviour0 m >>= applyDiff m >>= behaviour1

-- | the beside behaviour combinator. All behaviours that are side-by-side see the same bus.
(|~|) :: Behaviour a -> Behaviour a -> Behaviour a
behaviour0 |~| behaviour1 = \m -> do
    future0 <- behaviour0 m
    future1 <- behaviour1 m
    future $ concat <$> mapM immediate [future0, future1]

behind = (>~>)
beside = (|~|)
infrontof = (<~<)

-- | An infinite loop of behaviours and widgets over time, sampled forward.
bus :: [Widget a] -> IO b -> Behaviour a -> IO ()
bus widgets widgetThunk behaviour = do
    evBus <- newMVar emptyBus
    forM_ widgets ($evBus)

    let loop = do
        widgetThunk
        busIteration evBus behaviour
        loop

    loop

-- | Sample time and apply the behaviour to that sample.
busIteration :: MVar (Bus a) -> Behaviour a -> IO ()
busIteration b behaviour = do
    v <- tryTakeMVar b
    case v of
        Nothing -> return ()
        Just m -> putMVar b . expire =<< decrementTimeSpan =<< applyDiff m =<< behaviour m

-- | Assign an event to time given some event data and a TimeSpan.
produce :: String -> String -> String -> TimeSpan -> [EData a] -> IO (Diff a)
produce group source nm timetolive edata =
    (return . Insertion . Event nm group timetolive edata source) =<< getCurrentTime

-- | Assign an event to time from a widget.
produce' :: String -> String -> String -> TimeSpan -> [EData a] -> MVar (Bus a) -> IO ()
produce' group source nm timetolive edata b = getCurrentTime >>= \t -> modifyMVar_ b (return . addEvent (Event nm group timetolive edata source t))

-- | Sample all events with a given name at the current time and output their deletions as Diffs as
--   well as any additional Diffs returned by the behaviour.
consumeNamedEventsWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
consumeNamedEventsWith em nm f =
    maybe (future . return $ [])
          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)
          (Map.lookup nm (nameMap em))

-- | Sample all events with a given group at the current time and output their deletions as Diffs as
--   well as any additional Diffs returned by the behaviour.
consumeEventGroupWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
consumeEventGroupWith em gp f =
    maybe (future . return $ [])
          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)
          (Map.lookup gp (groupMap em))

-- | Sample all events with a given source at the current time and output their deletions as Diffs as
--   well as any additional Diffs returned by the behaviour.
consumeEventsFromSourceWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
consumeEventsFromSourceWith em source f =
    maybe (future . return $ [])
          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)
          (Map.lookup source (srcMap em))

-- | Sample a single fully qualified event at the current time and output their deletions as Diffs as
--   well as any additional Diffs returned by the behaviour.
consumeFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]
consumeFullyQualifiedEventWith em group source name f =
    maybe (future . return $ [])
          (\ev -> future $ (Deletion ev :) <$> f ev)
          (Map.lookup (group,source,name) (fullyQualifiedMap em))

-- | Sample all events with a given name and apply a Behaviour
pollNamedEventsCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
pollNamedEventsCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (nameMap b))

-- | Sample all events with a given name and apply a Behaviour to each
pollNamedEventsWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]
pollNamedEventsWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (nameMap b)))

-- | Sample all events with a given group and apply a Behaviour
pollEventGroupCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
pollEventGroupCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (groupMap b))

-- | Sample all events with a gien group and apply a Behaviour to each.
pollEventGroupWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]
pollEventGroupWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (groupMap b)))

-- | Sample all events with a given source and apply a Behaviour
pollEventsFromSourceCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
pollEventsFromSourceCollectivelyWith b nm f = maybe (future . return $[]) (future.f) (Map.lookup nm (srcMap b))

-- | Sample all events with a given source and apply a Behaviour to each.
pollEventsFromSourceWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]
pollEventsFromSourceWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (srcMap b)))

-- | Sample a single fully qualified event and output some Diffs.
pollFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]
pollFullyQualifiedEventWith b gp source nm f = maybe (future . return $ []) (future . f) (Map.lookup (gp,source,nm) (fullyQualifiedMap b))

-- | Apply a behaviour to all events in the bus, one event at a time.
pollAllEventsWith :: Bus a -> (Event a -> IO [Diff a]) -> Future [Diff a]
pollAllEventsWith b f = future $ concat <$> (mapM f . Map.elems . fullyQualifiedMap $ b)

-- | Apply a behaviour to the collection of all events on the bus at once
pollAllEventsCollectivelyWith :: Bus a -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]
pollAllEventsCollectivelyWith b f = future $ f . Set.fromList . Map.elems . fullyQualifiedMap $ b

applyDiff m ds = immediate ds >>= (return . foldl' busDiff m)
    where busDiff b (Insertion ev) = b{ nameMap = Map.insertWith (Set.union) (name ev) (singleton ev) (nameMap b)
                                      , srcMap = Map.insertWith (Set.union) (src ev) (singleton ev) (srcMap b)
                                      , groupMap = Map.insertWith (Set.union) (group ev) (singleton ev) (groupMap b)
                                      , fullyQualifiedMap = Map.insert (group ev, src ev, name ev) ev (fullyQualifiedMap b) }
          busDiff b (Deletion ev) = b { nameMap = deleteOneFrom ev (name ev) (nameMap b) -- should change this to alter instead of delete, check for empty lists
                                      , srcMap = deleteOneFrom ev (src ev) (srcMap b)
                                      , groupMap = deleteOneFrom ev (group ev) (groupMap b)
                                      , fullyQualifiedMap = Map.delete (group ev, src ev, name ev) (fullyQualifiedMap b) }
          deleteOneFrom ev key mp = case Map.lookup key mp of
					Just eset -> let eset' = Set.delete ev eset in if eset' == Set.empty then Map.delete key mp else Map.insert key eset' mp
					Nothing -> mp
					
singleton a = Set.fromList [a]					
	
decrementTimeSpan b = return $ b{ nameMap = Map.map decrements (nameMap b)
                           , srcMap = Map.map decrements (srcMap b)
                           , groupMap = Map.map decrements (groupMap b)
                           , fullyQualifiedMap = Map.map decrement (fullyQualifiedMap b) }
    where decrement e = e{ timespan = decTimeSpan e (timespan e) }
          decrements = Set.map (\e -> e{timespan = decTimeSpan e (timespan e)} )
          decTimeSpan _ Persistent = Persistent
          decTimeSpan e (Time x) = Time . realToFrac $ diffUTCTime (addUTCTime (realToFrac x) (time e)) (unsafePerformIO getCurrentTime)
          decTimeSpan _ (Iterations x) = (Iterations (x-1))

expire b = Bus (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . nameMap $ b)
               (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . srcMap $ b)
               (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . groupMap $ b)
               (Map.filter (current . timespan) . fullyQualifiedMap $ b)
	where current (Time x) = x > 0
	      current Persistent = True
	      current (Iterations x) = x > 0
	
{- example usage...
 -
 - handleDataLoad :: Behaviour
 - ...
 -
 - handleZoom :: Behaviour
 - ...
 -
 - handlePan :: Behaviour
 - ...
 -
 - handleRot :: Behaviour
 - ...
 -
 - handleWriteData :: Behaviour
 - ...
 -
 - main = do
 -  ui <- getUIFromFile "something.glade"
 -  mapM_ makeGtkProducers ui
 -  multitouch <- getMultitouchProducer "localhost" 8080
 -  bus (multitouch:ui) $ handleDataLoad >~> handleZoom |~| handlePan |~| handleRot >~> handleWriteData
 -
 -}

{- example of generically wrapping a Gtk widget into a EventBus.Widget
 - buttonWidget :: Gtk.Widget -> Bus a -> IO (Behaviour a)
 - buttonWidget button em = Gtk.onClick button $ do
 -      name <- Gtk.getWidgetName button
 -      value <- EString <$> Gtk.getText button
 -      produce' "ui" name "Click" once em
 -}