add --graphviz mode

This commit was sponsored by Shane-o on Patreon.

1 files changed, 79 insertions, 0 deletions

diff --git a/Graphviz.hs b/Graphviz.hs
new file mode 100644
index 0000000..81ff71a
--- /dev/null
+++ b/Graphviz.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
+
+module Graphviz (graphviz) where
+
+import Types
+
+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.Lazy as L
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.Encoding as T
+import Data.Text.Encoding.Error
+
+graphviz :: FilePath -> IO ()
+graphviz logfile = do
+	parsed <- parseLog <$> L.readFile logfile
+	case lefts parsed of
+		[] -> do
+			let g = genGraph (rights parsed)
+			f <- createImage logfile 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 :: [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 $ seenData $ activity a
+				, shape Circle
+				, xcolor Green
+				]
+			chain a h
+		ActivityEntered { activityEntered = (a, h) } -> do
+			node (display h)
+				[ textLabel $ display $ enteredData $ activity a
+				, shape Square
+				, if activityEnteredAccepted l
+					then xcolor Green
+					else xcolor Red
+				]
+			chain a h
+  where
+	chain a h = case prevActivity a of
+		Nothing -> return ()
+		Just p -> display p --> display h
+
+xcolor :: X11Color -> Attribute
+xcolor c = Color [toWC $ X11Color c]
+
+class Display t where
+	display :: t -> T.Text
+
+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