{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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 :: TermLab fs l -> Graph
renderCfgDot t :: 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 :: 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 :: [(* -> *) -> * -> *]). 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 :: [(* -> *) -> * -> *]) 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 (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 (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 (nId :: Node
nId, _) = NodeId -> [Attribute] -> Statement
Dot.NodeStatement (Node -> NodeId
renderId Node
nId) []

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

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

cfgToFgl :: Cfg fs -> Fgl.Gr Label ()
cfgToFgl :: Cfg fs -> Gr Label ()
cfgToFgl cfg :: Cfg fs
cfg = [LNode Label] -> [LEdge ()] -> Gr Label ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Fgl.mkGraph [LNode Label]
nodes [LEdge ()]
edges
  where
    (nodeLabs :: [Label]
nodeLabs, cfgNodes :: [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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
cfg_nodes)
    nodes :: [Fgl.LNode Label]
    nodes :: [LNode Label]
nodes = [Node] -> [Label] -> [LNode Label]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [Label]
nodeLabs
    nodeMap :: Map Label Node
nodeMap = [(Label, Node)] -> Map Label Node
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Label
lab, Node
id) | (id :: Node
id, lab :: 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
      (\ n :: CfgNode fs
n -> [ Edge -> () -> LEdge ()
forall b. Edge -> b -> LEdge b
Fgl.toLEdge (Map Label Node
nodeMap Map Label Node -> Label -> Node
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab), Map Label Node
nodeMap Map Label Node -> Label -> Node
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_succs) ]
      )
      [CfgNode fs]
cfgNodes

simplify :: (Fgl.DynGraph gr) => gr a () -> gr a ()
simplify :: gr a () -> gr a ()
simplify gr :: 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' :: gr a ()
gr' -> gr a () -> gr a ()
forall (gr :: * -> * -> *) a. DynGraph gr => gr a () -> gr a ()
simplify gr a ()
gr'
    Nothing -> gr a ()
gr

simplifyOnce :: (Fgl.DynGraph gr) => gr a () -> Maybe (gr a ())
simplifyOnce :: gr a () -> Maybe (gr a ())
simplifyOnce gr :: gr a ()
gr =
    case [Edge]
nodeLikeEdges of
      ((s :: Node
s, t :: Node
t) : _) ->
        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
$ Node -> gr a () -> gr a ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> gr a b
Fgl.delNode Node
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 (Node
s, Node
u) () | Node
u <- gr a () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
Fgl.suc gr a ()
gr Node
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 (\ (s :: Node
s, t :: Node
t) -> gr a () -> Node -> Node
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Node
Fgl.outdeg gr a ()
gr Node
s Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&& gr a () -> Node -> Node
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Node
Fgl.indeg gr a ()
gr Node
t Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== 1) (gr a () -> [Edge]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Edge]
Fgl.edges gr a ()
gr)