Renderer: allow combining RendererResults

This rejustifies the two subdiagrams appropriately so that they have the
same origin: the main reason why just catting the various lists together
doesn't cut it.

3 files changed, 117 insertions, 8 deletions

diff --git a/Bustle/Diagram.hs b/Bustle/Diagram.hs
index e440b16..30f8bbc 100644
--- a/Bustle/Diagram.hs
+++ b/Bustle/Diagram.hs
@@ -42,6 +42,7 @@ module Bustle.Diagram
   -- Displaying diagrams
   , diagramDimensions
   , topLeftJustifyDiagram
+  , translateDiagram
   , drawDiagram
   , drawRegion
   )
diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs
index 4ba2aa0..4756a3f 100644
--- a/Bustle/Renderer.hs
+++ b/Bustle/Renderer.hs
@@ -76,7 +76,7 @@ data Participants =
                  , _pSystem :: Map (Double, UniqueName) (Set OtherName)
                  }
   deriving
-    (Show)
+    (Show, Eq)
 
 instance Monoid Participants where
     mempty = Participants Map.empty Map.empty
@@ -92,13 +92,54 @@ sessionParticipants = map (snd *** id) . Map.toAscList . pSession
 
 data RendererResult apps =
     RendererResult { rrCentreOffset :: Double
+                   , rrTopOffset :: Double -- ^ you shouldn't really need this outside of here.
                    , rrShapes :: [Shape]
                    , rrRegions :: Regions DetailedMessage
                    , rrApplications :: apps
                    , rrWarnings :: [String]
                    }
   deriving
-    (Show, Functor) -- Using Functor is a slight hack really
+    (Show, Functor, Eq) -- Using Functor is a slight hack really
+
+-- Yikes.
+--
+-- When combining two segments of a diagram, we may need to translate
+-- one or other segment in either axis. For instance, if the first message
+-- involves a service with only one bus name, but the second involves a service
+-- with a hundred names, we're going to need a massive downwards translation to
+-- shift the first set of messages down to match the second.
+--
+-- This is extremely unpleasant but it's a Monday. There's a test case in
+-- Test/Renderer.hs because I don't trust myself.
+instance Monoid apps => Monoid (RendererResult apps) where
+    mempty = RendererResult 0 0 [] [] mempty []
+    mappend rr1 rr2 = RendererResult centreOffset topOffset shapes regions applications warnings
+      where
+        centreOffset = rrCentreOffset rr1 `max` rrCentreOffset rr2
+        topOffset = rrTopOffset rr1 `max` rrTopOffset rr2
+
+        shapes = shapes1 ++ shapes2
+        versus x y = if x < y then Just (y - x) else Nothing
+        translation rr = ( rrCentreOffset rr `versus` centreOffset
+                         , rrTopOffset    rr `versus` topOffset
+                         )
+        translateShapes rr =
+            case translation rr of
+                -- Hooray for premature optimization
+                (Nothing, Nothing) -> rrShapes rr
+                (mx,      my) -> translateDiagram (fromMaybe 0 mx, fromMaybe 0 my) $ rrShapes rr
+        shapes1 = translateShapes rr1
+        shapes2 = translateShapes rr2
+
+        translatedRegions rr =
+            case snd $ translation rr of
+                Nothing -> rrRegions rr
+                Just  y -> translateRegions y $ rrRegions rr
+
+        regions = translatedRegions rr1 ++ translatedRegions rr2
+
+        applications = rrApplications rr1 `mappend` rrApplications rr2
+        warnings = rrWarnings rr1 `mappend` rrWarnings rr2
 
 processWithFilters :: (Log, Set UniqueName)
                    -> (Log, Set UniqueName)
@@ -123,7 +164,7 @@ buildResult :: RendererOutput
             -> RendererState
             -> RendererResult Participants
 buildResult (RendererOutput diagram messageRegions warnings) rs =
-    RendererResult x diagram' regions' participants warnings
+    RendererResult x y diagram' regions' participants warnings
   where
     (_translation@(x, y), diagram') = topLeftJustifyDiagram diagram
     regions' = translateRegions y messageRegions
diff --git a/Test/Renderer.hs b/Test/Renderer.hs
index ce62257..446ec81 100644
--- a/Test/Renderer.hs
+++ b/Test/Renderer.hs
@@ -6,36 +6,103 @@ import Test.Framework.Providers.HUnit
 import Test.HUnit
 
 import Control.Monad (when)
+import Control.Monad.State
 import qualified Data.Set as Set
+import Data.Monoid
+import Data.List
 import System.Exit (exitFailure)
 
 import Bustle.Types
 import Bustle.Renderer
 
+main :: IO ()
 main = defaultMain tests
   where
     tests = [ testGroup "Disconnections don't affect participants"
                 [ testCase "One participant, no disconnection" test_participants
                 , testCase "One participant, which disconnects" test_participants_with_disconnect
                 ]
+            , testGroup "Incremential rendering matches all-at-once rendering"
+                [ testCase "rrCentreOffset" $ test_incremental_simple rrCentreOffset
+                , testCase "rrTopOffset" $ test_incremental_simple rrTopOffset
+                , testCase "rrShapes" $ test_incremental_list rrShapes
+                , testCase "rrRegions" $ test_incremental_list rrRegions
+                , testCase "rrApplications" $ test_incremental_simple rrApplications
+                , testCase "rrWarnings" $ test_incremental_simple rrWarnings
+                ]
             ]
 
 -- Tests that services visible in a log are listed as participants even if they
 -- disconnect from the bus before the end of the log. This is a regression test
 -- for a bug I almost introduced.
 activeService = UniqueName ":1.1"
-swaddle = map (\m -> DetailedMessage 0 m Nothing)
-sessionLog =
+swaddle messages timestamps = map (\(m, ts) -> DetailedMessage ts m Nothing)
+                                  (zip messages timestamps)
+sessionLogWithoutDisconnect =
     [ Connected activeService
     , Signal (U activeService) Nothing $ Member "/" Nothing "Hello"
     ]
-sessionLogWithDisconnect = sessionLog ++ [ Disconnected activeService ]
+sessionLogWithDisconnect = sessionLogWithoutDisconnect ++ [ Disconnected activeService ]
 expectedParticipants = [ (activeService, Set.empty) ]
 
 test_ l expected = expected @=? ps
   where
-    rr = process (swaddle l) []
+    rr = process (swaddle l [1..]) []
     ps = sessionParticipants (rrApplications rr)
 
-test_participants = test_ sessionLog expectedParticipants
+test_participants = test_ sessionLogWithoutDisconnect expectedParticipants
 test_participants_with_disconnect = test_ sessionLogWithDisconnect expectedParticipants
+
+-- Test that incremental rendering matches all-at-once rendering
+u1 = UniqueName ":1.1"
+u2 = UniqueName ":2.2"
+
+-- This is enough names that the log needs to be rejustified to the top
+os = map (OtherName . ("Foo." ++) . (:"potato")) ['a'..'z']
+
+m = Member "/" Nothing "Hi"
+
+bareLog = [ Connected u1
+          , Signal (U u1) Nothing m
+          , Connected u2
+          ]
+          ++ map (\o -> NameChanged o (Claimed u2)) os ++
+          [ MethodCall 0 (U u1) (O (head os)) m ]
+
+sessionLog = swaddle bareLog [1,3..]
+systemLog  = swaddle bareLog [2,4..]
+
+test_incremental_simple :: (Show b, Eq b)
+                        => (RendererResult Participants -> b)
+                        -> Assertion
+test_incremental_simple f =
+    test_incremental $ \full incremental -> f full @=? f incremental
+
+test_incremental_list :: (Show b, Eq b)
+                      => (RendererResult Participants -> [b])
+                      -> Assertion
+test_incremental_list f =
+    test_incremental $ \fullRR incrementalRR -> do
+        let full = f fullRR
+            incr = f incrementalRR
+
+        -- Compare each element in turn
+        mapM_ (uncurry (@=?)) $ zip full incr
+        when (length full /= length incr) $
+            full @=? incr
+
+test_incremental :: (  RendererResult Participants
+                    -> RendererResult Participants
+                    -> Assertion
+                    )
+                 -> Assertion
+test_incremental f = f fullRR incrementalRR
+
+-- TODO: it should be possible to make this work for side-by-side logs too.
+-- Currently it doesn't seem to...
+fullRR, incrementalRR :: RendererResult Participants
+fullRR = process sessionLog []
+incrementalRR = mconcat rrs
+  where
+    processOne m = state $ processSome [m] []
+    (rrs, _) = runState (mapM processOne sessionLog) rendererStateNew