diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-17 16:01:30 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-17 16:09:32 -0400 |
commit | 74499ceb9decf47709304c5923cefab6b0b99cef (patch) | |
tree | 3b06b6b42fefde413ff5a27bee1538744d64b2d7 /Graphviz.hs | |
parent | ca51fa47fd9d03ac25460dbea7619f79212a912f (diff) | |
download | debug-me-74499ceb9decf47709304c5923cefab6b0b99cef.tar.gz |
improve display of Rejected
Diffstat (limited to 'Graphviz.hs')
-rw-r--r-- | Graphviz.hs | 41 |
1 files changed, 26 insertions, 15 deletions
diff --git a/Graphviz.hs b/Graphviz.hs index 26b7563..d3a599e 100644 --- a/Graphviz.hs +++ b/Graphviz.hs @@ -3,6 +3,7 @@ module Graphviz (graphviz) where import Types +import Hash import Data.Aeson import Data.Char @@ -45,25 +46,35 @@ createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f genGraph :: [ActivityLog] -> G.DotGraph T.Text genGraph ls = digraph (Str "debug-me") $ do nodeAttrs [style filled] - forM_ ls $ \l -> case l of - ActivitySeen { activitySeen = (a, h) } -> do - node (display h) - [ textLabel $ display $ activity a - , shape BoxShape - , xcolor Green - ] - chain a h - ActivityEntered { activityEntered = (a, h) } -> do - node (display h) + forM_ ls $ + showactivity [ xcolor Green ] + where + showactivity s (ActivitySeen { activitySeen = (a, h) }) = do + node (display h) $ s ++ + [ textLabel $ display $ activity a + , shape BoxShape + ] + case activity a of + Rejected ar -> do + let hr = hash ar + let rejstyle = + [ xcolor Red + , Style [dashed, filled] + ] + showactivity rejstyle $ + ActivityEntered (ar, hr) + edge (display hr) (display h) rejstyle + _ -> return () + chain s a h + showactivity s (ActivityEntered { activityEntered = (a, h) }) = do + node (display h) $ s ++ [ textLabel $ display $ activity a , shape Circle - , xcolor Green ] - chain a h - where - chain a h = case prevActivity a of + chain s a h + chain s a h = case prevActivity a of Nothing -> return () - Just p -> display p --> display h + Just p -> edge (display p) (display h) s xcolor :: X11Color -> Attribute xcolor c = Color [toWC $ X11Color c] |