diff --git a/App/DebugEventBus.hs b/App/DebugEventBus.hs new file mode 100644 --- /dev/null +++ b/App/DebugEventBus.hs @@ -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 / 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 + -} diff --git a/App/EventBus.hs b/App/EventBus.hs --- a/App/EventBus.hs +++ b/App/EventBus.hs @@ -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 diff --git a/App/Widgets/Pacer.hs b/App/Widgets/Pacer.hs --- a/App/Widgets/Pacer.hs +++ b/App/Widgets/Pacer.hs @@ -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@ diff --git a/buster.cabal b/buster.cabal --- a/buster.cabal +++ b/buster.cabal @@ -1,12 +1,12 @@ name: buster -version: 2.21 +version: 2.51 cabal-version: -any build-type: Simple license: BSD3 license-file: "" copyright: 2009 Renaissance Computing Institute maintainer: Jeff Heard -build-depends: base -any, binary -any, bytestring -any, +build-depends: base <=4.1.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: