packages feed

buster 2.2 → 2.5

raw patch · 5 files changed

+551/−19 lines, 5 filesdep ~base

Dependency ranges changed: base

Files

+ App/DebugEventBus.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -O0 #-}+-- | 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.DebugEventBus where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Data.Maybe+import Data.List (foldl', foldl1')+import Data.Monoid+import qualified Data.Set as Set+import Data.Time.Clock+import Data.Time.Format+import System.Locale+import qualified Data.Map as Map+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import System.IO.Unsafe+import System.IO+import Debug.Trace++-- 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++data BusIterationChanges = +      Deleted String String String String String+    | Inserted String String String String String+    | Click +    deriving (Eq,Show,Read)++-- | 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.+    | InstrumentedBehaviour String++instance Show (Diff a) where+    show (Insertion a) = show ("Insertion",group a, src a, ename a, timespan a)+    show (Deletion a) = show ("Deletion",group a, src a, ename a, timespan a)+++-- | Defines the data attachable to events.+data EData a =+      EString String+    | EByteString B.ByteString+    | EByteStringL [B.ByteString]+    | ELByteString LB.ByteString+    | ELByteStringL [LB.ByteString]+    | EChar Char+    | EDouble Double+    | EInt Int+    | EBool Bool+    | EStringL [String]+    | EDoubleL [Double]+    | EIntL [Int]+    | EBoolL [Bool]+    | EOther a+    | EAssoc (String,EData a)+    | EAssocL [(String,EData a)]+    | EOtherL [a]+    deriving (Eq, Show, Read)++fromEString (EString a) = a+fromEByteString (EByteString a) = a+fromEByteStringL (EByteStringL a) = a+fromELByteString (ELByteString a) = a+fromELByteStringL (ELByteStringL a) = a+fromEChar (EChar a) = a+fromEDouble (EDouble a) = a+fromEInt (EInt a) = a+fromEBool (EBool a) = a+fromEStringL (EStringL a) = a+fromEDoubleL (EDoubleL a) = a+fromEIntL (EIntL a) = a+fromEBoolL (EBoolL a) = a+fromEOther (EOther a) = a+fromEAssoc (EAssoc a) = a+fromEAssocL (EAssocL a) = a+fromEOtherL (EOtherL a) = a++-- | Show without risking running into an unshowable type.+safeShow :: Maybe Int -> EData a -> String+safeShow n (EString s) = maybe s ((flip take) s) n+safeShow n (EStringL s) = maybe (show s) ((flip take) (show s)) n+safeShow n (EByteString _) = "ByteString data"+safeShow n (EByteStringL _) = "ByteString list data"+safeShow n (EChar c) = [c]+safeShow n (EDouble x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EDoubleL x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EInt x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EIntL x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EBool x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EBoolL x) = maybe (show x) ((flip take) (show x)) n+safeShow n (EAssoc (x,y)) = x ++ " -> " ++ safeShow n y+safeShow n (EAssocL xs) = concat $ (\(a,b) -> "(" ++ a ++ " -> " ++ safeShow n b ++ ")\n" ) <$> xs+safeShow n (EOther _) = "Other data"+safeShow n (EOtherL _) = "Other data list"++-- | An discrete event in time+data Event a = Event+    { ename :: 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 :: 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) />/+                  ((group %=> compare) l r) />/+                  ((ename %=> compare) l r)++instance Eq (Event a) where+    x == y = (ename %=> (==)) 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.+    , currentProducerConsumer :: Maybe String +    , debugout :: Handle }++instance Show (Bus a) where+    show = concat . map showQName . Map.elems . fullyQualifiedMap++showQName ev = show (group ev, src ev, ename ev, timespan ev)++eventsByName :: String -> Bus a -> Set.Set (Event a)+eventsByName n = fromMaybe Set.empty . Map.lookup n . nameMap++eventsBySource :: String -> Bus a -> Set.Set (Event a)+eventsBySource s = fromMaybe Set.empty . Map.lookup s . srcMap++eventsByGroup :: String -> Bus a -> Set.Set (Event a)+eventsByGroup g = fromMaybe Set.empty . Map.lookup g . groupMap++eventByQName:: String -> String -> String -> Bus a -> Maybe (Event a)+eventByQName g s n = Map.lookup (g,s,n) . fullyQualifiedMap++eventsFor (Just g) Nothing Nothing b = eventsByGroup g b+eventsFor Nothing (Just s) Nothing b = eventsBySource s b+eventsFor Nothing Nothing (Just n) b = eventsByName n b+eventsFor (Just g) (Just s) (Just n) b = maybe Set.empty (Set.singleton) (eventByQName g s n b)+eventsFor g s n b = persection gset . persection sset $ nset+    where gset = fromMaybe Set.empty $ (flip eventsByGroup) b <$> g+          sset = fromMaybe Set.empty $ (flip eventsBySource) b <$> s+          nset = fromMaybe Set.empty $ (flip eventsByName) b <$> n+          persection a b | a == Set.empty = b+                         | b == Set.empty = a+                         | otherwise = Set.intersection a b++filteredEventsFor (Left g) (Right sfilter) (Right nfilter) b = filter nfilter . filter sfilter . Set.toList $ eventsByGroup g b+filteredEventsFor (Right gfilter) (Left s) (Right nfilter) b = filter gfilter . filter nfilter . Set.toList $ eventsBySource s b+filteredEventsFor (Right gfilter) (Right sfilter) (Left n) b = filter gfilter . filter sfilter . Set.toList $ eventsByName n b+filteredEventsFor (Left g) (Left s) (Left n) b = maybe [] (\a -> [a]) (eventByQName g s n b)+filteredEventsFor (Right gfilter) (Right sfilter) (Right nfilter) b = filter gfilter . filter sfilter . filter nfilter . map snd . Map.toList . fullyQualifiedMap $ b+filteredEventsFor (Right gfilter) (Left s) (Left n) b = filter gfilter . Set.toList$ eventsFor Nothing (Just s) (Just n) b+filteredEventsFor (Left g) (Right sfilter) (Left n) b = filter sfilter . Set.toList $ eventsFor (Just g) Nothing (Just n) b+filteredEventsFor (Left g) (Left s) (Right nfilter) b = filter nfilter . Set.toList $ eventsFor (Just g) (Just s) Nothing b++topEvent = head . Set.toList++instance Monoid (Bus a) where+    mempty = emptyBus+    mappend (Bus n0 s0 g0 f0 cpc h) (Bus n1 s1 g1 f1 _ _) = Bus (Map.union n0 n1) (Map.union s0 s1) (Map.union g0 g1) (Map.union f0 f1) cpc h++-- | The empty bus+emptyBus :: Bus a+emptyBus = Bus Map.empty Map.empty Map.empty Map.empty Nothing $! (unsafePerformIO $ openFile "buster.evtprof" WriteMode)++-- | Add an event to time within the bus+addEvent :: Event a -> Bus a -> Bus a+addEvent edata b = b{ nameMap = Map.insertWith (Set.union) (ename 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, ename 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 (Bus a, MVar [Diff a])++-- | An IO action sometime in the future.+future :: Bus a -> IO [Diff a] -> Future a+future b thunk = do+    ref <- newEmptyMVar+    forkIO $ thunk >>= putMVar ref+    return (b,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 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 a (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 >>= 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 >>= 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 -> future m $ do+    (_,mv0) <- behaviour0 m+    (_,mv1) <- behaviour1 m+    value0 <- takeMVar mv0 -- :: IO [Diff a]+    value1 <- takeMVar mv1 -- :: IO [Diff a]+    return $ value0 ++ value1++behind = (>~>)+beside = (|~|)+infrontof = (<~<)++applyDiff (m,ds) = do+    ds' <- immediate ds +    now <- formatTime defaultTimeLocale "%H:%M:%S%Q" <$> getCurrentTime+    (foldM (busDiff now) m $ ds') >>= \b -> return b{ currentProducerConsumer = Nothing }+    where busDiff now b (Insertion ev) = do maybe (return ()) (\cpc -> hPutStr (debugout b) (show $ Inserted cpc (group ev) (src ev) (ename ev) now )) (currentProducerConsumer b)+                                            return b{ nameMap = Map.insertWith (union') (ename ev) (singleton ev) (nameMap b)+                                                , srcMap = Map.insertWith (union') (src ev) (singleton ev) (srcMap b)+                                                , groupMap = Map.insertWith (union') (group ev) (singleton ev) (groupMap b)+                                                , fullyQualifiedMap = Map.insert (group ev, src ev, ename ev) ev (fullyQualifiedMap b) }+          busDiff now b (Deletion ev) = do maybe (return ()) (\cpc -> hPutStr (debugout b) (show $ Deleted cpc (group ev) (src ev) (ename ev) now)) (currentProducerConsumer b)+                                           return b { nameMap = deleteOneFrom ev (ename ev) (nameMap b) +                                                , srcMap = deleteOneFrom ev (src ev) (srcMap b)+                                                , groupMap = deleteOneFrom ev (group ev) (groupMap b)+                                                , fullyQualifiedMap = Map.delete (group ev, src ev, ename ev) (fullyQualifiedMap b) }+          busDiff now b (InstrumentedBehaviour bname) = return b{ currentProducerConsumer = Just bname }                                      +          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+          union' v st = Set.union (Set.difference st v) v			++instrument bname behave bus = behave <~< (return . future bus . return $ [InstrumentedBehaviour bname] )++-- | 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 -> do diffs <- behaviour m+                     bus' <- applyDiff diffs+                     bus'' <- expire <$> decrementTimeSpan bus'+                     putMVar b bus''+                     hPutStr (debugout bus'') . show $ Click                     ++-- | Assign an event to time given some event data and a TimeSpan.+--+--   @produce group source nm timetolive edata@+produce :: String -> String -> String -> TimeSpan -> 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' group source nm timetolive edata bus@+produce' :: String -> String -> String -> TimeSpan -> 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.+consumeNamedEventsCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a+consumeNamedEventsCollectivelyWith em nm f =+    maybe (future em . return $ [])+          (\ev -> future em $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup nm (nameMap em))++consumeNamedEvents :: String -> Behaviour a+consumeNamedEvents nm b =+    maybe (future b . return $ [])+          (\ev -> future b . return $ Deletion <$> Set.toList ev)+          (Map.lookup nm . nameMap $ b)++consumeEventGroup :: String -> Behaviour a+consumeEventGroup g b =+    maybe (future b . return $ [])+          (\ev -> future b . return $ Deletion <$> Set.toList ev)+          (Map.lookup g . groupMap $ b)++consumeEventsFromSource :: String -> Behaviour a+consumeEventsFromSource s b =+    maybe (future b . return $ [])+          (\ev -> future b . return $ Deletion <$> Set.toList ev)+          (Map.lookup s . srcMap $ b)++consumeFullyQualifiedEvent :: String -> String -> String -> Behaviour a+consumeFullyQualifiedEvent g s n b =+    maybe (future b . return $ [])+          (\ev -> future b . return $ [Deletion ev])+          (Map.lookup (g, s, n) . fullyQualifiedMap $ b)++modifyEventData :: Event a -> (a -> a) -> [Diff a]+modifyEventData ev f = [Insertion ev{ eventdata = f . eventdata $ ev }]++modifyEvent :: Event a -> (Event a -> Event a) -> [Diff a]+modifyEvent ev f = let ev' = f ev in if ev==ev' then [Insertion ev'] else [Deletion ev, Insertion ev']++consumeNamedEventsWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a+consumeNamedEventsWith b n f =+    future b $ concat <$> ((\l -> (map Deletion l :) <$>  mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (nameMap b)))++-- | 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.+consumeEventGroupCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a+consumeEventGroupCollectivelyWith em gp f =+    maybe (future em . return $ [])+          (\ev -> future em $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup gp (groupMap em))++consumeEventGroupWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a+consumeEventGroupWith b n f =+    future b $ concat <$> ((\l -> (map Deletion l :) <$>  mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (groupMap b)))++-- | 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.+consumeEventsFromSourceCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a+consumeEventsFromSourceCollectivelyWith em source f =+    maybe (future em . return $ [])+          (\ev -> future em $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup source (srcMap em))++consumeEventsFromSourceWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a+consumeEventsFromSourceWith b n f =+    future b $ concat <$> ((\l -> (map Deletion l :) <$>  mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (srcMap b)))++-- | 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.  Parameter order is bus, group, source, name+consumeFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future a+consumeFullyQualifiedEventWith em group source name f =+    maybe (future em . return $ [])+          (\ev -> future em $ (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 a+pollNamedEventsCollectivelyWith b nm f = maybe (future b . return $[]) (future b . 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 a+pollNamedEventsWith b nm f = future b $ 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 a+pollEventGroupCollectivelyWith b nm f = maybe (future b . return $[]) (future b . 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 a+pollEventGroupWith b nm f = future b $ 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 a+pollEventsFromSourceCollectivelyWith b nm f = maybe (future b . return $[]) (future b . 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 a+pollEventsFromSourceWith b nm f = future b $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (srcMap b)))++-- | Sample a single fully qualified event and output some Diffs.+--   Parameter order is bus, group, source, name.+pollFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future a+pollFullyQualifiedEventWith b gp source nm f = maybe (future b . return $ []) (future b . 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 a+pollAllEventsWith b f = future b $ 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 a+pollAllEventsCollectivelyWith b f = future b $ f . Set.fromList . Map.elems . fullyQualifiedMap $ b++					+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 = b'+	where current (Time x) = x > 0+	      current Persistent = True+	      current (Iterations x) = x > 0+	      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)+                   Nothing+                   (debugout b)++listM v = v >>= return . (:[])	+	+{- 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+ -}
App/EventBus.hs view
@@ -96,6 +96,23 @@     | EOtherL [a]     deriving (Eq, Show, Read) +fromEString (EString a) = a+fromEByteString (EByteString a) = a+fromEByteStringL (EByteStringL a) = a+fromELByteString (ELByteString a) = a+fromELByteStringL (ELByteStringL a) = a+fromEChar (EChar a) = a+fromEDouble (EDouble a) = a+fromEInt (EInt a) = a+fromEBool (EBool a) = a+fromEStringL (EStringL a) = a+fromEDoubleL (EDoubleL a) = a+fromEIntL (EIntL a) = a+fromEBoolL (EBoolL a) = a+fromEOther (EOther a) = a+fromEAssoc (EAssoc a) = a+fromEAssocL (EAssocL a) = a+fromEOtherL (EOtherL a) = a  -- | Show without risking running into an unshowable type. safeShow :: Maybe Int -> EData a -> String@@ -111,7 +128,7 @@ safeShow n (EBool x) = maybe (show x) ((flip take) (show x)) n safeShow n (EBoolL x) = maybe (show x) ((flip take) (show x)) n safeShow n (EAssoc (x,y)) = x ++ " -> " ++ safeShow n y-safeShow n (EAssocL xs) = concat $ (\(a,b) -> a ++ " -> " ++ safeShow n b) <$> xs+safeShow n (EAssocL xs) = concat $ (\(a,b) -> "(" ++ a ++ " -> " ++ safeShow n b ++ ")\n" ) <$> xs safeShow n (EOther _) = "Other data" safeShow n (EOtherL _) = "Other data list" @@ -141,6 +158,8 @@     , 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.++instrument bname behave = behave   instance Show (Bus a) where     show = concat . map showQName . Map.elems . fullyQualifiedMap
App/Widgets/Environment.hs view
@@ -10,9 +10,9 @@ import Control.Applicative  isNotBlankLine = (/=0) . length . filter (/=' ') . filter (/='\t')-isNotCommentLine = not . elem ' '+isNotCommentLine = not . (=='#') . head hasValue = elem '='-parseConfigLine = liftA2 (,) (spaces *> many1 alphaNum <* spaces) (spaces *> char '=' *> many anyChar)+parseConfigLine = liftA2 (,) (many1 alphaNum) (spaces *> char '=' *> many anyChar)  -- | Place the command line arguments on the bus as an Event following the pattern --@@ -26,15 +26,15 @@ -- --    * data : EStringL of the command line args commandLineArgsWidget :: Widget [EData a]-commandLineArgsWidget b = getArgs >>= -    \args -> produce' "Environment" "CommandLineArgsWidget" "argv" Persistent [EStringL args] b +commandLineArgsWidget b = getArgs >>=+    \args -> produce' "Environment" "CommandLineArgsWidget" "argv" Persistent [EStringL args] b  -- | Read a config file and place it on the bus as individual events for each config item following the pattern: -- --     * name : config item name -- --     * group : Environment---      +-- --     * source : /filename/.ConfigFileWidget -- --     * timespan : Persistent@@ -46,17 +46,17 @@ --   ConfigFile := [ConfigLine] -- --   ConfigLine := <key> spaces = spaces <value> endl | CommentLine | BlankLine---   +-- --   CommentLine := # anychars endl---   +-- --   BlankLine := spaces endl configFileWidget :: String -> Widget [EData a] configFileWidget f b = configLines >>= mapM_ produceConfigDataEvent     where produceConfigDataEvent (n,v) = produce' "Environment" (f ++ ".ConfigFileWidget") n Persistent [EString v] b-          configLines = rights . map (parse parseConfigLine "(Unknown line in config file)") +          configLines = rights . map (parse parseConfigLine "(Unknown line in config file)")                             . filter isNotBlankLine                             . filter isNotCommentLine-                            . filter hasValue +                            . filter hasValue                             . lines                             <$> readFile f @@ -73,7 +73,7 @@ --     * data : EString variable value -- environmentWidget :: Widget [EData a]-environmentWidget b = getEnvironment >>= +environmentWidget b = getEnvironment >>=     mapM_ (\(k,v) -> produce' "Environment" "EnvironmentWidget" k Persistent [EString v] b)  -- | Set the program name as an event on the bus using the following pattern:@@ -88,5 +88,5 @@ -- --     * data : EString progran name progNameWidget :: Widget [EData a]-progNameWidget b = getProgName >>= +progNameWidget b = getProgName >>=     \v -> produce' "Environment" "ProgramNameWidget" "ProgramName" Persistent [EString v] b
App/Widgets/Pacer.hs view
@@ -21,9 +21,11 @@ -- | Send a heartbeat event out every /timeout/ microseconds to the bus paceMicrosecondsWidget :: Int -> String -> Widget [a] paceMicrosecondsWidget timeout timername b = do-    forkIO $ do-        threadDelay timeout-        produce' "Timers" "PacerWidget" timername once [] b+    let loop = do+            threadDelay timeout+            produce' "Timers" "PacerWidget" timername once [] b+            loop+    forkIO $ loop     return ()  -- | @paceMillisecondsWidget timeout timername bus@
buster.cabal view
@@ -1,12 +1,12 @@ name: buster-version: 2.2+version: 2.5 cabal-version: -any build-type: Simple license: BSD3 license-file: "" copyright: 2009 Renaissance Computing Institute maintainer: Jeff Heard <jeff@renci.org>-build-depends: base -any, binary -any, bytestring -any,+build-depends: base <=4.0.0, binary -any, bytestring -any,                containers -any, dataenc -any, mtl -any, old-locale -any,                parsec >=3.0.0, pretty -any, time -any stability: Experimental@@ -32,7 +32,7 @@ data-dir: "" extra-source-files: extra-tmp-files:-exposed-modules: App.EventBus App.Behaviours.PrintEvents+exposed-modules: App.EventBus App.DebugEventBus App.Behaviours.PrintEvents                  App.Behaviours.Exception App.Behaviours.FileOps App.Widgets.Pacer                  App.Widgets.Environment exposed: True@@ -54,7 +54,7 @@ other-modules: ghc-prof-options: ghc-shared-options:-ghc-options:+ghc-options: -O2 -fvia-C -optc-O3 hugs-options: nhc98-options: jhc-options: