2f06aba94c79dfa7082a034b3cd52a9de50cf10c
[packages/hoopl.git] / src / Compiler / Hoopl / XUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5
6 -- | Utilities for clients of Hoopl, not used internally.
7
8 module Compiler.Hoopl.XUtil
9 (
10 -- * Utilities for clients
11
12 -- ** Simple operations on blocks
13 isEmptyBlock
14 , firstNode, lastNode, endNodes
15 , blockSplitHead, blockSplitTail, blockSplit
16 , blockJoinHead, blockJoinTail, blockJoin
17 , blockAppend
18 , replaceFirstNode, replaceLastNode
19 , blockToList, blockFromList
20
21 -- ** Other operations
22 , {- firstXfer, distributeXfer
23 , -} distributeFact, distributeFactBwd
24 , successorFacts
25 , joinFacts
26 , joinOutFacts -- deprecated
27 , joinMaps
28 , foldGraphNodes
29 , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3
30 {-
31 , tfFoldBlock
32 , ScottBlock(ScottBlock), scottFoldBlock
33 , fbnf3
34 -}
35 , blockToNodeList, blockOfNodeList
36 , blockToNodeList' -- alternate version using fold
37 {-, blockToNodeList'' -- alternate version using scottFoldBlock
38 , blockToNodeList''' -- alternate version using tfFoldBlock
39 , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
40 , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
41 , noEntries
42 , BlockResult(..), lookupBlock-}
43 )
44 where
45
46 import qualified Data.Map as M
47 import Data.Maybe
48
49 import Compiler.Hoopl.Checkpoint
50 import Compiler.Hoopl.Collections
51 import Compiler.Hoopl.Dataflow
52 import Compiler.Hoopl.Graph
53 import Compiler.Hoopl.GraphUtil
54 import Compiler.Hoopl.Label
55 import Compiler.Hoopl.Util
56
57 -- -----------------------------------------------------------------------------
58 -- Simple operations on Blocks
59
60 isEmptyBlock :: Block n e x -> Bool
61 isEmptyBlock BNil = True
62 isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
63 isEmptyBlock _ = False
64
65
66 firstNode :: Block n C x -> n C O
67 firstNode (BlockCO n _) = n
68 firstNode (BlockCC n _ _) = n
69
70 lastNode :: Block n x C -> n O C
71 lastNode (BlockOC _ n) = n
72 lastNode (BlockCC _ _ n) = n
73
74 endNodes :: Block n C C -> (n C O, n O C)
75 endNodes (BlockCC f _ l) = (f,l)
76
77
78 blockSplitHead :: Block n C x -> (n C O, Block n O x)
79 blockSplitHead (BlockCO n b) = (n, b)
80 blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
81
82 blockSplitTail :: Block n e C -> (Block n e O, n O C)
83 blockSplitTail (BlockOC b n) = (b, n)
84 blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
85
86 blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
87 blockSplit (BlockCC f b t) = (f, b, t)
88
89 blockJoinHead :: n C O -> Block n O x -> Block n C x
90 blockJoinHead f (BlockOC b l) = BlockCC f b l
91 blockJoinHead f b = BlockCO f BNil `cat` b
92
93 blockJoinTail :: Block n e O -> n O C -> Block n e C
94 blockJoinTail (BlockCO f b) t = BlockCC f b t
95 blockJoinTail b t = b `cat` BlockOC BNil t
96
97 blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
98 blockJoin f b t = BlockCC f b t
99
100 blockAppend :: Block n e O -> Block n O x -> Block n e x
101 blockAppend = cat
102
103 replaceFirstNode :: Block n C x -> n C O -> Block n C x
104 replaceFirstNode (BlockCO _ b) f = BlockCO f b
105 replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
106
107 replaceLastNode :: Block n x C -> n O C -> Block n x C
108 replaceLastNode (BlockOC b _) n = BlockOC b n
109 replaceLastNode (BlockCC l b _) n = BlockCC l b n
110
111
112 blockToList :: Block n O O -> [n O O]
113 blockToList b = go b []
114 where go :: Block n O O -> [n O O] -> [n O O]
115 go BNil r = r
116 go (BMiddle n) r = n : r
117 go (BCat b1 b2) r = go b1 $! go b2 r
118 go (BHead b1 n) r = go b1 (n:r)
119 go (BTail n b1) r = n : go b1 r
120
121 blockFromList :: [n O O] -> Block n O O
122 blockFromList = foldr BTail BNil
123
124 -----------------------------------------------------------------------------
125
126 {-
127
128 -- | Forward dataflow analysis and rewriting for the special case of a Body.
129 -- A set of entry points must be supplied; blocks not reachable from
130 -- the set are thrown away.
131 analyzeAndRewriteFwdBody
132 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
133 => FwdPass m n f
134 -> entries -> Body n -> FactBase f
135 -> m (Body n, FactBase f)
136
137 -- | Backward dataflow analysis and rewriting for the special case of a Body.
138 -- A set of entry points must be supplied; blocks not reachable from
139 -- the set are thrown away.
140 analyzeAndRewriteBwdBody
141 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
142 => BwdPass m n f
143 -> entries -> Body n -> FactBase f
144 -> m (Body n, FactBase f)
145
146 analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))
147 analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))
148
149 mapBodyFacts :: (Monad m)
150 => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f))
151 -> (Body n -> FactBase f -> m (Body n, FactBase f))
152 -- ^ Internal utility; should not escape
153 mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts
154 where -- the type constraint is needed for the pattern match;
155 -- if it were not, we would use do-notation here.
156 bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)
157 bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)
158
159 {-
160 Can't write:
161
162 do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f
163 return (body, fb)
164
165 because we need an explicit type signature in order to do the GADT
166 pattern matches on NothingO
167 -}
168
169
170
171 -- | Forward dataflow analysis and rewriting for the special case of a
172 -- graph open at the entry. This special case relieves the client
173 -- from having to specify a type signature for 'NothingO', which beginners
174 -- might find confusing and experts might find annoying.
175 analyzeAndRewriteFwdOx
176 :: forall m n f x. (CheckpointMonad m, NonLocal n)
177 => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f)
178
179 -- | Backward dataflow analysis and rewriting for the special case of a
180 -- graph open at the entry. This special case relieves the client
181 -- from having to specify a type signature for 'NothingO', which beginners
182 -- might find confusing and experts might find annoying.
183 analyzeAndRewriteBwdOx
184 :: forall m n f x. (CheckpointMonad m, NonLocal n)
185 => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f)
186
187 -- | A value that can be used for the entry point of a graph open at the entry.
188 noEntries :: MaybeC O Label
189 noEntries = NothingC
190
191 analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f
192 analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip
193 where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)
194 strip (a, b, JustO c) = return (a, b, c)
195
196
197
198
199
200 -- | A utility function so that a transfer function for a first
201 -- node can be given just a fact; we handle the lookup. This
202 -- function is planned to be made obsolete by changes in the dataflow
203 -- interface.
204
205 firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)
206 firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb
207
208 -- | This utility function handles a common case in which a transfer function
209 -- produces a single fact out of a last node, which is then distributed
210 -- over the outgoing edges.
211 distributeXfer :: NonLocal n
212 => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f)
213 distributeXfer lattice xfer n f =
214 mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
215
216 -}
217 -- | This utility function handles a common case in which a transfer function
218 -- for a last node takes the incoming fact unchanged and simply distributes
219 -- that fact over the outgoing edges.
220 distributeFact :: NonLocal n => n O C -> f -> FactBase f
221 distributeFact n f = mapFromList [ (l, f) | l <- successors n ]
222 -- because the same fact goes out on every edge,
223 -- there's no need for 'mkFactBase' here.
224
225 -- | This utility function handles a common case in which a backward transfer
226 -- function takes the incoming fact unchanged and tags it with the node's label.
227 distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f
228 distributeFactBwd n f = mapSingleton (entryLabel n) f
229
230 -- | List of (unlabelled) facts from the successors of a last node
231 successorFacts :: NonLocal n => n O C -> FactBase f -> [f]
232 successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]
233
234 -- | Join a list of facts.
235 joinFacts :: DataflowLattice f -> Label -> [f] -> f
236 joinFacts lat inBlock = foldr extend (fact_bot lat)
237 where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new)
238
239 {-# DEPRECATED joinOutFacts
240 "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-}
241
242 joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f
243 joinOutFacts lat n f = foldr join (fact_bot lat) facts
244 where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new)
245 facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact]
246
247
248 -- | It's common to represent dataflow facts as a map from variables
249 -- to some fact about the locations. For these maps, the join
250 -- operation on the map can be expressed in terms of the join on each
251 -- element of the codomain:
252 joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)
253 joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new
254 where
255 add k new_v (ch, joinmap) =
256 case M.lookup k joinmap of
257 Nothing -> (SomeChange, M.insert k new_v joinmap)
258 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
259 (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)
260 (NoChange, _) -> (ch, joinmap)
261
262
263 {-
264
265 -- | A fold function that relies on the IndexedCO type function.
266 -- Note that the type parameter e is available to the functions
267 -- that are applied to the middle and last nodes.
268 tfFoldBlock :: forall n bc bo c e x .
269 ( n C O -> bc
270 , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo
271 , n O C -> IndexedCO e bc bo -> c)
272 -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo))
273 tfFoldBlock (f, m, l) bl bo = block bl
274 where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo)
275 block (BFirst n) = f n
276 block (BMiddle n) = m n bo
277 block (BLast n) = l n bo
278 block (b1 `BCat` b2) = oblock b2 $ block b1
279 block (b1 `BClosed` b2) = oblock b2 $ block b1
280 block (b1 `BHead` n) = m n $ block b1
281 block (n `BTail` b2) = oblock b2 $ m n bo
282 oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo)
283 oblock (BMiddle n) = m n
284 oblock (BLast n) = l n
285 oblock (b1 `BCat` b2) = oblock b1 `cat` oblock b2
286 oblock (n `BTail` b2) = m n `cat` oblock b2
287 cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
288 cat f f' = f' . f
289
290
291 type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))
292 blockToNodeList''' ::
293 forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n
294 , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>
295 Block n e x -> NodeList' e x n
296 blockToNodeList''' b = (h, reverse ms', t)
297 where
298 (h, ms', t) = tfFoldBlock (f, m, l) b z
299 z :: NodeList' O O n
300 z = (NothingC, [], NothingC)
301 f :: n C O -> NodeList' C O n
302 f n = (JustC n, [], NothingC)
303 m n (h, ms', t) = (h, n : ms', t)
304 l n (h, ms', _) = (h, ms', JustC n)
305
306
307 {-
308 data EitherCO' ex a b where
309 LeftCO :: a -> EitherCO' C a b
310 RightCO :: b -> EitherCO' O a b
311 -}
312
313 -- should be done with a *backward* fold
314
315 -- | More general fold
316
317 _unused :: Int
318 _unused = 3
319 where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)
320 _b = foldBlockNodesF3'
321
322 data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b
323 , fm :: n O O -> b -> b
324 , fl :: forall x . MaybeC x (n O C) -> b -> c
325 }
326
327 foldBlockNodesF3'' :: forall n a b c .
328 Trips n a b c -> (forall e x . Block n e x -> a -> c)
329 foldBlockNodesF3'' trips = block
330 where block :: Block n e x -> a -> c
331 block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2
332 block (BFirst node) = ff trips (JustC node) `cat` missingLast
333 block (b @ BHead {}) = foldCO b `cat` missingLast
334 block (BMiddle node) = missingFirst `cat` fm trips node `cat` missingLast
335 block (b @ BCat {}) = missingFirst `cat` foldOO b `cat` missingLast
336 block (BLast node) = missingFirst `cat` fl trips (JustC node)
337 block (b @ BTail {}) = missingFirst `cat` foldOC b
338 missingLast = fl trips NothingC
339 missingFirst = ff trips NothingC
340 foldCO :: Block n C O -> a -> b
341 foldOO :: Block n O O -> b -> b
342 foldOC :: Block n O C -> b -> c
343 foldCO (BFirst n) = ff trips (JustC n)
344 foldCO (BHead b n) = foldCO b `cat` fm trips n
345 foldOO (BMiddle n) = fm trips n
346 foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2
347 foldOC (BLast n) = fl trips (JustC n)
348 foldOC (BTail n b) = fm trips n `cat` foldOC b
349 cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
350 f `cat` g = g . f
351
352 data ScottBlock n a = ScottBlock
353 { sb_first :: n C O -> a C O
354 , sb_mid :: n O O -> a O O
355 , sb_last :: n O C -> a O C
356 , sb_cat :: forall e x . a e O -> a O x -> a e x
357 }
358
359 scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x
360 scottFoldBlock funs = block
361 where block :: forall e x . Block n e x -> a e x
362 block (BFirst n) = sb_first funs n
363 block (BMiddle n) = sb_mid funs n
364 block (BLast n) = sb_last funs n
365 block (BClosed b1 b2) = block b1 `cat` block b2
366 block (BCat b1 b2) = block b1 `cat` block b2
367 block (BHead b n) = block b `cat` sb_mid funs n
368 block (BTail n b) = sb_mid funs n `cat` block b
369 cat :: forall e x. a e O -> a O x -> a e x
370 cat = sb_cat funs
371
372 newtype NodeList n e x
373 = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }
374
375 fbnf3 :: forall n a b c .
376 ( n C O -> a -> b
377 , n O O -> b -> b
378 , n O C -> b -> c)
379 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
380 fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block
381 where f n = FF3 $ ff n
382 m n = FF3 $ fm n
383 l n = FF3 $ fl n
384 -- XXX Ew.
385 cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.
386 (IndexedCO x c b ~ IndexedCO t9 t7 t6,
387 IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,
388 IndexedCO t3 t t1 ~ IndexedCO e a b) =>
389 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x
390 FF3 f `cat` FF3 f' = FF3 $ f' . f
391
392 newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }
393
394 blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
395 blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
396 where f n = NL (JustC n, id, NothingC)
397 m n = NL (NothingC, (n:), NothingC)
398 l n = NL (NothingC, id, JustC n)
399 cat :: forall n t1 t3. NodeList n t1 O -> NodeList n O t3 -> NodeList n t1 t3
400 NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)
401 finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)
402 finish (e, ms, x) = (e, ms [], x)
403
404
405 -}
406
407 blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
408 blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()
409 where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e
410 fm :: forall n e. n O O -> PNL n e -> PNL n e
411 fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x
412 ff n () = PNL (n, [])
413 fm n (PNL (first, mids')) = PNL (first, n : mids')
414 fl n (PNL (first, mids')) = FNL (first, reverse mids', n)
415
416 -- newtypes for 'partial node list' and 'final node list'
417 newtype PNL n e = PNL (MaybeC e (n C O), [n O O])
418 newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}
419
420 foldBlockNodesF3''' :: forall n a b c .
421 (forall e . MaybeC e (n C O) -> a -> b e)
422 -> (forall e . n O O -> b e -> b e)
423 -> (forall e x . MaybeC x (n O C) -> b e -> c e x)
424 -> (forall e x . Block n e x -> a -> c e x)
425 foldBlockNodesF3''' ff fm fl = block
426 where
427 block :: forall e x . Block n e x -> a -> c e x
428 block (BlockCO f b) = ff (JustC f) `cat` blockOO b `cat` fl NothingC
429 block (BlockCC f b l) = ff (JustC f) `cat` blockOO b `cat` fl (JustC l)
430 block (BlockOC b l) = ff NothingC `cat` blockOO b `cat` fl (JustC l)
431 block BNil = ff NothingC `cat` fl NothingC
432 block (BMiddle n) = ff NothingC `cat` fm n `cat` fl NothingC
433 block b@BCat{} = ff NothingC `cat` blockOO b `cat` fl NothingC
434 block b@BHead{} = ff NothingC `cat` blockOO b `cat` fl NothingC
435 block b@BTail{} = ff NothingC `cat` blockOO b `cat` fl NothingC
436
437 blockOO :: forall e . Block n O O -> b e -> b e
438 blockOO BNil = id
439 blockOO (BMiddle n) = fm n
440 blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
441 blockOO (BHead b1 n) = blockOO b1 `cat` fm n
442 blockOO (BTail n b1) = fm n `cat` blockOO b1
443
444 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
445 f `cat` g = g . f
446
447 {-
448 -- | The following function is easy enough to define but maybe not so useful
449 foldBlockNodesF3' :: forall n a b c .
450 ( n C O -> a -> b
451 , n O O -> b -> b
452 , n O C -> b -> c)
453 -> (a -> b) -- called iff there is no first node
454 -> (b -> c) -- called iff there is no last node
455 -> (forall e x . Block n e x -> a -> c)
456 foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block
457 where block :: forall e x . Block n e x -> a -> c
458 blockCO :: Block n C O -> a -> b
459 blockOO :: Block n O O -> b -> b
460 blockOC :: Block n O C -> b -> c
461 block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2
462 block (BFirst node) = ff node `cat` missingLast
463 block (b @ BHead {}) = blockCO b `cat` missingLast
464 block (BMiddle node) = missingFirst `cat` fm node `cat` missingLast
465 block (b @ BCat {}) = missingFirst `cat` blockOO b `cat` missingLast
466 block (BLast node) = missingFirst `cat` fl node
467 block (b @ BTail {}) = missingFirst `cat` blockOC b
468 blockCO (BFirst n) = ff n
469 blockCO (BHead b n) = blockCO b `cat` fm n
470 blockOO (BMiddle n) = fm n
471 blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
472 blockOC (BLast n) = fl n
473 blockOC (BTail n b) = fm n `cat` blockOC b
474 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
475 f `cat` g = g . f
476 -}
477
478 -- | Fold a function over every node in a block, forward or backward.
479 -- The fold function must be polymorphic in the shape of the nodes.
480 foldBlockNodesF3 :: forall n a b c .
481 ( n C O -> a -> b
482 , n O O -> b -> b
483 , n O C -> b -> c)
484 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
485 foldBlockNodesF :: forall n a .
486 (forall e x . n e x -> a -> a)
487 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
488 foldBlockNodesB3 :: forall n a b c .
489 ( n C O -> b -> c
490 , n O O -> b -> b
491 , n O C -> a -> b)
492 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
493 foldBlockNodesB :: forall n a .
494 (forall e x . n e x -> a -> a)
495 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
496 -- | Fold a function over every node in a graph.
497 -- The fold function must be polymorphic in the shape of the nodes.
498
499 foldGraphNodes :: forall n a .
500 (forall e x . n e x -> a -> a)
501 -> (forall e x . Graph n e x -> a -> a)
502
503
504 foldBlockNodesF3 (ff, fm, fl) = block
505 where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
506 block (BlockCO f b ) = ff f `cat` block b
507 block (BlockCC f b l) = ff f `cat` block b `cat` fl l
508 block (BlockOC b l) = block b `cat` fl l
509 block BNil = id
510 block (BMiddle node) = fm node
511 block (b1 `BCat` b2) = block b1 `cat` block b2
512 block (b1 `BHead` n) = block b1 `cat` fm n
513 block (n `BTail` b2) = fm n `cat` block b2
514 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
515 cat f f' = f' . f
516
517 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
518
519 foldBlockNodesB3 (ff, fm, fl) = block
520 where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
521 block (BlockCO f b ) = ff f `cat` block b
522 block (BlockCC f b l) = ff f `cat` block b `cat` fl l
523 block (BlockOC b l) = block b `cat` fl l
524 block BNil = id
525 block (BMiddle node) = fm node
526 block (b1 `BCat` b2) = block b1 `cat` block b2
527 block (b1 `BHead` n) = block b1 `cat` fm n
528 block (n `BTail` b2) = fm n `cat` block b2
529 cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
530 cat f f' = f . f'
531
532 foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
533
534 foldGraphNodes f = graph
535 where graph :: forall e x . Graph n e x -> a -> a
536 lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
537
538 graph GNil = id
539 graph (GUnit b) = block b
540 graph (GMany e b x) = lift block e . body b . lift block x
541 body :: Body n -> a -> a
542 body bdy = \a -> mapFold block a bdy
543 lift _ NothingO = id
544 lift f (JustO thing) = f thing
545
546 block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
547 block = foldBlockNodesF f
548
549 {-
550 {-# DEPRECATED blockToNodeList, blockOfNodeList
551 "What justifies these functions? Can they be eliminated? Replaced with folds?" #-}
552 -}
553
554
555 -- | Convert a block to a list of nodes. The entry and exit node
556 -- is or is not present depending on the shape of the block.
557 --
558 -- The blockToNodeList function cannot be currently expressed using
559 -- foldBlockNodesB, because it returns IndexedCO e a b, which means
560 -- two different types depending on the shape of the block entry.
561 -- But blockToNodeList returns one of four possible types, depending
562 -- on the shape of the block entry *and* exit.
563 blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
564 blockToNodeList block = case block of
565 BlockCO f b -> (JustC f, blockToList b, NothingC)
566 BlockCC f b l -> (JustC f, blockToList b, JustC l)
567 BlockOC b l -> (NothingC, blockToList b, JustC l)
568 BNil -> (NothingC, [], NothingC)
569 BMiddle n -> (NothingC, [n], NothingC)
570 b@BCat{} -> (NothingC, blockToList b, NothingC)
571 b@BTail{} -> (NothingC, blockToList b, NothingC)
572 b@BHead{} -> (NothingC, blockToList b, NothingC)
573
574 -- | Convert a list of nodes to a block. The entry and exit node
575 -- must or must not be present depending on the shape of the block.
576 blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x
577 blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"
578 blockOfNodeList (NothingC, m, NothingC) = blockFromList m
579 blockOfNodeList (NothingC, m, JustC l) = BlockOC (blockFromList m) l
580 blockOfNodeList (JustC f, m, NothingC) = BlockCO f (blockFromList m)
581 blockOfNodeList (JustC f, m, JustC l) = BlockCC f (blockFromList m) l
582 {-
583 data BlockResult n x where
584 NoBlock :: BlockResult n x
585 BodyBlock :: Block n C C -> BlockResult n x
586 ExitBlock :: Block n C O -> BlockResult n O
587
588 lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x
589 lookupBlock (GMany _ _ (JustO exit)) lbl
590 | entryLabel exit == lbl = ExitBlock exit
591 lookupBlock (GMany _ body _) lbl =
592 case mapLookup lbl body of
593 Just b -> BodyBlock b
594 Nothing -> NoBlock
595 lookupBlock GNil _ = NoBlock
596 lookupBlock (GUnit _) _ = NoBlock
597 -}