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