{-# 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)