Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added project files

  • Loading branch information...
commit 8e16bdf210ef54f4b826db1f71f7f8748bea6851 1 parent bbbab1a
@JeffHeard authored
Showing with 9,894 additions and 0 deletions.
  1. BIN  App/Behaviours/.FileOps.hs.swp
  2. +58 −0 App/Behaviours/Exception.hs
  3. BIN  App/Behaviours/FileOps.hi
  4. +270 −0 App/Behaviours/FileOps.hs
  5. BIN  App/Behaviours/FileOps.o
  6. +60 −0 App/Behaviours/HTTP.hs
  7. +130 −0 App/Behaviours/PrintEvents.hs
  8. +105 −0 App/Behaviours/XmlRpc.hs
  9. +516 −0 App/DebugEventBus.hs
  10. BIN  App/EventBus.hi
  11. +495 −0 App/EventBus.hs
  12. BIN  App/EventBus.o
  13. BIN  App/Widgets/Environment.hi
  14. +92 −0 App/Widgets/Environment.hs
  15. BIN  App/Widgets/Environment.o
  16. +66 −0 App/Widgets/GtkMouseKeyboard.hs
  17. +45 −0 App/Widgets/Pacer.hs
  18. +12 −0 IDE.flags
  19. +15 −0 IDE.session
  20. +6 −0 Setup.lhs
  21. +60 −0 buster.cabal
  22. +373 −0 doc/buster/App-Behaviours-Exception.html
  23. +667 −0 doc/buster/App-Behaviours-FileOps.html
  24. +254 −0 doc/buster/App-Behaviours-PrintEvents.html
  25. +3,254 −0 doc/buster/App-EventBus.html
  26. +325 −0 doc/buster/App-Widgets-Environment.html
  27. +230 −0 doc/buster/App-Widgets-Pacer.html
  28. BIN  doc/buster/buster.haddock
  29. +1,160 −0 doc/buster/doc-index.html
  30. +133 −0 doc/buster/haddock-util.js
  31. +267 −0 doc/buster/haddock.css
  32. BIN  doc/buster/haskell_icon.gif
  33. +186 −0 doc/buster/index.html
  34. BIN  doc/buster/minus.gif
  35. BIN  doc/buster/plus.gif
  36. +63 −0 doc/buster/src/App-Behaviours-Exception.html
  37. +277 −0 doc/buster/src/App-Behaviours-FileOps.html
  38. +134 −0 doc/buster/src/App-Behaviours-PrintEvents.html
  39. +481 −0 doc/buster/src/App-EventBus.html
  40. +102 −0 doc/buster/src/App-Widgets-Environment.html
  41. +53 −0 doc/buster/src/App-Widgets-Pacer.html
  42. +5 −0 doc/buster/src/hscolour.css
View
BIN  App/Behaviours/.FileOps.hs.swp
Binary file not shown
View
58 App/Behaviours/Exception.hs
@@ -0,0 +1,58 @@
+-- |
+-- Module : App.Behaviours.Exception
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+-- Handle exceptions slightly more gracefully than the Haskell runtime does.
+module App.Behaviours.Exception where
+
+import Data.List (filter)
+import Control.Applicative
+import qualified Control.Exception as Ex
+import App.EventBus
+import Text.PrettyPrint
+import qualified Data.Set as Set
+import System.IO
+import Data.Time
+import System.Locale
+
+renderException (Event nm _ _ edata source tm) =
+ brackets (text (formatTime defaultTimeLocale "%T" tm)) <+> text "Exception thrown from" <+> text source <> colon <+> text nm $+$
+ (nest 4 . vcat . map text . map (safeShow (Just 80)) $ edata)
+
+-- | Bork the program when an unhandled exception makes it to this behaviour.
+-- Catches all events with the group \"Exception\" and throws them as one big exception.
+unhandledExceptionBehaviour :: Behaviour [EData a]
+unhandledExceptionBehaviour b = consumeEventGroupCollectivelyWith b "Exception" $
+ (return []) <$ (Ex.throwIO . Ex.ErrorCall . render . vcat . map renderException . Set.toList)
+
+-- | Handle exceptions by completely ignoring them. Not recommended, really, but hey, who am I to judge?
+disregardExceptionsFromSource :: String -> Behaviour [EData a]
+disregardExceptionsFromSource s b = pollEventGroupWith b "Exception" $
+ (\e -> return $ if src e == s then [Deletion e] else [])
+
+-- | 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 ename e == n then [Deletion e] else [])
+
+-- | Handle exceptions by printing them to stdout and then completely ignoring them.
+printAndDisregardExceptionsFromSource :: String -> Behaviour [EData a]
+printAndDisregardExceptionsFromSource s b = pollEventGroupWith b "Exception" $ \e ->
+ if src e == s then (return . return $ [Deletion e]) =<< (putStrLn . render . renderException $ e) else return []
+
+-- | 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 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]
+logAndDisregardExceptionsFromSource h s b = pollEventGroupWith b "Exception" $ \e ->
+ if src e == s then (return . return $ [Deletion e]) =<< (hPutStrLn h . render . renderException $ e) else return []
+
+-- | 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 ename e == n then (return . return $ [Deletion e]) =<< (hPutStrLn h . render . renderException $ e) else return []
+
View
BIN  App/Behaviours/FileOps.hi
Binary file not shown
View
270 App/Behaviours/FileOps.hs
@@ -0,0 +1,270 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- Module : App.Behaviours.FileOps
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+-- This module handles read, write, encode, and decode of files. It also cleanly handles exceptions
+-- by introducing Exception events that are handlable by the behaviours in "App.Behaviours.Exception"
+-- which exit your program gracefully, or by your own user defined exception handlers.
+--
+-- It can handle datatypes @EData a@ with Binary, Show, and Read instances as well.
+module App.Behaviours.FileOps where
+
+import App.EventBus
+import Control.Applicative
+import qualified Data.ByteString.Char8 as SB
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Binary
+import qualified Control.Exception as Ex
+
+emitException :: Event [EData a] -> String -> String -> Ex.IOException -> IO [Diff [EData a]]
+emitException e n str ex = produce "Exception" str n once (EString (show ex):eventdata e) >>= return . (:[])
+-- | @readFileBehaviour name datatype@ looks for any event with the name /name/ and reads the file
+-- into an event following the pattern:
+--
+-- * name: same as filename.
+--
+-- * group: same as name of the behaviour, @name@
+--
+-- * source: \"ReadSource\"
+--
+-- * timespan: Persistent
+--
+-- * eventdata: the file, read in and processed using @read@ to be of the datatype that
+-- corresponds to the constructor in the @datatype@ parameter.
+--
+-- NOTE: This function can only be used with @EData a@ where @a@ has a 'Read' instance. For event
+-- data without a read instance, use 'readFileBehaviourNR'
+readFileBehaviour :: Read a => String -> EData a -> Behaviour [EData a]
+readFileBehaviour n d b = consumeNamedEventsWith b n readFileCatch
+ where readFileCatch e = Ex.catch (readFile0 e) (emitException e n "readFileBehaviour")
+ readFile0 e = (rFile0 d . eventdata $ e) >>= produce n "ReadSource" (filename e) Persistent >>= return . (:[])
+ filename = (\(EString x) -> x) . head . eventdata
+
+-- | @readFileBehaviourNR name datatype@ looks for any event with the name /name/ and reads the file
+-- into an event following the pattern:
+--
+-- * name: same as filename.
+--
+-- * group: same as name of the behaviour, @name@
+--
+-- * source: \"ReadSource\"
+--
+-- * timespan: Persistent
+--
+-- * eventdata: the file, read in and processed using 'read' to be of the datatype that
+-- corresponds to the constructor in the @datatype@ parameter. The constructor itself should
+-- not be serialized.
+--
+-- NOTE: Attempting to read datatype @EOther a@ using this will cause the program to emit an
+-- event with \"Exception\" as the group and /name/ as the source.
+readFileBehaviourNR :: String -> EData a -> Behaviour [EData a]
+readFileBehaviourNR n d b = consumeNamedEventsWith b n readFileCatch
+ where readFileCatch e = Ex.catch (readFile0 e) (emitException e n "readFileBehaviour")
+ readFile0 e = (rFile d . eventdata $ e) >>= produce n "ReadSource" (filename e) Persistent >>= return . (:[])
+ filename = (\(EString x) -> x) . head . eventdata
+
+-- | @decodeFileBehaviour name datatype@ looks for any event with the name /name/ and reads the file
+-- into an event following the pattern:
+--
+-- * name: same as filename.
+--
+-- * group: same as name of the behaviour, @name@
+--
+-- * source: \"ReadSource\"
+--
+-- * timespan: Persistent
+--
+-- * eventdata: the file, read in and processed using 'Data.Binary.decodeFile' to be of the
+-- datatype that corresponds to the constructor in the @datatype@ parameter. The constructor
+-- itself need not be serialized.
+--
+-- NOTE: This function can only be used with @EData a@ where @a@ has a 'Binary' instance. For event
+-- data without a read instance, use 'decodeFileBehaviourNB'
+decodeFileBehaviour :: Binary a => String -> EData a -> Behaviour [EData a]
+decodeFileBehaviour n d b = consumeNamedEventsWith b n decodeFileCatch
+ where decodeFileCatch e = Ex.catch (decodeFile0 e) (emitException e n "decodeFileBehaviour")
+ decodeFile0 e = (dFile0 d . eventdata $ e) >>= produce n "ReadSource" (filename e) Persistent >>= return . (:[])
+ filename = (\(EString x) -> x) . head . eventdata
+
+-- | @readFileBehaviour name datatype@ looks for any event with the name /name/ and reads the file
+-- into an event following the pattern:
+--
+-- * name: same as filename.
+--
+-- * group: same as name of the behaviour, @name@
+--
+-- * source: \"ReadSource\"
+--
+-- * timespan: Persistent
+--
+-- * eventdata: the file, read in and processed using @read@ to be of the datatype that
+-- corresponds to the constructor in the @datatype@ parameter.
+--
+-- NOTE: Attempting to read datatype @EOther a@ using this will cause the program to raise an
+-- Event with \"Exception\" as the group.
+decodeFileBehaviourNB :: String -> EData a -> Behaviour [EData a]
+decodeFileBehaviourNB n d b = consumeNamedEventsWith b n decodeFileCatch
+ where decodeFileCatch e = Ex.catch (decodeFile0 e) (emitException e n "decodeFileBehaviourNB")
+ decodeFile0 e = (dFile d . eventdata $ e) >>= (produce n "ReadSource" (filename e) Persistent) >>= return . (:[])
+ filename = (\(EString x) -> x) . head . eventdata
+
+-- | @writeFileBehaviour@ looks for \"WriteFile\" named events with event data corresponding to
+-- @[EString filepath,@ /data constructor/ @contents]@ and removes them from the bus, writing
+-- the file named @filepath@. Any error is placed on the bus with an Exception event with
+-- \"WriteFile\" as the source.
+writeFileBehaviourNS :: Behaviour [EData a]
+writeFileBehaviourNS b = consumeNamedEventsWith b "WriteFile" $ \e -> Ex.catch
+ (wFile . eventdata $ e)
+ (emitException e "writeFileBehaviourNS" "WriteFile" )
+
+-- | @writeFileBehaviour@ looks for \"WriteFile\" named events with event data corresponding to
+-- @[EString filepath,@ /data constructor/ @contents]@ and removes them from the bus, writing
+-- the file named @filepath@. Any error is placed on the bus with an Exception event with
+-- \"WriteFile\" as the source.
+--
+-- NOTE: Attempting to encode 'EOther a' using this will raise an Exception.
+writeFileBehaviour :: Show a => Behaviour [EData a]
+writeFileBehaviour b = consumeNamedEventsWith b "WriteFile" $ \e -> Ex.catch
+ (wFile0 . eventdata $ e)
+ (emitException e "writeFileBehaviourNS" "WriteFile" )
+
+-- | @writeFileBehaviour@ looks for \"WriteFile\" named events with event data corresponding to
+-- @[EString filepath,@ /data constructor/ @contents]@ and removes them from the bus, writing
+-- the file named @filepath@. Any error is placed on the bus with an Exception event with
+-- \"WriteFile\" as the source.
+--
+-- NOTE: Attempting to encode 'EOther a' using this will raise an Exception.
+encodeFileBehaviourNB :: Behaviour [EData a]
+encodeFileBehaviourNB b = consumeNamedEventsWith b "WriteBinary" $ \e -> Ex.catch
+ (wBinary . eventdata $ e)
+ (emitException e "encodeFileBehaviourNS" "WriteFile")
+
+-- | @writeFileBehaviour@ looks for \"WriteFile\" named events with event data corresponding to
+-- @[EString filepath,@ /data constructor/ @contents]@ and removes them from the bus, writing
+-- the file named @filepath@. Any error is placed on the bus with an Exception event with
+-- \"WriteFile\" as the source.
+--
+-- NOTE: This can only be used with an EData a where a has a 'Data.Binary.Binary' instance.
+encodeFileBehaviour :: Binary a => Behaviour [EData a]
+encodeFileBehaviour b = consumeNamedEventsWith b "WriteBinary" $ \e -> Ex.catch
+ (wBinary0 . eventdata $ e)
+ (emitException e "encodeFileBehaviourNS" "WriteFile" )
+
+wFile [EString filepath, EString contents] = [] <$ writeFile filepath contents
+wFile [EString filepath, EStringL contents] = [] <$ (writeFile filepath . unlines $ contents)
+wFile [EString filepath, ELByteString contents] = [] <$ (LB.writeFile filepath contents)
+wFile [EString filepath, ELByteStringL contents] = [] <$ (LB.writeFile filepath . LB.unlines $ contents)
+wFile [EString filepath, EByteString contents] = [] <$ SB.writeFile filepath contents
+wFile [EString filepath, EByteStringL contents] = [] <$ (SB.writeFile filepath . SB.unlines $ contents)
+wFile [EString filepath, EInt contents] = [] <$ (writeFile filepath . show $ contents)
+wFile [EString filepath, EIntL contents] = [] <$ (writeFile filepath . show $ contents)
+wFile [EString filepath, EDouble contents] = [] <$ (writeFile filepath . show $ contents)
+wFile [EString filepath, EDoubleL contents] = [] <$ (writeFile filepath . show $ contents)
+wFile [EString filepath, EBool contents] = [] <$ (writeFile filepath . show $ contents)
+wFile [EString filepath, EBoolL contents] = [] <$ (writeFile filepath . show $ contents)
+
+wFile0 [EString filepath, EString contents] = [] <$ writeFile filepath contents
+wFile0 [EString filepath, EStringL contents] = [] <$ (writeFile filepath . unlines $ contents)
+wFile0 [EString filepath, ELByteString contents] = [] <$ (LB.writeFile filepath contents)
+wFile0 [EString filepath, ELByteStringL contents] = [] <$ (LB.writeFile filepath . LB.unlines $ contents)
+wFile0 [EString filepath, EByteString contents] = [] <$ SB.writeFile filepath contents
+wFile0 [EString filepath, EByteStringL contents] = [] <$ (SB.writeFile filepath . SB.unlines $ contents)
+wFile0 [EString filepath, EInt contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EIntL contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EDouble contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EDoubleL contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EBool contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EBoolL contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EOther contents] = [] <$ (writeFile filepath . show $ contents)
+wFile0 [EString filepath, EOtherL contents] = [] <$ (writeFile filepath . show $ contents)
+
+wBinary [EString filepath, EString contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EByteString contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EByteStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, ELByteString contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, ELByteStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EInt contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EIntL contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EDouble contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EDoubleL contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EBool contents] = [] <$ (encodeFile filepath contents)
+wBinary [EString filepath, EBoolL contents] = [] <$ (encodeFile filepath contents)
+
+
+wBinary0 [EString filepath, EString contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EByteString contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EByteStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, ELByteString contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, ELByteStringL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EInt contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EIntL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EDouble contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EDoubleL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EBool contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EBoolL contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EOther contents] = [] <$ (encodeFile filepath contents)
+wBinary0 [EString filepath, EOtherL contents] = [] <$ (encodeFile filepath contents)
+
+--rFile :: EData a -> [EData a] -> IO [EData a]
+rFile (EString _) [EString filepath] = (:[]) . EString . LB.unpack <$> LB.readFile filepath
+rFile (EStringL _) [EString filepath] = (:[]) . EStringL . read . LB.unpack <$> LB.readFile filepath
+rFile (EByteString _) [EString filepath] = (:[]) . EByteString <$> SB.readFile filepath
+rFile (EByteStringL _) [EString filepath] = (:[]) . EByteStringL . SB.lines <$> SB.readFile filepath
+rFile (ELByteString _) [EString filepath] = (:[]) . ELByteString <$> LB.readFile filepath
+rFile (ELByteStringL _) [EString filepath] = (:[]) . ELByteStringL . LB.lines <$> LB.readFile filepath
+rFile (EInt _) [EString filepath] = (:[]) . EInt . read . LB.unpack <$> LB.readFile filepath
+rFile (EIntL _) [EString filepath] = (:[]) . EIntL . read . LB.unpack <$> LB.readFile filepath
+rFile (EDouble _) [EString filepath] = (:[]) . EDouble . read . LB.unpack <$> LB.readFile filepath
+rFile (EDoubleL _) [EString filepath] = (:[]) . EDoubleL . read . LB.unpack <$> LB.readFile filepath
+rFile (EBool _) [EString filepath] = (:[]) . EBool . read . LB.unpack <$> LB.readFile filepath
+rFile (EBoolL _) [EString filepath] = (:[]) . EBoolL . read . LB.unpack <$> LB.readFile filepath
+
+--dFile :: EData a -> [EData a] -> IO [EData a]
+dFile (EString _) [EString filepath] = (:[]) .EString <$> decodeFile filepath
+dFile (EStringL _) [EString filepath] = (:[]) .EStringL <$> decodeFile filepath
+dFile (EByteString _) [EString filepath] = (:[]) .EByteString <$> decodeFile filepath
+dFile (EByteStringL _) [EString filepath] = (:[]) .EByteStringL <$> decodeFile filepath
+dFile (ELByteString _) [EString filepath] = (:[]) .ELByteString <$> decodeFile filepath
+dFile (ELByteStringL _) [EString filepath] = (:[]) .ELByteStringL <$> decodeFile filepath
+dFile (EInt _) [EString filepath] =(:[]) . EInt <$> decodeFile filepath
+dFile (EIntL _) [EString filepath] =(:[]) . EIntL <$> decodeFile filepath
+dFile (EDouble _) [EString filepath] =(:[]) . EDouble <$> decodeFile filepath
+dFile (EDoubleL _) [EString filepath] =(:[]) . EDoubleL <$> decodeFile filepath
+dFile (EBool _) [EString filepath] =(:[]) . EBool <$> decodeFile filepath
+dFile (EBoolL _) [EString filepath] =(:[]) . EBoolL <$> decodeFile filepath
+
+--rFile0 :: Read a => EData a -> [EData a] -> IO [EData a]
+rFile0 (EString _) [EString filepath] =(:[]) . EString . LB.unpack <$> LB.readFile filepath
+rFile0 (EStringL _) [EString filepath] =(:[]) . EStringL . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EByteString _) [EString filepath] =(:[]) . EByteString <$> SB.readFile filepath
+rFile0 (EByteStringL _) [EString filepath] =(:[]) . EByteStringL . SB.lines <$> SB.readFile filepath
+rFile0 (ELByteString _) [EString filepath] =(:[]) . ELByteString <$> LB.readFile filepath
+rFile0 (ELByteStringL _) [EString filepath] =(:[]) . ELByteStringL . LB.lines <$> LB.readFile filepath
+rFile0 (EInt _) [EString filepath] =(:[]) . EInt . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EIntL _) [EString filepath] =(:[]) . EIntL . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EDouble _) [EString filepath] = (:[]) . EDouble . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EDoubleL _) [EString filepath] = (:[]) . EDoubleL . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EBool _) [EString filepath] =(:[]) . EBool . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EBoolL _) [EString filepath] =(:[]) . EBoolL . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EOther _) [EString filepath] =(:[]) . EOther . read . LB.unpack <$> LB.readFile filepath
+rFile0 (EOtherL _) [EString filepath] =(:[]) . EOtherL . read . LB.unpack <$> LB.readFile filepath
+
+--dFile0 :: Binary a => EData a -> [EData a] -> IO [EData a]
+dFile0 (EString _) [EString filepath] = (:[]) . EString <$> decodeFile filepath
+dFile0 (EStringL _) [EString filepath] =(:[]) . EStringL <$> decodeFile filepath
+dFile0 (EByteString _) [EString filepath] =(:[]) . EByteString <$> decodeFile filepath
+dFile0 (EByteStringL _) [EString filepath] = (:[]) . EByteStringL <$> decodeFile filepath
+dFile0 (ELByteString _) [EString filepath] = (:[]) . ELByteString <$> decodeFile filepath
+dFile0 (ELByteStringL _) [EString filepath] = (:[]) . ELByteStringL <$> decodeFile filepath
+dFile0 (EInt _) [EString filepath] = (:[]) . EInt <$> decodeFile filepath
+dFile0 (EIntL _) [EString filepath] = (:[]) . EIntL <$> decodeFile filepath
+dFile0 (EDouble _) [EString filepath] = (:[]) . EDouble <$> decodeFile filepath
+dFile0 (EDoubleL _) [EString filepath] = (:[]) . EDoubleL <$> decodeFile filepath
+dFile0 (EBool _) [EString filepath] = (:[]) . EBool <$> decodeFile filepath
+dFile0 (EBoolL _) [EString filepath] = (:[]) . EBoolL <$> decodeFile filepath
+dFile0 (EOther _) [EString filepath] = (:[]) . EOther <$> decodeFile filepath
+dFile0 (EOtherL _) [EString filepath] = (:[]) . EOtherL <$> decodeFile filepath
View
BIN  App/Behaviours/FileOps.o
Binary file not shown
View
60 App/Behaviours/HTTP.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Module : App.Behaviours.HTTP
+-- Copyright : 2009 Renaissance Computing Institute
+-- License : BSD3
+--
+-- Maintainer : Jeff Heard <jeff@renci.org>
+-- Stability : Experimental
+-- Portability :
+--
+-- | Behaviours for HTTP requests. Looks for Events named
+-- HTTP\//MethodName/ with event data of [EString uri, EByteString senddata, EStringL headers] and consumes them. Produces
+-- Events named HTTPResponse with source httpBehaviour\//MethodName/ and the contents of the response as the event data in a ByteString.
+-- They also produce Exceptions with the same source and name ConnectionError if there is no network connection or HTTP Service
+-- or HTTPErrorResponseCode if the Server sent back an error code or ParseFailure if the URI didn't parse.
+--
+-----------------------------------------------------------------------------
+
+module App.Behaviours.HTTP (
+
+
+) where
+
+import Control.Applicative ((<$>))
+import App.EventBus
+import Network.HTTP.HandleStream
+import Network.HTTP
+import Network.URI
+import Network.Stream
+import qualified Data.ByteString as BS
+
+maybeHead (x:xs) = Just x
+maybeHead [] = Nothing
+
+httpBehaviour :: RequestMethod -> Behaviour [EData a]
+httpBehaviour method b = consumeNamedEventsWith b ("HTTP/" ++ show method) $ \evt ->
+ let EString uriS = head . eventdata $ evt
+ postdata = maybe BS.empty (\(EByteString getdata) -> getdata) . maybeHead . tail . eventdata $ evt
+ postheaders = headers . tail . tail . eventdata $ evt
+
+ headers (EString nm:EString val:hs) = Header (HdrCustom nm) val : headers hs
+ headers [] = []
+
+ httpGet uri = (Network.HTTP.HandleStream.simpleHTTP $ Request uri method postheaders postdata) >>=
+ either (\_ -> produce "Exception" ("httpBehaviour" ++ show method) "ConnectionError" once [])
+ (\(Response code reason rspheaders contents) ->
+ case code of
+ (1,_,_) -> produce "HTTPResponse" ("httpBehaviour/" ++ show method) (show uri) Persistent [EByteString contents]
+ (2,_,_) -> produce "HTTPResponse" ("httpBehaviour/" ++ show method) (show uri) Persistent [EByteString contents]
+ _ -> produce "Exception" ("httpBehaviour/" ++ show method) "HTTPErrorResponseCode" once [EString (show code), EStringL . map show $ rspheaders, EByteString contents])
+ in case parseURI uriS of
+ Just uri -> listM $ httpGet uri
+ Nothing -> listM $ produce "Exception" ("httpBehaviour" ++ show method) "ParseFailure" once [EString uriS]
+
+
+
+
+
+
View
130 App/Behaviours/PrintEvents.hs
@@ -0,0 +1,130 @@
+-- |
+-- Module : App.Behaviours.PrintEvents
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+-- Printouts of events for debugging purposes
+module App.Behaviours.PrintEvents where
+
+import qualified Data.ByteString as B
+import Text.PrettyPrint
+import Data.Time
+import System.Locale
+import App.EventBus
+import System.IO
+
+printEventsBehaviour :: Behaviour [EData a]
+printEventsBehaviour b = pollAllEventsWith b $ (\(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 [])
+
+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 []
+
+checkpoint :: String -> Behaviour a
+checkpoint message bus = do
+ putStrLn message
+ passthrough bus
+
+logEventsBehaviour :: Handle -> Behaviour [EData a]
+logEventsBehaviour handle b = pollAllEventsWith b $ (\(Event n g lifetime edata source t) -> do
+ hPutStrLn handle.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 [])
+
+logEventGroupBehaviour :: Handle -> String -> Behaviour [EData a]
+logEventGroupBehaviour handle grp b = pollEventGroupWith b grp $ (\(Event n g lifetime edata source t) -> do
+ hPutStrLn handle.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 [])
+
+logEventNameBehaviour :: Handle -> String -> Behaviour [EData a]
+logEventNameBehaviour handle grp b = pollNamedEventsWith b grp $ (\(Event n g lifetime edata source t) -> do
+ hPutStrLn handle . 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 [])
+
+logEventSourceBehaviour :: Handle -> String -> Behaviour [EData a]
+logEventSourceBehaviour handle grp b = pollEventsFromSourceWith b grp $ (\(Event n g lifetime edata source t) -> do
+ hPutStrLn handle.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 [])
+
+
+logQNameBehaviour handle bus = pollAllEventsWith bus $ \(Event n g _ _ s _) -> do
+ hPutStrLn handle . show $ (g,s,n)
+ return []
+
+logCheckpoint handle message bus = hPutStrLn handle message >> passthrough bus
View
105 App/Behaviours/XmlRpc.hs
@@ -0,0 +1,105 @@
+
+-- Module : App.Behaviours.XmlRpc
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+module App.Behaviours.XmlRpc where
+
+import Control.Monad.Error
+import Network.XmlRpc.Client
+import Network.XmlRpc.Internals
+import Control.Applicative
+import App.EventBus
+import qualified Codec.Binary.Base64
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Lazy as LB
+import Data.Maybe
+
+edata2value :: XmlRpcType a => EData a -> Value
+edata2value (EString x) = ValueString x
+edata2value (EStringL x) = ValueArray $ ValueString <$> x
+edata2value (EByteString x) = ValueBase64 . Codec.Binary.Base64.encode . SB.unpack $ x
+edata2value (EByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . SB.unpack <$> x
+edata2value (ELByteString x) = ValueBase64 . Codec.Binary.Base64.encode . LB.unpack $ x
+edata2value (ELByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . LB.unpack <$> x
+edata2value (EChar x) = ValueString [x]
+edata2value (EDouble x) = ValueDouble x
+edata2value (EDoubleL x) = ValueArray $ ValueDouble <$> x
+edata2value (EInt x) = ValueInt x
+edata2value (EIntL x) = ValueArray $ ValueInt <$> x
+edata2value (EBool x) = ValueBool x
+edata2value (EBoolL x) = ValueArray $ ValueBool <$> x
+edata2value (EOther x) = toValue x
+edata2value (EOtherL x) = ValueArray $ toValue <$> x
+edata2value (EAssoc (k,v)) = ValueStruct [(k, edata2value v)]
+edata2value (EAssocL xs) = ValueStruct $ (\(k,v) -> (k, edata2value v)) <$> xs
+
+edata2valueNX :: EData a -> Value
+edata2valueNX (EString x) = ValueString x
+edata2valueNX (EStringL x) = ValueArray $ ValueString <$> x
+edata2valueNX (EByteString x) = ValueBase64 . Codec.Binary.Base64.encode . SB.unpack $ x
+edata2valueNX (EByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . SB.unpack <$> x
+edata2valueNX (ELByteString x) = ValueBase64 . Codec.Binary.Base64.encode . LB.unpack $ x
+edata2valueNX (ELByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . LB.unpack <$> x
+edata2valueNX (EChar x) = ValueString [x]
+edata2valueNX (EDouble x) = ValueDouble x
+edata2valueNX (EDoubleL x) = ValueArray $ ValueDouble <$> x
+edata2valueNX (EInt x) = ValueInt x
+edata2valueNX (EIntL x) = ValueArray $ ValueInt <$> x
+edata2valueNX (EBool x) = ValueBool x
+edata2valueNX (EBoolL x) = ValueArray $ ValueBool <$> x
+edata2valueNX (EAssoc (k,v)) = ValueStruct [(k, edata2valueNX v)]
+edata2valueNX (EAssocL xs) = ValueStruct $ (\(k,v) -> (k, edata2valueNX v)) <$> xs
+
+value2edata :: Value -> EData a
+value2edata (ValueInt x) = EInt x
+value2edata (ValueBool x) = EBool x
+value2edata (ValueString x) = EString x
+value2edata (ValueDateTime x) = EString (show x)
+value2edata (ValueBase64 x) = EByteString . SB.pack . fromJust . Codec.Binary.Base64.decode $ x
+value2edata (ValueStruct xs) = EAssocL $ (\(x,y) -> (x, value2edata y)) <$> xs
+value2edata (ValueArray xs) = EAssocL . zip (show<$>[0..]) $ value2edata <$> xs
+
+
+
+xmlrpcMethodBehaviour :: XmlRpcType a => String -> String -> Behaviour [EData a]
+xmlrpcMethodBehaviour service method b = consumeEventGroupWith b (service ++ "/" ++ method) $ \evt -> do
+ let parms = map edata2value . eventdata $ evt
+ exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg]
+ responseEvent val = produce "XmlRpcResponse" service method once [value2edata val]
+ r <- runErrorT $ call service method parms
+ case r of
+ Left err -> listM $ exceptionEvent err
+ Right res -> listM $ responseEvent res
+
+xmlrpcServiceBehaviour :: XmlRpcType a => String -> Behaviour [EData a]
+xmlrpcServiceBehaviour service b = consumeEventGroupWith b service $ \evt -> do
+ let parms = map edata2value . tail . eventdata $ evt
+ EString method = head . eventdata $ evt
+ exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg]
+ responseEvent val = produce "XmlRpcResponse" service method once [value2edata val]
+ r <- runErrorT $ call service method parms
+ case r of
+ Left err -> listM $ exceptionEvent err
+ Right res -> listM $ responseEvent res
+
+xmlrpcMethodBehaviourNX :: String -> String -> Behaviour [EData a]
+xmlrpcMethodBehaviourNX service method b = consumeEventGroupWith b (service ++ "/" ++ method) $ \evt -> do
+ let parms = map edata2valueNX . eventdata $ evt
+ exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg]
+ responseEvent val = produce "XmlRpcResponse" service method once [value2edata val]
+ r <- runErrorT $ call service method parms
+ case r of
+ Left err -> listM $ exceptionEvent err
+ Right res -> listM $ responseEvent res
+
+xmlrpcServiceBehaviourNX :: String -> Behaviour [EData a]
+xmlrpcServiceBehaviourNX service b = consumeEventGroupWith b service $ \evt -> do
+ let parms = map edata2valueNX . tail . eventdata $ evt
+ EString method = head . eventdata $ evt
+ exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg]
+ responseEvent val = produce "XmlRpcResponse" service method once [value2edata val]
+ r <- runErrorT $ call service method parms
+ case r of
+ Left err -> listM $ exceptionEvent err
+ Right res -> listM $ responseEvent res
View
516 App/DebugEventBus.hs
@@ -0,0 +1,516 @@
+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -O0 #-}
+-- |
+-- Module : App.DebugEventBus
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+-- 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
+ -}
View
BIN  App/EventBus.hi
Binary file not shown
View
495 App/EventBus.hs
@@ -0,0 +1,495 @@
+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}
+-- |
+-- Module : App.EventBus
+-- Copyright : (c) Renaissance Computing Institute 2009
+-- License : BSD3
+--
+-- Not exactly the FRP model, but rather a model of a large application with
+-- heterogenous data and many inputs and outputs. An application is in its
+-- essence a collection of widgets and behaviours and events with a bus.
+-- The bus holds events and manages the event timeline. Behaviours and
+-- widgets are continuous. Widgets applied to the bus make insertions and
+-- never deletions. Behaviours applied to the bus make insertions and deletions.
+--
+-- Behaviours are composable using combinators that set one Behaviour as either
+-- behind, in front, or beside another behaviour on the bus. The in front and
+-- behind combinators establish that the behaviour "behind" the others
+-- sees the results of the other behaviours' application to the bus. The beside
+-- combinator says that the combinators see the same bus.
+--
+module App.EventBus where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad
+import Data.Maybe
+import Data.List (foldl', foldl1')
+import Data.Monoid
+import qualified Data.Set as Set
+import Data.Time.Clock
+import qualified Data.Map as Map
+import qualified Data.ByteString as B
+import 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
+a />/ _ = a
+
+a /</ EQ = a
+_ /</ b = b
+
+g %=> f = f `on` g
+
+on f g a b = f (g a) (g b)
+
+-- IO version of the <* Applicative operator
+a =<<^ b = \m -> b >> a m
+
+-- | Defines the amount of time that an event exists.
+data TimeSpan =
+ Persistent -- ^ The event exists forever
+ | Time DiffTime -- ^ The event exists for a specified amount of real time
+ | Iterations Int -- ^ The event exists for a certain number of samples of time from its inception.
+ deriving (Eq,Ord,Show)
+
+seconds :: Integer -> TimeSpan
+seconds = Time . secondsToDiffTime
+
+minutes :: Integer -> TimeSpan
+minutes = Time . secondsToDiffTime . (60*)
+
+hours :: Integer -> TimeSpan
+hours = Time . secondsToDiffTime . (3600*)
+
+days :: Integer -> TimeSpan
+days = Time . secondsToDiffTime . (86400*)
+
+once :: TimeSpan
+once = Iterations 1
+
+-- | Defines time in terms of the differences from time t0 to the next instant. This is the type
+-- returned by Behaviours to describe time directly after the Behaviour.
+data Diff a =
+ Insertion (Event a) -- ^ Time t1 contains all events at time t0 plus this event.
+ | Deletion (Event a) -- ^ Time t1 contains all events at time t0 minus this event.
+
+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.
+
+instrument bname behave = behave
+
+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) (Bus n1 s1 g1 f1) = Bus (Map.union n0 n1) (Map.union s0 s1) (Map.union g0 g1) (Map.union f0 f1)
+
+-- | The empty bus
+emptyBus :: Bus a
+emptyBus = Bus Map.empty Map.empty Map.empty Map.empty
+
+-- | Add an event to time within the bus
+addEvent :: Event a -> Bus a -> Bus a
+addEvent edata b = b{ nameMap = Map.insertWith (Set.union) (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
+ 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) = 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
+ 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''
+
+-- | 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)
+
+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
+ -}
View
BIN  App/EventBus.o
Binary file not shown
View
BIN  App/Widgets/Environment.hi
Binary file not shown
View
92 App/Widgets/Environment.hs
@@ -0,0 +1,92 @@
+module App.Widgets.Environment where
+
+import Control.Monad
+import Data.Either
+import Data.List (elem)
+import App.EventBus
+import System.Environment
+import Data.Maybe
+import Text.Parsec hiding (many)
+import Control.Applicative
+
+isNotBlankLine = (/=0) . length . filter (/=' ') . filter (/='\t')
+isNotCommentLine = not . (=='#') . head
+hasValue = elem '='
+parseConfigLine = liftA2 (,) (many1 alphaNum) (spaces *> char '=' *> many anyChar)
+
+-- | Place the command line arguments on the bus as an Event following the pattern
+--
+-- * name : argv
+--
+-- * group : Environment
+--
+-- * source : CommandLineArgsWidget
+--
+-- * timespan : Persistent
+--
+-- * data : EStringL of the command line args
+commandLineArgsWidget :: Widget [EData a]
+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
+--
+-- * data : EString config item value
+--
+-- Config files follow a fairly simple grammar:
+--
+-- 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)")
+ . filter isNotBlankLine
+ . filter isNotCommentLine
+ . filter hasValue
+ . lines
+ <$> readFile f
+
+-- | Read in all environment variables and place them on the bus individually as events following the pattern:
+--
+-- * name : variable name
+--
+-- * group : Environment
+--
+-- * source : EnvironmentWidget
+--
+-- * timespan : Persistent
+--
+-- * data : EString variable value
+--
+environmentWidget :: Widget [EData a]
+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:
+--
+-- * name : ProgramName
+--
+-- * group : Environment
+--
+-- * source : ProgramNameWidget
+--
+-- * timespan : Persistent
+--
+-- * data : EString progran name
+progNameWidget :: Widget [EData a]
+progNameWidget b = getProgName >>=
+ \v -> produce' "Environment" "ProgramNameWidget" "ProgramName" Persistent [EString v] b
View
BIN  App/Widgets/Environment.o
Binary file not shown
View
66 App/Widgets/GtkMouseKeyboard.hs
@@ -0,0 +1,66 @@
+-- | Gtk mouse keyboard widget.
+--
+-- For a mouse button press or release, add events named SingleClick or ClickRelease respectively to the bus.
+-- For this widget, all events have source \"KeyboardMouseWidget\", and group \"Mouse\"
+-- Additionally, the data attached to the event follows the form [EString SingleClick|ClickRelease, EDouble x, EDouble y, EStringL [Gtk modifier names]]
+--
+-- For a keyboard press or release, add events named KeyDown or KeyUp respectively to the bus.
+-- All keyboard events have group ''Keyboard'' and source ''WidgetName.KeyboardMouseWidget''
+-- Additionally, the data attached to a keyboard event follows the form [EString keyName | EChar keyChar, EStringL [Gtk modifier names]]
+--
+-- For a tablet proximity, add events named \"Proximity\" with source WidgetName.KeyboardMouseWidget, group \"Mouse\" and with attached data
+-- [EBool True] for the tablet is in proximity and [EBool False] for the tablet is out of proximity.
+--
+-- For mouse motion, add events named \"Position\" with group \"Mouse\" and attached data [EDouble x, EDouble y, EStringL modifiers]
+--
+module App.Widgets.GtkMouseKeyboard where
+
+import Control.Applicative
+import Control.Concurrent
+import Data.Maybe
+import qualified Graphics.UI.Gtk as Gtk
+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk
+import App.EventBus
+
+-- Gtk's button click event system is annoying, so we're ignoring it and only bothering with the single clicks.
+-- when we receive a click, fire off a thread (once) that waits for 100ms to see how many clicks we get total in that time. Then fire off that number.
+buttonHandler _ _ (Gtk.Button _ Gtk.DoubleClick _ _ _ _ _ _ _) = return True
+buttonHandler _ _ (Gtk.Button _ Gtk.TripleClick _ _ _ _ _ _ _) = return True
+buttonHandler wname b (Gtk.Button sent click time x y modifiers button _ _) = do
+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show click) once [EString . show $ button, EDouble x, EDouble y, EStringL . map show $ modifiers] b
+ return True
+
+scrollWheelHandler wname b (Gtk.Scroll _ _ x y direction _ _) = do
+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show direction) once [EDouble x, EDouble y] b
+ return True
+
+keyboardHandler wname b (Gtk.Key released sent time modifiers withCapsLock withNumLock withScrollLock keyVal keyName keyChar) = do
+ produce' "Keyboard" (wname ++ "KeyboardMouseWidget") (if released then "KeyUp" else "KeyDown") once
+ [ fromMaybe (EString . show $ keyName) (EChar <$> keyChar)
+ , EStringL . map show $ modifiers ] b
+ return False
+
+motionHandler wname w b evt = do
+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Position" once [EDouble . Gtk.eventX $ evt, EDouble . Gtk.eventY $ evt, EStringL . map show . Gtk.eventModifier $ evt] b
+ dwin <- Gtk.widgetGetDrawWindow w
+ Gtk.drawWindowGetPointer dwin
+ return False
+
+proximityHandler wname b evt = do
+ produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Proximity" once [EBool . Gtk.eventInContact $ evt] b
+ return False
+
+-- | Bind a keyboard mouse widget to the given Gtk widget. Se module documentation for description of events.
+bindMouseKeyboardWidget :: Gtk.Widget -> Widget [EData a]
+bindMouseKeyboardWidget w b = do
+ ref <- newEmptyMVar
+ wname <- Gtk.widgetGetName w
+ Gtk.onButtonPress w (buttonHandler wname b)
+ Gtk.onButtonRelease w (buttonHandler wname b)
+ Gtk.onScroll w (scrollWheelHandler wname b)
+ Gtk.onKeyPress w (keyboardHandler wname b)
+ Gtk.onKeyRelease w (keyboardHandler wname b)
+ Gtk.onMotionNotify w True (motionHandler wname w b)
+ Gtk.onProximityIn w (proximityHandler wname b)
+ Gtk.onProximityOut w (proximityHandler wname b)
+ return ()
View
45 App/Widgets/Pacer.hs
@@ -0,0 +1,45 @@
+-----------------------------------------------------------------------------
+--
+-- Module : App.Widgets.Pacer
+-- Copyright : 2009 Renaissance Computing Institute
+-- License : BSD3
+--
+-- Maintainer : Jeff Heard <jeff@renci.org>
+-- Stability : Experimental
+-- Portability :
+--
+-- | Widgets for sending a heartbeat out onto the bus to be caught by other behaviours.
+--
+-----------------------------------------------------------------------------
+module App.Widgets.Pacer where
+
+import App.EventBus
+import Control.Concurrent
+
+-- | @paceMicrosecondsWidget timeout timername bus@
+-- |
+-- | 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
+ return ()
+
+-- | @paceMillisecondsWidget timeout timername bus@
+-- |
+-- | Send a heartbeat event out every /timeout/ milliseconds to the bus
+paceMillisecondsWidget :: Int -> String -> Widget [a]
+paceMillisecondsWidget timeout = paceMicrosecondsWidget (timeout*1000)
+
+-- | @paceSecondsWidget timeout timername bus@
+-- |
+-- | Send a heartbeat event out every /timeout/ seconds to the bus
+paceSecondsWidget :: Double -> String -> Widget [a]
+paceSecondsWidget timeout = paceMillisecondsWidget (round $ timeout*1000*1000)
+
+
+
+
View
12 IDE.flags
@@ -0,0 +1,12 @@
+Config flags: "--user"
+Build flags: "--user"
+Haddock flags: ""
+Executable flags:
+ ""
+Install flags: "--user"
+Register flags:
+ ""
+Unregister flags:
+ ""
+Source Distribution flags:
+ ""
View
15 IDE.session
@@ -0,0 +1,15 @@
+Time of storage:
+ "Tue May 26 17:29:59 EDT 2009"
+Layout: VerticalP (TerminalP (Just TopP) 9) (HorizontalP (TerminalP (Just BottomP) 0) (TerminalP (Just BottomP) 1) 739) 1216
+Population: [(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/Annotations.hs" 410)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/Carte.hs" 13311)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/CoordTrans.hs" 1609)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/buster/App/EventBus.hs" 0)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/EventNames.hs" 7779)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/buster-gtk/App/Widgets/GtkMouseKeyboard.hs" 0)),[LeftP]),(Just (InfoSt (InfoState (Descr {descrName' = "consumeFullyQualifiedEvent", typeInfo' = "consumeFullyQualifiedEvent :: forall a.\n String -> String -> String -> Behaviour a\n", descrModu' = PM {pack = PackageIdentifier {pkgName = PackageName "buster", pkgVersion = Version {versionBranch = [2,0], versionTags = []}}, modu = ModuleName ["App","EventBus"]}, mbLocation' = Nothing, mbComment' = Nothing, details' = VariableDescr}))),[RightP,BottomP]),(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 347 (System,False) (Just (ModuleName ["App","EventBus"]),Just "consumeFullyQualifiedEvent") (ExpanderState {localExp = ([],[]), localExpNoBlack = ([],[]), packageExp = ([[1,0,0],[1,0],[1]],[]), packageExpNoBlack = ([[1,0],[1]],[]), systemExp = ([[10,0,2],[10,0],[10]],[]), systemExpNoBlack = ([[0]],[])}))),[RightP,TopP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/Navigation.hs" 1038)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/Hieroglyph/Graphics/Rendering/Hieroglyph/OpenGL.hs" 30120)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/TheBigBoardMain.hs" 1631)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/UIBehaviour.hs" 10978)),[LeftP]),(Just (BufferSt (BufferState "/home/jeff/Source/TheBigBoard3/Packages/bigboard/UIGeometry.hs" 596)),[LeftP])]
+Window size: (1916,1177)
+Active package:
+ Just "/home/jeff/Source/TheBigBoard3/Packages/buster/buster.cabal"
+Active pane: Just "UIBehaviour.hs"
+Toolbar visible:
+ True
+FindbarState: (True,FindState {entryStr = "print", entryHist = ["print","validate","compiledgeometry","compiledGeometry","mapAccum","Point 0 3","image { filename =","image { filename=","image{ filename=","image{ filename =","image{ il","\"icons/"], replaceStr = "labeloffse", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = True, backward = True, lineNr = 1})
+Recently opened files:
+ ["/home/jeff/Source/TheBigBoard3/Packages/buster/App/Behaviours/PrintEvents.hs","/home/jeff/Source/TheBigBoard3/Packages/bigboard/thebigboard.ini","/home/jeff/Source/TheBigBoard3/Packages/bigboard/Wkt.hs","/home/jeff/Source/TheBigBoard3/Packages/bigboard/WktHieroglyph.hs","/home/jeff/Source/TheBigBoard3/Packages/buster/App/Widgets/Pacer.hs","/home/jeff/Source/TheBigBoard3/Packages/Hieroglyph/Graphics/Rendering/Hieroglyph/Primitives.hs","/home/jeff/Source/TheBigBoard3/Packages/buster/App/Widgets/Environment.hs","/home/jeff/Source/TheBigBoard3/Packages/buster/App/Behaviours/FileOps.hs","/home/jeff/Source/TheBigBoard3/Packages/bigboard/tryagain/CoordTrans.hs","/home/jeff/Source/TheBigBoard3/Packages/Hieroglyph/Graphics/Rendering/Hieroglyph/Interactive.hs","/home/jeff/Source/TheBigBoard3/Packages/Hieroglyph/Graphics/Rendering/Hieroglyph/Cairo.hs"]
+Recently opened packages:
+ ["/home/jeff/Source/TheBigBoard3/Packages/bigboard/bigboard.cabal","/home/jeff/Source/TheBigBoard3/Packages/Hieroglyph/Hieroglyph.cabal"]
View
6 Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
View
60 buster.cabal
@@ -0,0 +1,60 @@
+name: buster
+version: 2.52
+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.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
+homepage: http://vis.renci.org/jeff/buster
+package-url:
+bug-reports:
+synopsis: Almost but not quite entirely unlike FRP
+description: Buster is best described by the following blog post: http:\/\/vis.renci.org\/jeff\/2009\/03\/31\/almost-but-not-quite-entirely-like-frp\/
+ .
+ It is an engine for orchestrating large, complex, and multifaceted applications by couching them in terms of time, events, a bus,
+ behaviours, and widgets. Time is continuous and infininte. Events are discrete and exist for a particular time. The bus is a
+ discrete sample of time made available to behaviours. Behaviours are continuous and exist for all time, but sample time via
+ the bus. They filter Events to determine what is on the bus at future times. Widgets are input-only objects that sample the
+ outside world and assign events to discrete portions of time.
+ .
+ Buster is designed to be flexible, with a flexible event model and the ability to add custom data to events, and designed to be
+ high performance. It is simple to integrate with Gtk while at the same time able to handle other kinds of resources, like files
+ and sockets.
+category: FRP
+author: Jeff Heard
+tested-with:
+data-files:
+data-dir: ""
+extra-source-files:
+extra-tmp-files:
+exposed-modules: App.EventBus App.DebugEventBus App.Behaviours.PrintEvents
+ App.Behaviours.Exception App.Behaviours.FileOps App.Widgets.Pacer
+ App.Widgets.Environment
+exposed: True
+buildable: True
+build-tools:
+cpp-options:
+cc-options:
+ld-options:
+pkgconfig-depends:
+frameworks:
+c-sources:
+extensions:
+extra-libraries:
+extra-lib-dirs:
+includes:
+install-includes:
+include-dirs:
+hs-source-dirs: .
+other-modules:
+ghc-prof-options:
+ghc-shared-options:
+ghc-options: -O2 -fvia-C -optc-O3
+hugs-options:
+nhc98-options:
+jhc-options:
View
373 doc/buster/App-Behaviours-Exception.html
@@ -0,0 +1,373 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<!--Rendered using the Haskell Html Library v0.2-->
+<HTML
+><HEAD
+><META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=UTF-8"
+><TITLE
+>App.Behaviours.Exception</TITLE
+><LINK HREF="haddock.css" REL="stylesheet" TYPE="text/css"
+><SCRIPT SRC="haddock-util.js" TYPE="text/javascript"
+></SCRIPT
+></HEAD
+><BODY
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD CLASS="topbar"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD
+><IMG SRC="haskell_icon.gif" WIDTH="16" HEIGHT="16" ALT=" "
+></TD
+><TD CLASS="title"
+>buster-2.2: Almost but not quite entirely unlike FRP</TD
+><TD CLASS="topbut"
+><A HREF="index.html"
+>Contents</A
+></TD
+><TD CLASS="topbut"
+><A HREF="doc-index.html"
+>Index</A
+></TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="modulebar"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD
+><FONT SIZE="6"
+>App.Behaviours.Exception</FONT
+></TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="section1"
+>Description</TD
+></TR
+><TR
+><TD CLASS="doc"
+>Handle exceptions slightly more gracefully than the Haskell runtime does.
+</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="section1"
+>Synopsis</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="body"
+><TABLE CLASS="vanilla" CELLSPACING="0" CELLPADDING="0"
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AunhandledExceptionBehaviour"
+>unhandledExceptionBehaviour</A
+> :: <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AdisregardExceptionsFromSource"
+>disregardExceptionsFromSource</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AdisregardExceptionsNamed"
+>disregardExceptionsNamed</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AprintAndDisregardExceptionsFromSource"
+>printAndDisregardExceptionsFromSource</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AprintAndDisregardExceptionsNamed"
+>printAndDisregardExceptionsNamed</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AlogAndDisregardExceptionsFromSource"
+>logAndDisregardExceptionsFromSource</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/System-IO.html#t%3AHandle"
+>Handle</A
+> -&gt; <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="s8"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A HREF="#v%3AlogAndDisregardExceptionsNamed"
+>logAndDisregardExceptionsNamed</A
+> :: <A HREF="/usr/local/share/doc/ghc/libraries/base/System-IO.html#t%3AHandle"
+>Handle</A
+> -&gt; <A HREF="/usr/local/share/doc/ghc/libraries/base/Data-Char.html#t%3AString"
+>String</A
+> -&gt; <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+></TABLE
+></TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="section1"
+>Documentation</TD
+></TR
+><TR
+><TD CLASS="s15"
+></TD
+></TR
+><TR
+><TD CLASS="decl"
+><A NAME="v%3AunhandledExceptionBehaviour"
+></A
+><B
+>unhandledExceptionBehaviour</B
+> :: <A HREF="App-EventBus.html#t%3ABehaviour"
+>Behaviour</A
+> [<A HREF="App-EventBus.html#t%3AEData"
+>EData</A
+> a]</TD
+></TR
+><TR
+><TD CLASS="doc"
+>Bork the program when an unhandled exception makes it to this behaviour.