Support directed signals

Previously we always ignored signals' destination. They're now shown
similarly to normal signals, but with only one arrow, pointing to the
destination.

7 files changed, 91 insertions, 39 deletions

diff --git a/Bustle/Diagram.hs b/Bustle/Diagram.hs
index bba4172..e440b16 100644
--- a/Bustle/Diagram.hs
+++ b/Bustle/Diagram.hs
@@ -67,6 +67,7 @@ import Graphics.UI.Gtk.Pango.Font
 
 import qualified Bustle.Markup as Markup
 import Bustle.Markup (Markup)
+import Bustle.Util
 
 type Point = (Double, Double)
 type Rect = (Double, Double, Double, Double)
@@ -114,6 +115,7 @@ data Shape = Header { strs :: [String]
                    , shapex1, shapex2, shapey :: Double
                    }
            | SignalArrow { shapex1, epicentre, shapex2, shapey :: Double }
+           | DirectedSignalArrow { epicentre, shapex, shapey :: Double }
            | Arc { topx, topy, bottomx, bottomy :: Double
                  , arcside :: Side
                  , caption :: String
@@ -228,6 +230,10 @@ bounds s = case s of
     let (x1, x2) = xMinMax s
         (y1, y2) = (subtract 5) &&& (+5) $ shapey s
     in (x1, y1, x2, y2)
+  DirectedSignalArrow {} ->
+    let (x1, x2) = minMax (epicentre s, shapex s)
+        (y1, y2) = (subtract 5) &&& (+5) $ shapey s
+    in (x1, y1, x2, y2)
   Arc { topx=x1, bottomx=x2, topy=y1, bottomy=y2 } ->
     let ((cx, _), (dx, _)) = arcControlPoints s
        -- FIXME: magic 5 makes the bounding box include the text
@@ -332,8 +338,13 @@ draw s = draw' s
           Arc {} -> let ((cx, cy), (dx, dy)) = arcControlPoints s
                     in drawArc cx cy dx dy <$>
                           topx <*> topy <*> bottomx <*> bottomy <*> caption
-          SignalArrow {} -> drawSignalArrow <$> epicentre <*> shapex1 <*>
-                              shapex2 <*> shapey
+          SignalArrow {} -> drawSignalArrow <$> epicentre
+                                            <*> Just . shapex1
+                                            <*> Just . shapex2
+                                            <*> shapey
+          DirectedSignalArrow { } -> drawDirectedSignalArrow <$> epicentre
+                                                             <*> shapex
+                                                             <*> shapey
           Arrow {} -> drawArrow <$> shapecolour <*> arrowhead <*> shapex1 <*>
                         shapex2 <*> shapey
           Header {} -> drawHeader <$> strs <*> shapex <*> shapey
@@ -374,21 +385,35 @@ drawArrow c a from to y = saved $ do
     halfArrowHead a (from < to)
     stroke
 
-drawSignalArrow :: Double -> Double -> Double -> Double -> Render ()
-drawSignalArrow e left right y = do
+drawDirectedSignalArrow :: Double -- ^ the signal emission source
+                        -> Double -- ^ signal target coordinate
+                        -> Double -- ^ vertical coordinate
+                        -> Render ()
+drawDirectedSignalArrow e x y
+    | x < e     = drawSignalArrow e (Just x) Nothing y
+    | otherwise = drawSignalArrow e Nothing (Just x) y
+
+drawSignalArrow :: Double -- ^ the signal emission source
+                -> Maybe Double -- ^ left-pointing arrow coordinate
+                -> Maybe Double -- ^ right-pointing arrow coordinate
+                -> Double -- ^ vertical coordinate
+                -> Render ()
+drawSignalArrow e mleft mright y = do
     newPath
     arc e y 5 0 (2 * pi)
     stroke
 
-    moveTo left y
-    arrowHead False
-    lineTo (e - 5) y
-    stroke
-
-    moveTo (e + 5) y
-    lineTo right y
-    arrowHead True
-    stroke
+    maybeM mleft $ \left -> do
+        moveTo left y
+        arrowHead False
+        lineTo (e - 5) y
+        stroke
+
+    maybeM mright $ \right -> do
+        moveTo (e + 5) y
+        lineTo right y
+        arrowHead True
+        stroke
 
 drawArc :: Double -> Double -> Double -> Double
         -> Double -> Double -> Double -> Double
diff --git a/Bustle/Loader/OldSkool.hs b/Bustle/Loader/OldSkool.hs
index 945b883..4a0ca9f 100644
--- a/Bustle/Loader/OldSkool.hs
+++ b/Bustle/Loader/OldSkool.hs
@@ -148,6 +148,7 @@ signal = do
     t
     -- Ignore serial
     m <- Signal <$> (parseSerial >> t >> parseBusName) <* t
+                <*> return Nothing
                 <*> entireMember
     return $ DetailedMessage µs m Nothing
   <?> "signal"
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index 436b2b5..80f1c03 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -4,7 +4,7 @@ module Bustle.Loader.Pcap
   )
 where
 
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, fromMaybe)
 import Data.Either (partitionEithers)
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -27,15 +27,21 @@ import qualified Bustle.Types as B
 
 -- Conversions from dbus-core's types into Bustle's more stupid types. This
 -- whole section is pretty upsetting.
+stringifyBusName :: BusName
+                 -> String
+stringifyBusName = T.unpack . busNameText
+
+stupifyBusName :: String
+               -> B.BusName
+stupifyBusName n =
+    case n of
+        (':':_) -> B.U $ B.UniqueName n
+        _       -> B.O $ B.OtherName n
+
 convertBusName :: String
                -> Maybe BusName
                -> B.BusName
-convertBusName context n =
-    case rawName of
-        (':':_) -> B.U $ B.UniqueName rawName
-        _       -> B.O $ B.OtherName rawName
-  where
-    rawName = maybe context (T.unpack . busNameText) n
+convertBusName context n = stupifyBusName (maybe context stringifyBusName n)
 
 convertMember :: (a -> ObjectPath)
               -> (a -> Maybe InterfaceName)
@@ -170,6 +176,8 @@ bustlify µs bytes m = do
             | otherwise                      -> return $
                 B.Signal { B.sender = convertBusName "signal.sender" sender
                          , B.member = convertMember signalPath (Just . signalInterface) signalMember sig
+                         , B.signalDestination = fmap (stupifyBusName . stringifyBusName)
+                                               $ signalDestination sig
                          }
 
         (ReceivedUnknown _ _ _) -> error "wtf"
diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs
index 3d3463e..43d08e3 100644
--- a/Bustle/Renderer.hs
+++ b/Bustle/Renderer.hs
@@ -49,7 +49,7 @@ import Control.Monad.Writer
 import Control.Monad (forM_)
 
 import Data.List (isPrefixOf, stripPrefix, sort, sortBy)
-import Data.Maybe (fromJust, maybe, fromMaybe, catMaybes)
+import Data.Maybe (fromJust, maybe, fromMaybe, catMaybes, maybeToList)
 import Data.Ord (comparing)
 
 data Bus = SessionBus
@@ -498,6 +498,14 @@ destinationCoordinate :: Bus
                       -> Renderer Double
 destinationCoordinate bus m = appCoordinate bus . destination $ dmMessage m
 
+signalDestinationCoordinate :: Bus
+                            -> DetailedMessage
+                            -> Renderer (Maybe Double)
+signalDestinationCoordinate bus m =
+    case signalDestination $ dmMessage m of
+        Nothing -> return Nothing
+        Just n  -> Just <$> appCoordinate bus n
+
 memberName :: DetailedMessage
            -> Bool
            -> Renderer ()
@@ -543,7 +551,7 @@ mentionedNames :: Message
 mentionedNames m = case m of
     MethodCall { sender = s, destination = d }   -> [s, d]
     MethodReturn { sender = s, destination = d } -> [s, d]
-    Signal { sender = s }                        -> [s]
+    Signal { sender = s, signalDestination = d } -> s:maybeToList d
     Error { sender = s, destination = d }        -> [s, d]
     -- We always want to process owner changes.
     _                                            -> []
@@ -620,19 +628,24 @@ methodLike colour a bus dm = do
 
 signal :: Bus -> DetailedMessage -> Renderer ()
 signal bus dm = do
-    x <- senderCoordinate bus dm
     t <- gets row
-
-    -- FIXME: per-bus sign.
-    let f = case bus of
-            SessionBus -> subtract
-            SystemBus  -> (+)
-    -- fromJust is safe here because we must have an app to have a signal. It
-    -- doesn't make me very happy though.
-    outside <- f columnWidth . fromJust <$> edgemostApp bus
-    inside <- getsBusState firstColumn bus
-    let [x1, x2] = sort [outside, inside]
-
-    shape $ SignalArrow (x1 - 20) x (x2 + 20) t
+    emitter <- senderCoordinate bus dm
+    mtarget <- signalDestinationCoordinate bus dm
+
+    case mtarget of
+        Just target -> do
+            shape $ DirectedSignalArrow emitter target t
+        Nothing -> do
+            -- FIXME: per-bus sign.
+            let f = case bus of
+                    SessionBus -> subtract
+                    SystemBus  -> (+)
+            -- fromJust is safe here because we must have an app to have a
+            -- signal. It doesn't make me very happy though.
+            outside <- f columnWidth . fromJust <$> edgemostApp bus
+            inside <- getsBusState firstColumn bus
+            let [x1, x2] = sort [outside, inside]
+
+            shape $ SignalArrow (x1 - 20) emitter (x2 + 20) t
 
 -- vim: sw=2 sts=2
diff --git a/Bustle/Types.hs b/Bustle/Types.hs
index d90faf5..64e37b9 100644
--- a/Bustle/Types.hs
+++ b/Bustle/Types.hs
@@ -73,6 +73,7 @@ data Message = MethodCall { serial :: Serial
                             , destination :: BusName
                             }
              | Signal { sender :: BusName
+                      , signalDestination :: Maybe BusName
                       , member :: Member
                       }
              | Error { inReplyTo :: Maybe DetailedMessage
diff --git a/Bustle/UI/DetailsView.hs b/Bustle/UI/DetailsView.hs
index 4fe8394..9c0ceba 100644
--- a/Bustle/UI/DetailsView.hs
+++ b/Bustle/UI/DetailsView.hs
@@ -87,7 +87,10 @@ pickTitle (DetailedMessage _ m _) = case m of
     MethodCall {} -> b (escape "Method call")
     MethodReturn {} -> b (escape "Method return")
     Error {} -> b (escape "Error")
-    Signal {} -> b (escape "Signal")
+    Signal { signalDestination = d } ->
+        b . escape $ case d of
+            Nothing -> "Signal"
+            Just _  -> "Directed signal"
     _ -> escape "I am made of chalk"
 
 getMemberMarkup :: Member -> String
diff --git a/Bustle/Util.hs b/Bustle/Util.hs
index 7420475..7b746b5 100644
--- a/Bustle/Util.hs
+++ b/Bustle/Util.hs
@@ -74,9 +74,10 @@ handleIOExceptions f act = do
     result <- io $ try act
     toErrorT f result
 
-maybeM :: Maybe a
-       -> (a -> IO b)
-       -> IO ()
+maybeM :: Monad m
+       => Maybe a
+       -> (a -> m b)
+       -> m ()
 maybeM Nothing _ = return ()
 maybeM (Just x) act = act x >> return ()