summaryrefslogtreecommitdiffhomepage
path: root/Graphviz.hs
blob: f8f165c8e8b9c6d81ec6ce69db9d813a24931ba6 (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
134
135
136
137
{- 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.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
	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