1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{- Copyright 2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}
module Graphviz (graphviz) where
import Types
import CmdLine
import Log
import Data.Char hiding (Control)
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import Data.GraphViz.Types.Generalised as G
import Data.GraphViz.Types.Monadic
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import Data.Text.Encoding.Error
import Data.Monoid
import Prelude
graphviz :: GraphvizOpts -> IO ()
graphviz opts = do
l <- streamLog (graphvizLogFile opts)
let g = genGraph opts l
f <- createImage (graphvizLogFile opts) Png g
putStrLn ("Generated " ++ f)
createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath
createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f
genGraph :: GraphvizOpts -> [Either String Log] -> G.DotGraph T.Text
genGraph opts ls = digraph (Str "debug-me") $ do
nodeAttrs [style filled]
forM_ ls $
showlog [ xcolor Green ]
where
showlog s (Right l) = showactivity s l
showlog _ (Left l) = node (display l) [xcolor Red, shape DiamondShape]
showactivity s l = case (loggedMessage l, loggedHash l) of
(User (ActivityMessage a), Just h) -> do
node (display h) $ s ++
[ textLabel $ prettyDisplay $ activity a
, shape BoxShape
]
linkprev s a h
(Developer (ActivityMessage a), Just h) -> do
node (display h) $ s ++
[ textLabel $ prettyDisplay $ activity a
, shape Circle
]
linkprev s a h
(User (ControlMessage c), Nothing) -> showcontrol c
(Developer (ControlMessage c), Nothing) -> showcontrol c
_ -> return ()
showcontrol (Control (EnteredRejected hr _) _) = do
let rejstyle =
[ xcolor Red
, Style [dashed, filled]
]
let nodename = display $ "Rejected: " <> display hr
node nodename $ rejstyle ++
[ textLabel "Rejected"
, shape BoxShape
]
edge nodename (display hr) rejstyle
showcontrol _ = return ()
linkprev s a h = do
case prevActivity a of
Nothing -> return ()
Just p -> link p h s
case prevEntered a of
Nothing -> return ()
Just p -> link p h (s ++ enteredpointerstyle)
link a b s = edge (display a) (display b) $ s ++
if graphvizShowHashes opts
then [ textLabel (prettyDisplay a) ]
else []
enteredpointerstyle = [ xcolor Gray ]
xcolor :: X11Color -> Attribute
xcolor c = Color [toWC $ X11Color c]
class Display t where
-- Display more or less as-is, for graphviz.
display :: t -> T.Text
-- Prettified display for user-visible labels etc.
prettyDisplay :: t -> T.Text
prettyDisplay = prettyDisplay . display
instance Display T.Text where
display = id
prettyDisplay t
| all visible s = t
| all isPrint s && not (leadingws s) && not (leadingws (reverse s)) = t
| otherwise = T.pack (show s)
where
s = T.unpack t
visible c = isPrint c && not (isSpace c)
leadingws (c:_) = isSpace c
leadingws _ = False
instance Display String where
display = display . T.pack
instance Display Val where
display (Val b) = T.decodeUtf8With lenientDecode (L.fromStrict b)
instance Display Hash where
display (Hash m h) = T.pack (show m) <> display h
-- Use short hash for pretty display.
-- The "h:" prefix is to work around this bug:
-- https://github.com/ivan-m/graphviz/issues/16
prettyDisplay h = display $ Val $ "h:" <> (B.take 5 $ val $ hashValue h)
instance Display Seen where
display = display . seenData
instance Display Entered where
display v
| B.null (val $ echoData v) = display $ enteredData v
| otherwise = "[" <> display (echoData v) <> "] " <> display (enteredData v)
instance Display Control where
display = display . control
instance Display ControlAction where
display = T.pack . show
|
