diff --git a/App/Behaviours/Exception.hs b/App/Behaviours/Exception.hs --- a/App/Behaviours/Exception.hs +++ b/App/Behaviours/Exception.hs @@ -29,7 +29,7 @@ -- | Handle exceptions by completely ignoring them. Not recommended, really, but hey, who am I to judge? disregardExceptionsNamed :: String -> Behaviour [EData a] disregardExceptionsNamed n b = pollEventGroupWith b "Exception" $ - (\e -> return $ if name e == n then [Deletion e] else []) + (\e -> return $ if ename e == n then [Deletion e] else []) -- | Handle exceptions by printing them to stdout and then completely ignoring them. printAndDisregardExceptionsFromSource :: String -> Behaviour [EData a] @@ -39,7 +39,7 @@ -- | Handle exceptions by printing them to stdout and then completely ignoring them printAndDisregardExceptionsNamed :: String -> Behaviour [EData a] printAndDisregardExceptionsNamed n b = pollEventGroupWith b "Exception" $ \e -> - if name e == n then (return . return $ [Deletion e]) =<< (putStrLn . render . renderException $ e) else return [] + if ename e == n then (return . return $ [Deletion e]) =<< (putStrLn . render . renderException $ e) else return [] -- | Handle exceptions by printing them to a handle and then completely ignoring them. logAndDisregardExceptionsFromSource :: Handle -> String -> Behaviour [EData a] @@ -49,5 +49,5 @@ -- | Handle exceptions by printing them to handle and then completely ignoring them logAndDisregardExceptionsNamed :: Handle -> String -> Behaviour [EData a] logAndDisregardExceptionsNamed h n b = pollEventGroupWith b "Exception" $ \e -> - if name e == n then (return . return $ [Deletion e]) =<< (hPutStrLn h . render . renderException $ e) else return [] + if ename e == n then (return . return $ [Deletion e]) =<< (hPutStrLn h . render . renderException $ e) else return [] diff --git a/App/Behaviours/PrintEvents.hs b/App/Behaviours/PrintEvents.hs --- a/App/Behaviours/PrintEvents.hs +++ b/App/Behaviours/PrintEvents.hs @@ -15,20 +15,58 @@ text "emitTime:" <+> text (formatTime defaultTimeLocale "%T" t) $+$ (vcat.map showIfPossible $ edata) return []) - where showIfPossible (EString x) = text x - showIfPossible (EByteString x) = text "ByteString" - showIfPossible (EByteStringL x) = text "[ByteString]" - showIfPossible (EInt x) = text (show x) - showIfPossible (EDouble x) = text (show x) - showIfPossible (EBool x) = text (show x) - showIfPossible (EStringL x) = text (show x) - showIfPossible (EIntL x) = text (show x) - showIfPossible (EDoubleL x) = text (show x) - showIfPossible (EBoolL x) = text (show x) - showIfPossible (EChar x) = char x - showIfPossible (EOther x) = text "Custom Data" - showIfPossible (EOtherL x) = text "Custom Data List" - showIfPossible (EAssoc (x,y)) = text "x -> " <> showIfPossible y - showIfPossible (EAssocL assocs) = vcat (map showAssoc assocs) - showAssoc (x, y) = text x <> showIfPossible y + +showIfPossible (EString x) = text x +showIfPossible (EByteString x) = text "ByteString" +showIfPossible (EByteStringL x) = text "[ByteString]" +showIfPossible (EInt x) = text (show x) +showIfPossible (EDouble x) = text (show x) +showIfPossible (EBool x) = text (show x) +showIfPossible (EStringL x) = text (show x) +showIfPossible (EIntL x) = text (show x) +showIfPossible (EDoubleL x) = text (show x) +showIfPossible (EBoolL x) = text (show x) +showIfPossible (EChar x) = char x +showIfPossible (EOther x) = text "Custom Data" +showIfPossible (EOtherL x) = text "Custom Data List" +showIfPossible (EAssoc (x,y)) = text "x -> " <> showIfPossible y +showIfPossible (EAssocL assocs) = vcat (map showAssoc assocs) +showAssoc (x, y) = text x <> showIfPossible y +printEventGroupBehaviour :: String -> Behaviour [EData a] +printEventGroupBehaviour grp b = pollEventGroupWith b grp $ (\(Event n g lifetime edata source t) -> do + putStrLn.render $ text "name: " <+> text n $+$ + text "source: " <+> text source $+$ + text "group: " <+> text g $+$ + text "ttl: " <+> text (show lifetime) $+$ + text "emitTime:" <+> text (formatTime defaultTimeLocale "%T" t) $+$ + (vcat.map showIfPossible $ edata) + return []) + + +printEventNameBehaviour :: String -> Behaviour [EData a] +printEventNameBehaviour grp b = pollNamedEventsWith b grp $ (\(Event n g lifetime edata source t) -> do + putStrLn.render $ text "name: " <+> text n $+$ + text "source: " <+> text source $+$ + text "group: " <+> text g $+$ + text "ttl: " <+> text (show lifetime) $+$ + text "emitTime:" <+> text (formatTime defaultTimeLocale "%T" t) $+$ + (vcat.map showIfPossible $ edata) + return []) + + +printEventSourceBehaviour :: String -> Behaviour [EData a] +printEventSourceBehaviour grp b = pollEventsFromSourceWith b grp $ (\(Event n g lifetime edata source t) -> do + putStrLn.render $ text "name: " <+> text n $+$ + text "source: " <+> text source $+$ + text "group: " <+> text g $+$ + text "ttl: " <+> text (show lifetime) $+$ + text "emitTime:" <+> text (formatTime defaultTimeLocale "%T" t) $+$ + (vcat.map showIfPossible $ edata) + return []) + +printQNameBehaviour :: Behaviour a +printQNameBehaviour bus = pollAllEventsWith bus $ \(Event n g _ _ s _) -> do + print (g,s,n) + return [] + diff --git a/App/EventBus.hs b/App/EventBus.hs --- a/App/EventBus.hs +++ b/App/EventBus.hs @@ -18,7 +18,7 @@ import Control.Concurrent import Control.Monad import Data.Maybe -import Data.List (foldl') +import Data.List (foldl', foldl1') import Data.Monoid import qualified Data.Set as Set import Data.Time.Clock @@ -26,6 +26,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import System.IO.Unsafe +import Debug.Trace -- generic functions for key ordering. move somewhere else later EQ />/ b = b @@ -69,7 +70,11 @@ 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. +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 @@ -112,7 +117,7 @@ -- | 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. + { 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. @@ -122,12 +127,11 @@ instance Ord (Event a) where compare l r = ((src %=> compare) l r) />/ - ((time %=> compare) l r) />/ ((group %=> compare) l r) />/ - ((name %=> compare) l r) + ((ename %=> compare) l r) instance Eq (Event a) where - x == y = (name %=> (==)) x y && + x == y = (ename %=> (==)) x y && (group %=> (==)) x y && (src %=> (==)) x y @@ -138,6 +142,11 @@ , 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 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 @@ -183,10 +192,10 @@ -- | 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) +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, name edata) edata (fullyQualifiedMap 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 @@ -196,21 +205,21 @@ -- | 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) +type Future a = IO (Bus a, MVar [Diff a]) -- | An IO action sometime in the future. -future :: IO a -> Future a -future thunk = do +future :: Bus a -> IO [Diff a] -> Future a +future b thunk = do ref <- newEmptyMVar forkIO $ thunk >>= putMVar ref - return 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 [Diff a] +type Behaviour a = Bus a -> Future a instance Monoid (Behaviour a) where mempty = passthrough @@ -218,27 +227,44 @@ -- | The null Behaviour. Samples the bus and adds and deletes nothing. passthrough :: Behaviour a -passthrough a = future (return []) +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 m >>= behaviour1 +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 m >>= behaviour1 +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 -> do - future0 <- behaviour0 m - future1 <- behaviour1 m - future $ concat <$> mapM immediate [future0, future1] +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) = immediate ds >>= (\k -> {- trace ("------\n" ++ show k ++ "\n" ++ show m ++ "\n\nthen after diff applied\n\n" ++ (show . foldl' busDiff m $ k)) -} (return . foldl' busDiff m) $ k) + where busDiff b (Insertion ev) = 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 b (Deletion ev) = b { nameMap = deleteOneFrom ev (ename 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, ename 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 + union' v st = Set.union (Set.difference st v) v + + -- | An infinite loop of behaviours and widgets over time, sampled forward. bus :: [Widget a] -> IO b -> Behaviour a -> IO () bus widgets widgetThunk behaviour = do @@ -258,7 +284,10 @@ v <- tryTakeMVar b case v of Nothing -> return () - Just m -> putMVar b . expire =<< decrementTimeSpan =<< applyDiff m =<< behaviour m + Just m -> do diffs <- behaviour m + bus' <- applyDiff diffs + bus'' <- expire <$> decrementTimeSpan bus' + putMVar b bus'' -- | Assign an event to time given some event data and a TimeSpan. -- @@ -275,34 +304,34 @@ -- | 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 [Diff a] +consumeNamedEventsCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a consumeNamedEventsCollectivelyWith em nm f = - maybe (future . return $ []) - (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev) + 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 . return $ []) - (\ev -> future . return $ Deletion <$> Set.toList ev) + 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 . return $ []) - (\ev -> future . return $ Deletion <$> Set.toList ev) + 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 . return $ []) - (\ev -> future . return $ Deletion <$> Set.toList ev) + 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 . return $ []) - (\ev -> future . return $ [Deletion ev]) + maybe (future b . return $ []) + (\ev -> future b . return $ [Deletion ev]) (Map.lookup (g, s, n) . fullyQualifiedMap $ b) modifyEventData :: Event a -> (a -> a) -> [Diff a] @@ -311,91 +340,79 @@ 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 [Diff a] +consumeNamedEventsWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a consumeNamedEventsWith b n f = - future $ concat <$> ((\l -> (map Deletion l :) <$> mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (nameMap b))) + 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 [Diff a] +consumeEventGroupCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a consumeEventGroupCollectivelyWith em gp f = - maybe (future . return $ []) - (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev) + 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 [Diff a] +consumeEventGroupWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a consumeEventGroupWith b n f = - future $ concat <$> ((\l -> (map Deletion l :) <$> mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (groupMap b))) + 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 [Diff a] +consumeEventsFromSourceCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future a consumeEventsFromSourceCollectivelyWith em source f = - maybe (future . return $ []) - (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev) + 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 [Diff a] +consumeEventsFromSourceWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future a consumeEventsFromSourceWith b n f = - future $ concat <$> ((\l -> (map Deletion l :) <$> mapM f l) . Set.toList $ fromMaybe Set.empty (Map.lookup n (srcMap b))) + 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 [Diff a] +consumeFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future a consumeFullyQualifiedEventWith em group source name f = - maybe (future . return $ []) - (\ev -> future $ (Deletion ev :) <$> f ev) + 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 [Diff a] -pollNamedEventsCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (nameMap b)) +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 [Diff a] -pollNamedEventsWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (nameMap b))) +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 [Diff a] -pollEventGroupCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (groupMap b)) +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 [Diff a] -pollEventGroupWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (groupMap b))) +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 [Diff a] -pollEventsFromSourceCollectivelyWith b nm f = maybe (future . return $[]) (future.f) (Map.lookup nm (srcMap b)) +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 [Diff a] -pollEventsFromSourceWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (srcMap b))) +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 [Diff a] -pollFullyQualifiedEventWith b gp source nm f = maybe (future . return $ []) (future . f) (Map.lookup (gp,source,nm) (fullyQualifiedMap b)) +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 [Diff a] -pollAllEventsWith b f = future $ concat <$> (mapM f . Map.elems . fullyQualifiedMap $ b) +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 [Diff a] -pollAllEventsCollectivelyWith b f = future $ f . Set.fromList . Map.elems . fullyQualifiedMap $ b +pollAllEventsCollectivelyWith :: Bus a -> (Set.Set (Event a) -> IO [Diff a]) -> Future a +pollAllEventsCollectivelyWith b f = future b $ 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] @@ -409,14 +426,15 @@ 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) +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) + listM v = v >>= return . (:[]) {- example usage... diff --git a/buster.cabal b/buster.cabal --- a/buster.cabal +++ b/buster.cabal @@ -1,5 +1,5 @@ name: buster -version: 1.2 +version: 2.0 cabal-version: -any build-type: Simple license: BSD3