module Cubix.Language.Parametric.Semantics.Cfg.CfgDot (
    renderCfgDot
  ) where

import qualified Data.Graph.Inductive.Graph as Fgl
import qualified Data.Graph.Inductive.PatriciaTree as Fgl
import qualified Data.Map as Map
import qualified Data.Set as Set

import Control.Lens ((^.))

import qualified Language.Dot.Syntax as Dot

import Cubix.Language.Info
import Cubix.Language.Parametric.Semantics.Cfg.CfgConstruction
import Cubix.Language.Parametric.Semantics.Cfg.Graph

renderCfgDot :: forall fs l. (CfgBuilder fs) => TermLab fs l -> Dot.Graph
renderCfgDot :: forall (fs :: Signature) l. CfgBuilder fs => TermLab fs l -> Graph
renderCfgDot TermLab fs l
t = GraphStrictness
-> GraphDirectedness -> Maybe Id -> [Statement] -> Graph
Dot.Graph GraphStrictness
Dot.StrictGraph GraphDirectedness
Dot.DirectedGraph Maybe Id
forall a. Maybe a
Nothing ([Statement]
nodeStmts [Statement] -> [Statement] -> [Statement]
forall a. [a] -> [a] -> [a]
++ [Statement]
edgeStmts)
  where
    cfg :: (CfgBuilder fs) => Fgl.Gr Label ()
    cfg :: CfgBuilder fs => Gr Label ()
cfg = Gr Label () -> Gr Label ()
forall (gr :: * -> * -> *) a. DynGraph gr => gr a () -> gr a ()
simplify (Gr Label () -> Gr Label ()) -> Gr Label () -> Gr Label ()
forall a b. (a -> b) -> a -> b
$ Cfg fs -> Gr Label ()
forall (fs :: Signature). Cfg fs -> Gr Label ()
cfgToFgl (Cfg fs -> Gr Label ()) -> Cfg fs -> Gr Label ()
forall a b. (a -> b) -> a -> b
$ (TermLab fs l -> Cfg fs
forall (fs :: Signature) l. CfgBuilder fs => TermLab fs l -> Cfg fs
makeCfg TermLab fs l
t)

    nodeStmts :: [Dot.Statement]
    nodeStmts :: [Statement]
nodeStmts = (LNode Label -> Statement) -> [LNode Label] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map LNode Label -> Statement
renderNode ([LNode Label] -> [Statement]) -> [LNode Label] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Gr Label () -> [LNode Label]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
Fgl.labNodes Gr Label ()
CfgBuilder fs => Gr Label ()
cfg

    edgeStmts :: [Dot.Statement]
    edgeStmts :: [Statement]
edgeStmts = (LEdge () -> Statement) -> [LEdge ()] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map LEdge () -> Statement
renderEdge ([LEdge ()] -> [Statement]) -> [LEdge ()] -> [Statement]
forall a b. (a -> b) -> a -> b
$ Gr Label () -> [LEdge ()]
forall a b. Gr a b -> [LEdge b]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
Fgl.labEdges Gr Label ()
CfgBuilder fs => Gr Label ()
cfg

renderNode :: Fgl.LNode Label -> Dot.Statement
renderNode :: LNode Label -> Statement
renderNode (Int
nId, Label
_) = NodeId -> [Attribute] -> Statement
Dot.NodeStatement (Int -> NodeId
renderId Int
nId) []

renderEdge :: Fgl.LEdge () -> Dot.Statement
renderEdge :: LEdge () -> Statement
renderEdge (Int
a, Int
b, ()
_) =
    [Entity] -> [Attribute] -> Statement
Dot.EdgeStatement [Entity
ea, Entity
eb] []
  where
    ea :: Entity
ea = EdgeType -> NodeId -> Entity
Dot.ENodeId EdgeType
Dot.NoEdge (Int -> NodeId
renderId Int
a)
    eb :: Entity
eb = EdgeType -> NodeId -> Entity
Dot.ENodeId EdgeType
Dot.DirectedEdge (Int -> NodeId
renderId Int
b)

renderId :: Int -> Dot.NodeId
renderId :: Int -> NodeId
renderId Int
nId = Id -> Maybe Port -> NodeId
Dot.NodeId (String -> Id
Dot.NameId (String -> Id) -> String -> Id
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
nId) Maybe Port
forall a. Maybe a
Nothing

cfgToFgl :: Cfg fs -> Fgl.Gr Label ()
cfgToFgl :: forall (fs :: Signature). Cfg fs -> Gr Label ()
cfgToFgl Cfg fs
cfg = [LNode Label] -> [LEdge ()] -> Gr Label ()
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Fgl.mkGraph [LNode Label]
nodes [LEdge ()]
edges
  where
    ([Label]
nodeLabs, [CfgNode fs]
cfgNodes) = [(Label, CfgNode fs)] -> ([Label], [CfgNode fs])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Label, CfgNode fs)] -> ([Label], [CfgNode fs]))
-> [(Label, CfgNode fs)] -> ([Label], [CfgNode fs])
forall a b. (a -> b) -> a -> b
$ Map Label (CfgNode fs) -> [(Label, CfgNode fs)]
forall k a. Map k a -> [(k, a)]
Map.toList (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
-> Map Label (CfgNode fs)
forall s a. s -> Getting a s a -> a
^. Getting (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes)
    nodes :: [Fgl.LNode Label]
    nodes :: [LNode Label]
nodes = [Int] -> [Label] -> [LNode Label]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Label]
nodeLabs
    nodeMap :: Map Label Int
nodeMap = [(Label, Int)] -> Map Label Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Label
lab, Int
id) | (Int
id, Label
lab) <- [LNode Label]
nodes]
    edges :: [Fgl.LEdge ()]
    edges :: [LEdge ()]
edges = (CfgNode fs -> [LEdge ()]) -> [CfgNode fs] -> [LEdge ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\ CfgNode fs
n -> [ Edge -> () -> LEdge ()
forall b. Edge -> b -> LEdge b
Fgl.toLEdge (Map Label Int
nodeMap Map Label Int -> Label -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! (CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab), Map Label Int
nodeMap Map Label Int -> Label -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Label
t) ()
              | Label
t <- Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs) ]
      )
      [CfgNode fs]
cfgNodes

simplify :: (Fgl.DynGraph gr) => gr a () -> gr a ()
simplify :: forall (gr :: * -> * -> *) a. DynGraph gr => gr a () -> gr a ()
simplify gr a ()
gr =
  case gr a () -> Maybe (gr a ())
forall (gr :: * -> * -> *) a.
DynGraph gr =>
gr a () -> Maybe (gr a ())
simplifyOnce gr a ()
gr of
    Just gr a ()
gr' -> gr a () -> gr a ()
forall (gr :: * -> * -> *) a. DynGraph gr => gr a () -> gr a ()
simplify gr a ()
gr'
    Maybe (gr a ())
Nothing -> gr a ()
gr

simplifyOnce :: (Fgl.DynGraph gr) => gr a () -> Maybe (gr a ())
simplifyOnce :: forall (gr :: * -> * -> *) a.
DynGraph gr =>
gr a () -> Maybe (gr a ())
simplifyOnce gr a ()
gr =
    case [Edge]
nodeLikeEdges of
      ((Int
s, Int
t) : [Edge]
_) ->
        gr a () -> Maybe (gr a ())
forall a. a -> Maybe a
Just (gr a () -> Maybe (gr a ())) -> gr a () -> Maybe (gr a ())
forall a b. (a -> b) -> a -> b
$ Int -> gr a () -> gr a ()
forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> gr a b
Fgl.delNode Int
t (gr a () -> gr a ()) -> gr a () -> gr a ()
forall a b. (a -> b) -> a -> b
$ [LEdge ()] -> gr a () -> gr a ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
Fgl.insEdges [Edge -> () -> LEdge ()
forall b. Edge -> b -> LEdge b
Fgl.toLEdge (Int
s, Int
u) () | Int
u <- gr a () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
Fgl.suc gr a ()
gr Int
t] gr a ()
gr
      [] ->
        Maybe (gr a ())
forall a. Maybe a
Nothing
  where
    nodeLikeEdges :: [Edge]
nodeLikeEdges = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (Int
s, Int
t) -> gr a () -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
Fgl.outdeg gr a ()
gr Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& gr a () -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
Fgl.indeg gr a ()
gr Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (gr a () -> [Edge]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Edge]
Fgl.edges gr a ()
gr)