{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.StateMachine.DotDrawing
( GraphOptions (..)
, GraphvizOutput (..)
, Rose (..)
, printDotGraph
) where
import Control.Exception
import Control.Monad
import Data.GraphViz.Attributes.Complete
import Data.GraphViz.Commands
import Data.GraphViz.Exception
import Data.GraphViz.Types.Canonical
import Data.List
(uncons)
import Data.List.Split
import Data.Map hiding
(null)
import Data.Maybe
import Data.Text.Lazy
(pack)
import Prelude
import Test.StateMachine.Types.History
------------------------------------------------------------------------
data GraphOptions = GraphOptions {
filePath :: FilePath -- Where to store the graph
-- (note: file extensions are not checked)
, graphvizOutput :: GraphvizOutput -- output formats (like Jpeg, Png ..)
}
data Rose a = Rose a (Map Pid a)
deriving stock (Functor, Show)
printDotGraph :: GraphOptions -> Rose [String] -> IO ()
printDotGraph GraphOptions{..} (Rose pref sfx) = do
let
-- create barrier nodes
nThreads = size sfx
barrierRecord = (\n -> PortName (PN {portName = pack $ show n})) <$> [1..nThreads]
barrierNode = DotNode {
nodeID = "barrier"
, nodeAttributes =
[Shape Record,FixedSize SetNodeSize,Width 4.0,
Height 0.0,
Label (RecordLabel barrierRecord)]
}
-- create preffix
prefixWithResp = zip [1..] $ byTwoUnsafe "prefix" pref
prefixNodes = toDotNode "prefix" <$> prefixWithResp
prefixEdges = connectNodes prefixNodes
-- create suffixes
nodesAndEdges = flip Prelude.map (toList sfx) $ \(pid, str) ->
let p = unPid pid
s = zip [1..] $ byTwoUnsafe (show p) str
n = toDotNode (show p) <$> s
e = connectNodes n
in (p, n, e)
nodes = concatMap (\(_,n,_) -> n) nodesAndEdges
edges = concatMap (\(_,_,e) -> e) nodesAndEdges
firstOfEachPid = (\(p, n, _) -> (p, fst <$> uncons n)) <$> nodesAndEdges
-- create barrier edges
edgesFromBarrier = concatMap (\(p, mn) -> case mn of
Nothing -> []
Just n -> [DotEdge {
fromNode = nodeID barrierNode
, toNode = nodeID n
, edgeAttributes = [TailPort (LabelledPort (PN {portName = pack $ show p}) Nothing)]
}]) firstOfEachPid
prefixToBarrier = case prefixNodes of
[] -> []
_ -> [DotEdge {
fromNode = nodeID (last prefixNodes)
, toNode = nodeID barrierNode
, edgeAttributes = [] -- [HeadPort (LabelledPort (PN {portName = "1"}) Nothing)]]
}]
-- create dot graph
dotStmts = DotStmts {
attrStmts = [NodeAttrs {attrs = [Shape BoxShape,Width 4.0]}]
, subGraphs = [] -- do we want to put commands with same pid on the same group?
, nodeStmts = barrierNode : (prefixNodes ++ nodes)
, edgeStmts = prefixToBarrier ++ prefixEdges ++ edges ++ edgesFromBarrier
}
dg = DotGraph {
strictGraph = False
, directedGraph = True
, graphID = Just (Str $ pack "G")
, graphStatements = dotStmts
}
err <- try $ try $ runGraphviz dg graphvizOutput filePath
case err of
Left (e :: GraphvizException) ->
putStrLn $ displayException e
Right (Left (e :: IOException)) ->
putStrLn $ displayException e
Right (Right _) ->
return ()
toDotNode :: String -> (Int, (String,String)) -> DotNode String
toDotNode nodeIdGroup (n, (invocation, resp)) =
DotNode {
nodeID = nodeIdGroup ++ "-" ++ show n
, nodeAttributes = [Label $ StrLabel $ pack $
newLinesAfter "\\l" 60 invocation
++ "\\n"
++ newLinesAfter "\\r" 60 resp]
}
byTwoUnsafe :: String -> [a] -> [(a,a)]
byTwoUnsafe str ls = fromMaybe (error $ "couldn't split " ++ if null str then " " else str ++ " in pairs") $ byTwo ls
byTwo :: [a] -> Maybe [(a,a)]
byTwo = go []
where
go acc [] = Just $ reverse acc
go _acc [_] = Nothing
go acc (a: b : rest) = go ((a,b) : acc) rest
connectNodes :: [DotNode a] -> [DotEdge a]
connectNodes = go []
where
go acc [] = reverse acc
go acc [_] = reverse acc
go acc (a:b:rest) = go (DotEdge (nodeID a) (nodeID b) [] : acc) (b:rest)
newLinesAfter :: String -> Int -> String -> String
newLinesAfter esc n str = concatMap (++ esc) (chunksOf n str)