{-# 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 {
GraphOptions -> String
filePath :: FilePath
, GraphOptions -> GraphvizOutput
graphvizOutput :: GraphvizOutput
}
data Rose a = Rose a (Map Pid a)
deriving stock (forall a b. a -> Rose b -> Rose a
forall a b. (a -> b) -> Rose a -> Rose b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Rose b -> Rose a
$c<$ :: forall a b. a -> Rose b -> Rose a
fmap :: forall a b. (a -> b) -> Rose a -> Rose b
$cfmap :: forall a b. (a -> b) -> Rose a -> Rose b
Functor, Int -> Rose a -> ShowS
forall a. Show a => Int -> Rose a -> ShowS
forall a. Show a => [Rose a] -> ShowS
forall a. Show a => Rose a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rose a] -> ShowS
$cshowList :: forall a. Show a => [Rose a] -> ShowS
show :: Rose a -> String
$cshow :: forall a. Show a => Rose a -> String
showsPrec :: Int -> Rose a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Rose a -> ShowS
Show)
printDotGraph :: GraphOptions -> Rose [String] -> IO ()
printDotGraph :: GraphOptions -> Rose [String] -> IO ()
printDotGraph GraphOptions{String
GraphvizOutput
graphvizOutput :: GraphvizOutput
filePath :: String
graphvizOutput :: GraphOptions -> GraphvizOutput
filePath :: GraphOptions -> String
..} (Rose [String]
pref Map Pid [String]
sfx) = do
let
nThreads :: Int
nThreads = forall k a. Map k a -> Int
size Map Pid [String]
sfx
barrierRecord :: [RecordField]
barrierRecord = (\Int
n -> PortName -> RecordField
PortName (PN {portName :: Text
portName = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
n})) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1..Int
nThreads]
barrierNode :: DotNode String
barrierNode = DotNode {
nodeID :: String
nodeID = String
"barrier"
, nodeAttributes :: Attributes
nodeAttributes =
[Shape -> Attribute
Shape Shape
Record,NodeSize -> Attribute
FixedSize NodeSize
SetNodeSize,Double -> Attribute
Width Double
4.0,
Double -> Attribute
Height Double
0.0,
Label -> Attribute
Label ([RecordField] -> Label
RecordLabel [RecordField]
barrierRecord)]
}
prefixWithResp :: [(Int, (String, String))]
prefixWithResp = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [(a, a)]
byTwoUnsafe String
"prefix" [String]
pref
prefixNodes :: [DotNode String]
prefixNodes = String -> (Int, (String, String)) -> DotNode String
toDotNode String
"prefix" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (String, String))]
prefixWithResp
prefixEdges :: [DotEdge String]
prefixEdges = forall a. [DotNode a] -> [DotEdge a]
connectNodes [DotNode String]
prefixNodes
nodesAndEdges :: [(Int, [DotNode String], [DotEdge String])]
nodesAndEdges = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
Prelude.map (forall k a. Map k a -> [(k, a)]
toList Map Pid [String]
sfx) forall a b. (a -> b) -> a -> b
$ \(Pid
pid, [String]
str) ->
let p :: Int
p = Pid -> Int
unPid Pid
pid
s :: [(Int, (String, String))]
s = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [(a, a)]
byTwoUnsafe (forall a. Show a => a -> String
show Int
p) [String]
str
n :: [DotNode String]
n = String -> (Int, (String, String)) -> DotNode String
toDotNode (forall a. Show a => a -> String
show Int
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (String, String))]
s
e :: [DotEdge String]
e = forall a. [DotNode a] -> [DotEdge a]
connectNodes [DotNode String]
n
in (Int
p, [DotNode String]
n, [DotEdge String]
e)
nodes :: [DotNode String]
nodes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
_,[DotNode String]
n,[DotEdge String]
_) -> [DotNode String]
n) [(Int, [DotNode String], [DotEdge String])]
nodesAndEdges
edges :: [DotEdge String]
edges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
_,[DotNode String]
_,[DotEdge String]
e) -> [DotEdge String]
e) [(Int, [DotNode String], [DotEdge String])]
nodesAndEdges
firstOfEachPid :: [(Int, Maybe (DotNode String))]
firstOfEachPid = (\(Int
p, [DotNode String]
n, [DotEdge String]
_) -> (Int
p, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (a, [a])
uncons [DotNode String]
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, [DotNode String], [DotEdge String])]
nodesAndEdges
edgesFromBarrier :: [DotEdge String]
edgesFromBarrier = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ (\(Int
p, Maybe (DotNode String)
mn) -> case Maybe (DotNode String)
mn of
Maybe (DotNode String)
Nothing -> []
Just DotNode String
n -> [DotEdge {
fromNode :: String
fromNode = forall n. DotNode n -> n
nodeID DotNode String
barrierNode
, toNode :: String
toNode = forall n. DotNode n -> n
nodeID DotNode String
n
, edgeAttributes :: Attributes
edgeAttributes = [PortPos -> Attribute
TailPort (PortName -> Maybe CompassPoint -> PortPos
LabelledPort (PN {portName :: Text
portName = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
p}) forall a. Maybe a
Nothing)]
}]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Maybe (DotNode String))]
firstOfEachPid
prefixToBarrier :: [DotEdge String]
prefixToBarrier = case [DotNode String]
prefixNodes of
[] -> []
[DotNode String]
_ -> [DotEdge {
fromNode :: String
fromNode = forall n. DotNode n -> n
nodeID (forall a. [a] -> a
last [DotNode String]
prefixNodes)
, toNode :: String
toNode = forall n. DotNode n -> n
nodeID DotNode String
barrierNode
, edgeAttributes :: Attributes
edgeAttributes = []
}]
dotStmts :: DotStatements String
dotStmts = DotStmts {
attrStmts :: [GlobalAttributes]
attrStmts = [NodeAttrs {attrs :: Attributes
attrs = [Shape -> Attribute
Shape Shape
BoxShape,Double -> Attribute
Width Double
4.0]}]
, subGraphs :: [DotSubGraph String]
subGraphs = []
, nodeStmts :: [DotNode String]
nodeStmts = DotNode String
barrierNode forall a. a -> [a] -> [a]
: ([DotNode String]
prefixNodes forall a. [a] -> [a] -> [a]
++ [DotNode String]
nodes)
, edgeStmts :: [DotEdge String]
edgeStmts = [DotEdge String]
prefixToBarrier forall a. [a] -> [a] -> [a]
++ [DotEdge String]
prefixEdges forall a. [a] -> [a] -> [a]
++ [DotEdge String]
edges forall a. [a] -> [a] -> [a]
++ [DotEdge String]
edgesFromBarrier
}
dg :: DotGraph String
dg = DotGraph {
strictGraph :: Bool
strictGraph = Bool
False
, directedGraph :: Bool
directedGraph = Bool
True
, graphID :: Maybe GraphID
graphID = forall a. a -> Maybe a
Just (Text -> GraphID
Str forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
"G")
, graphStatements :: DotStatements String
graphStatements = DotStatements String
dotStmts
}
Either GraphvizException (Either IOException String)
err <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizOutput -> String -> IO String
runGraphviz DotGraph String
dg GraphvizOutput
graphvizOutput String
filePath
case Either GraphvizException (Either IOException String)
err of
Left (GraphvizException
e :: GraphvizException) ->
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException GraphvizException
e
Right (Left (IOException
e :: IOException)) ->
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException IOException
e
Right (Right String
_) ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
toDotNode :: String -> (Int, (String,String)) -> DotNode String
toDotNode :: String -> (Int, (String, String)) -> DotNode String
toDotNode String
nodeIdGroup (Int
n, (String
invocation, String
resp)) =
DotNode {
nodeID :: String
nodeID = (String
nodeIdGroup forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n)
, nodeAttributes :: Attributes
nodeAttributes = [Label -> Attribute
Label forall a b. (a -> b) -> a -> b
$ Text -> Label
StrLabel forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$
(String -> Int -> ShowS
newLinesAfter String
"\\l" Int
60 String
invocation)
forall a. [a] -> [a] -> [a]
++ String
"\\n"
forall a. [a] -> [a] -> [a]
++ (String -> Int -> ShowS
newLinesAfter String
"\\r" Int
60 String
resp)]
}
byTwoUnsafe :: String -> [a] -> [(a,a)]
byTwoUnsafe :: forall a. String -> [a] -> [(a, a)]
byTwoUnsafe String
str [a]
ls = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"couldn't split " forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str then String
" " else String
str forall a. [a] -> [a] -> [a]
++ String
" in pairs") forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe [(a, a)]
byTwo [a]
ls
byTwo :: [a] -> Maybe [(a,a)]
byTwo :: forall a. [a] -> Maybe [(a, a)]
byTwo = forall {b}. [(b, b)] -> [b] -> Maybe [(b, b)]
go []
where
go :: [(b, b)] -> [b] -> Maybe [(b, b)]
go [(b, b)]
acc [] = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [(b, b)]
acc
go [(b, b)]
_acc [b
_] = forall a. Maybe a
Nothing
go [(b, b)]
acc (b
a: b
b : [b]
rest) = [(b, b)] -> [b] -> Maybe [(b, b)]
go ((b
a,b
b) forall a. a -> [a] -> [a]
: [(b, b)]
acc) [b]
rest
connectNodes :: [DotNode a] -> [DotEdge a]
connectNodes :: forall a. [DotNode a] -> [DotEdge a]
connectNodes = forall {n}. [DotEdge n] -> [DotNode n] -> [DotEdge n]
go []
where
go :: [DotEdge n] -> [DotNode n] -> [DotEdge n]
go [DotEdge n]
acc [] = forall a. [a] -> [a]
reverse [DotEdge n]
acc
go [DotEdge n]
acc [DotNode n
_] = forall a. [a] -> [a]
reverse [DotEdge n]
acc
go [DotEdge n]
acc (DotNode n
a:DotNode n
b:[DotNode n]
rest) = [DotEdge n] -> [DotNode n] -> [DotEdge n]
go (forall n. n -> n -> Attributes -> DotEdge n
DotEdge (forall n. DotNode n -> n
nodeID DotNode n
a) (forall n. DotNode n -> n
nodeID DotNode n
b) [] forall a. a -> [a] -> [a]
: [DotEdge n]
acc) (DotNode n
bforall a. a -> [a] -> [a]
:[DotNode n]
rest)
newLinesAfter :: String -> Int -> String -> String
newLinesAfter :: String -> Int -> ShowS
newLinesAfter String
esc Int
n String
str = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [a] -> [a]
++ String
esc) (forall e. Int -> [e] -> [[e]]
chunksOf Int
n String
str)