never executed always true always false
1 -- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
2 --
3 -- This file is a part of decafc.
4 --
5 -- decafc is free software: you can redistribute it and/or modify it under the
6 -- terms of the MIT (X11) License as described in the LICENSE file.
7 --
8 -- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
9 -- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
10 -- FOR A PARTICULAR PURPOSE. See the X11 license for more details.
11
12 -- Graph -- A graph implementation to help build CFG
13 -- Supports cyclical graphs. Also allows dynamic updates to the graph for
14 -- transformations over CFG.
15 -- TODO: Perhaps we could just use FGL/ALGA?
16
17 module Util.Graph
18 ( empty
19 , Graph(..)
20 , outBound
21 , inBound
22 , lookupNode
23 , nodeToList
24 , edgeToList
25 , alterNode
26 , adjustNode
27 , union
28 , GraphBuilder(..)
29 , addNode
30 , addEdge
31 , deleteNode
32 , deleteEdge
33 , update
34 , build
35 , strictlyDominate
36 , strictlyPostDominate
37 , topologicalTraverse
38 , topologicalTraverseM
39 ) where
40
41 import Control.Lens ((%=))
42 import Control.Monad
43 import Control.Monad.Except
44 import Control.Monad.State
45 import Data.Monoid
46 import Data.Functor
47 import Data.Generics.Labels
48 import Data.List qualified as List
49 import Data.Map (Map)
50 import Data.Map.Strict qualified as Map
51 import Data.Maybe qualified as Maybe
52 import Data.Set (Set)
53 import Data.Set qualified as Set
54 import Data.Text (Text)
55 import Data.Text.Lazy.Builder qualified as Text
56 import GHC.Generics (Generic)
57
58 data Graph ni nd ed = Graph
59 { nodes :: !(Map ni nd),
60 edges :: !(Map (ni, ni) ed)
61 }
62 deriving (Show, Generic)
63
64 type GraphException = Text
65
66 empty :: Graph ni nd ed
67 empty = Graph Map.empty Map.empty
68
69 flattenEdgeTuple :: ((ni, ni), d) -> (ni, ni, d)
70 flattenEdgeTuple ((src, dst), d) = (src, dst, d)
71
72 outBound :: (Eq ni, Ord ni) => ni -> Graph ni nd ed -> [(ni, ni, ed)]
73 outBound idx g = fmap flattenEdgeTuple $
74 Map.toList $ Map.filterWithKey (\(src, _) _ -> src == idx) (edges g)
75
76 inBound :: (Eq ni, Ord ni) => ni -> Graph ni nd ed -> [(ni, ni, ed)]
77 inBound idx g = fmap flattenEdgeTuple $
78 Map.toList $ Map.filterWithKey (\(_, dst) _ -> dst == idx) (edges g)
79
80 lookupNode :: (Eq ni, Ord ni) => ni -> Graph ni nd ed -> Maybe nd
81 lookupNode nid g = Map.lookup nid $ nodes g
82
83 nodeToList :: (Eq ni, Ord ni) => Graph ni nd ed -> [(ni, nd)]
84 nodeToList g = Map.toList $ nodes g
85
86 edgeToList :: (Eq ni, Ord ni) => Graph ni nd ed -> [(ni, ni, ed)]
87 edgeToList g = fmap flattenEdgeTuple $ Map.toList $ edges g
88
89 union :: (Eq ni, Ord ni) => Graph ni nd ed -> Graph ni nd ed -> Graph ni nd ed
90 union g1 g2 =
91 Graph
92 { nodes = nodes g1 `Map.union` nodes g2,
93 edges = edges g1 `Map.union` edges g2
94 }
95
96 newtype GraphBuilder ni nd ed a = GraphBuilder
97 { buildGraph :: (ExceptT GraphException (State (Graph ni nd ed))) a }
98 deriving
99 ( Functor,
100 Applicative,
101 Monad,
102 MonadError GraphException,
103 MonadState (Graph ni nd ed)
104 )
105
106 addNode :: (Eq ni, Ord ni) => ni -> nd -> GraphBuilder ni nd ed ()
107 addNode idx dt = do
108 modify $ \g -> g {nodes = Map.insert idx dt (nodes g)}
109
110 addEdge :: (Eq ni, Ord ni) => ni -> ni -> ed -> GraphBuilder ni nd ed ()
111 addEdge src dst dt = do
112 modify $ \g -> g {edges = Map.insert (src, dst) dt (edges g)}
113
114 deleteNode :: (Eq ni, Ord ni) => ni -> GraphBuilder ni nd ed ()
115 deleteNode n = do
116 g <- get
117 let nodes' = Map.delete n (nodes g)
118 edges' = Map.filterWithKey (\(s, d) _ -> s /= n && d /= n) (edges g)
119 modify $ \g -> g {nodes = nodes', edges = edges'}
120
121 deleteEdge :: (Eq ni, Ord ni) => ni -> ni -> GraphBuilder ni nd ed ()
122 deleteEdge src dst = do
123 g <- get
124 let edges' = Map.delete (src, dst) (edges g)
125 modify $ \g -> g {edges = edges'}
126
127 alterNode :: (Eq ni, Ord ni) => ni -> (Maybe nd -> Maybe nd) -> GraphBuilder ni nd ed ()
128 alterNode nid f = do
129 g <- get
130 let nds = nodes g
131 modify $ \g -> g {nodes = Map.alter f nid nds}
132
133 adjustNode :: (Eq ni, Ord ni) => ni -> (nd -> nd) -> GraphBuilder ni nd ed ()
134 adjustNode nid f = alterNode nid f'
135 where
136 f' Nothing = Nothing
137 f' (Just d) = Just $ f d
138
139 updateEdge :: (Eq ni, Ord ni) => ni -> ni -> ed -> GraphBuilder ni nd ed ()
140 updateEdge src dst d = do
141 deleteEdge src dst
142 addEdge src dst d
143
144 update :: (Eq ni, Ord ni) => GraphBuilder ni nd ed a -> Graph ni nd ed -> Either Text (Graph ni nd ed)
145 update bd init =
146 let (except, g) = (runState $ runExceptT $ buildGraph bd) init
147 in case except of
148 Left except -> Left except
149 Right _ -> Right g
150
151 build :: (Eq ni, Ord ni) => GraphBuilder ni nd ed a -> Either Text (Graph ni nd ed)
152 build bd = update bd empty
153
154 topologicalTraverseM :: (Eq ni, Ord ni, Monad m) => (ni -> nd -> m a) -> Graph ni nd ed -> m [a]
155 topologicalTraverseM f g = sequence $ topologicalTraverse f g
156
157 topologicalTraverse :: (Eq ni, Ord ni) => (ni -> nd -> a) -> Graph ni nd ed -> [a]
158 topologicalTraverse f g@Graph {nodes = nodes} = recurse initIndegree g
159 where
160 initIndegree = Map.mapWithKey (\i d -> length $ inBound i g) nodes
161 findZeroIndegree :: Map ni Int -> [ni]
162 findZeroIndegree m = fmap fst $ Map.toList $ Map.filter (== 0) m
163 updateIndegree i m g =
164 let m' = List.foldl' (\m (_, ni, _) -> Map.adjust (\x -> x - 1) ni m) m $ outBound i g
165 m'' = Map.delete i m'
166 in m''
167 recurse indegree g =
168 let zeroIndegree = findZeroIndegree indegree
169 in case zeroIndegree of
170 [] -> mempty
171 (n : ns) ->
172 let ele = f n (Maybe.fromJust $ lookupNode n g)
173 indegree' = updateIndegree n indegree g
174 in ele : recurse indegree' g
175
176 newtype Memoize ni m a = Memoize
177 { unmem :: State m a
178 }
179 deriving (Functor, Applicative, Monad, MonadState m)
180
181 data Memory ni = Memory
182 { processing :: !(Set ni),
183 finished :: !(Map ni (Set ni))
184 }
185 deriving (Generic)
186
187 recurse_ :: (Eq ni, Ord ni) => (ni -> Graph ni nd ed -> [ni]) -> ni -> Graph ni nd ed -> Memoize ni (Memory ni) (Set ni)
188 recurse_ f idx g = do
189 (Memory processing finished) <- get
190 #processing %= Set.insert idx
191 case Map.lookup idx finished of
192 Just res -> return res
193 Nothing -> do
194 let direct = f idx g
195 -- Avoid infinite loops by ignoring nodes being processed in the stack
196 indirect <- mapM (\i -> recurse_ f i g) (filter (`Set.notMember` processing) direct)
197 let res = Set.union (Set.fromList direct) (Set.unions indirect)
198 #finished %= Map.insert idx res
199 return res
200
201 strictlyDominate :: (Eq ni, Ord ni) => ni -> Graph ni nd ed -> Set ni
202 strictlyDominate idx g =
203 evalState (unmem $ recurse_ (\i g -> outBound i g <&> \(_, dst, _) -> dst) idx g) (Memory Set.empty Map.empty)
204
205 strictlyPostDominate :: (Eq ni, Ord ni) => ni -> Graph ni nd ed -> Set ni
206 strictlyPostDominate idx g =
207 evalState (unmem $ recurse_ (\i g -> inBound i g <&> \(src, _, _) -> src) idx g) (Memory Set.empty Map.empty)