{-# 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       --  Where to store the graph
                                       --  (note: file extensions are not checked)
    , GraphOptions -> GraphvizOutput
graphvizOutput :: GraphvizOutput --  output formats (like Jpeg, Png ..)
    }

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

        -- create barrier nodes

        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)]
                        }

        -- create preffix

        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

        -- create suffixes

        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

        -- create barrier edges

        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 = [] -- [HeadPort (LabelledPort (PN {portName = "1"}) Nothing)]]
                    }]

        -- create dot graph

        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 = [] -- do we want to put commands with same pid on the same group?
                    , 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)