packages feed

buster 2.5 → 2.21

raw patch · 4 files changed

+8/−540 lines, 4 filesdep ~base

Dependency ranges changed: base

Files

− App/DebugEventBus.hs 
@@ -1,511 +0,0 @@-{-# 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,23 +96,6 @@     | 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@@ -128,7 +111,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 ++ ")\n" ) <$> xs+safeShow n (EAssocL xs) = concat $ (\(a,b) -> a ++ " -> " ++ safeShow n b) <$> xs safeShow n (EOther _) = "Other data" safeShow n (EOtherL _) = "Other data list" @@ -158,8 +141,6 @@     , 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/Pacer.hs view
@@ -21,11 +21,9 @@ -- | Send a heartbeat event out every /timeout/ microseconds to the bus paceMicrosecondsWidget :: Int -> String -> Widget [a] paceMicrosecondsWidget timeout timername b = do-    let loop = do-            threadDelay timeout-            produce' "Timers" "PacerWidget" timername once [] b-            loop-    forkIO $ loop+    forkIO $ do+        threadDelay timeout+        produce' "Timers" "PacerWidget" timername once [] b     return ()  -- | @paceMillisecondsWidget timeout timername bus@
buster.cabal view
@@ -1,12 +1,12 @@ name: buster-version: 2.5+version: 2.21 cabal-version: -any build-type: Simple license: BSD3 license-file: "" copyright: 2009 Renaissance Computing Institute maintainer: Jeff Heard <jeff@renci.org>-build-depends: base <=4.0.0, binary -any, bytestring -any,+build-depends: base -any, 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.DebugEventBus App.Behaviours.PrintEvents+exposed-modules: App.EventBus 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: -O2 -fvia-C -optc-O3+ghc-options: hugs-options: nhc98-options: jhc-options: