debug-me-1.20181208: Graphviz.hs

{- 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