blob: c6ce8a99549e2eff6e39bb9fcfac88b2c89ee3e8 (
plain)
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
|
{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
module Graphviz (graphviz) where
import Types
import Hash
import CmdLine
import Data.Aeson
import Data.Char
import Data.Word
import Data.Either
import Data.Monoid
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
graphviz :: GraphvizOpts -> IO ()
graphviz opts = do
parsed <- parseLog <$> L.readFile (graphvizLogFile opts)
case lefts parsed of
[] -> do
let g = genGraph opts (rights parsed)
f <- createImage (graphvizLogFile opts) Png g
putStrLn ("Generated " ++ f)
errs -> error $ unlines errs
parseLog :: L.ByteString -> [Either String ActivityLog]
parseLog = map eitherDecode'
. filter (not . L.null)
. L.split nl
nl :: Word8
nl = fromIntegral (ord '\n')
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 opts ls = digraph (Str "debug-me") $ do
nodeAttrs [style filled]
forM_ ls $
showactivity [ xcolor Green ]
where
showactivity s l = case loggedActivity l of
ActivitySeen a -> 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
node (display h) $ s ++
[ textLabel $ prettyDisplay $ activity a
, shape Circle
]
linkprev s a h
where
h = loggedHash l
linkprev s a h = case prevActivity a of
Nothing -> return ()
Just p -> link p h s
link a b s = edge (display a) (display b) $ s ++
if graphvizShowHashes opts
then [ textLabel (prettyDisplay a) ]
else []
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 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 a => Display (Proto a) where
display (Proto a) = display a
display (Rejected a) = "Rejected: " <> display (activity a)
|
