From 6f7cf857b408401abdc4477c888495b4f13162c7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 19 Apr 2017 17:30:32 -0400
Subject: reorganized message types

Make Control messages be out-of-band async messages, without a pointer
to a previous message.

And then followed the type change through the code for hours..

This commit was sponsored by Nick Daly on Patreon.
---
 Graphviz.hs | 60 ++++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 34 insertions(+), 26 deletions(-)

(limited to 'Graphviz.hs')

diff --git a/Graphviz.hs b/Graphviz.hs
index b85821c..59f3bf9 100644
--- a/Graphviz.hs
+++ b/Graphviz.hs
@@ -7,7 +7,7 @@ import Hash
 import CmdLine
 import Log
 
-import Data.Char
+import Data.Char hiding (Control)
 import Data.Monoid
 import Data.GraphViz
 import Data.GraphViz.Attributes.Complete
@@ -30,42 +30,48 @@ graphviz opts = do
 createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath
 createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f
 
-genGraph :: GraphvizOpts -> [ActivityLog] -> G.DotGraph T.Text
+genGraph :: GraphvizOpts -> [Log] -> G.DotGraph T.Text
 genGraph opts ls = digraph (Str "debug-me") $ do
 	nodeAttrs [style filled]
 	forM_ ls $
-		showactivity [ xcolor Green ]
+		showlog [ xcolor Green ]
   where
-	showactivity s l = case loggedActivity l of
-		ActivitySeen a -> do
+	showlog s l = case (loggedMessage l, loggedHash l) of
+		(User (ActivityMessage a), Just h) -> do
 			node (display h) $ s ++
 				[ textLabel $ prettyDisplay $ activity a
 				, shape BoxShape
 				]
-			case activity a of
-				Rejected ar -> do
-					let hr = hash ar
-					let rejstyle =
-						[ xcolor Red
-						, Style [dashed, filled]
-						]
-					showactivity rejstyle $
-						ActivityLog
-							{ loggedActivity = ActivityEntered ar
-							, loggedHash = hr
-							, loggedTimestamp = loggedTimestamp l
-							}
-					link hr h rejstyle
-				_ -> return ()
 			linkprev s a h
-		ActivityEntered a -> do
+		(Developer (ActivityMessage a), Just h) -> do
 			node (display h) $ s ++
 				[ textLabel $ prettyDisplay $ activity a
 				, shape Circle
 				]
 			linkprev s a h
-	  where
-		h = loggedHash l
+		(User (ControlMessage c), Nothing) -> showcontrol c l
+		(Developer (ControlMessage c), Nothing) -> showcontrol c l
+		_ -> return ()
+
+	showcontrol (Control (Rejected ar) _) l = do
+		let hr = hash ar
+		let rejstyle =
+			[ xcolor Red
+			, Style [dashed, filled]
+			]
+		let nodename = display $ "Rejected " <> display hr
+		node nodename $ rejstyle ++
+			[ textLabel "Rejected"
+			, shape BoxShape
+			]
+		showlog rejstyle $ Log
+			{ loggedMessage = Developer (ActivityMessage ar)
+			, loggedHash = Just hr
+			, loggedTimestamp = loggedTimestamp l
+			}
+		edge nodename (display hr) rejstyle
+	showcontrol _ _ = return ()
+
 	linkprev s a h = case prevActivity a of
 		Nothing -> return ()
 		Just p -> link p h s
@@ -114,6 +120,8 @@ instance Display Entered where
 		| B.null (val $ echoData v) = display $ enteredData v
 		| otherwise = "[" <> display (echoData v) <> "] " <> display (enteredData v)
 
-instance Display a => Display (Proto a) where
-	display (Proto a) = display a
-	display (Rejected a) = "Rejected: " <> display (activity a)
+instance Display Control where
+	display = display . control
+
+instance Display ControlAction where
+	display = T.pack . show
-- 
cgit v1.2.3