[commit: hoopl] master: Add mapGraph and related functions. (0febb7f)

[Edward Z. Yang]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/hoopl

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/0febb7f04ff4326bd120fc75549845e5e9678d72

>---------------------------------------------------------------

commit 0febb7f04ff4326bd120fc75549845e5e9678d72
Author: Edward Z. Yang <ezyang at mit.edu>
Date:   Tue Apr 12 11:04:08 2011 +0100

    Add mapGraph and related functions.
    
    Signed-off-by: Edward Z. Yang <ezyang at mit.edu>

>---------------------------------------------------------------

 src/Compiler/Hoopl/Graph.hs |   29 ++++++++++++++++++++++++++++-
 1 files changed, 28 insertions(+), 1 deletions(-)

diff --git a/src/Compiler/Hoopl/Graph.hs b/src/Compiler/Hoopl/Graph.hs
index 9fcc707..b6cee3f 100644
--- a/src/Compiler/Hoopl/Graph.hs
+++ b/src/Compiler/Hoopl/Graph.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-}
+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-}
 
 module Compiler.Hoopl.Graph 
   ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)
   , MaybeO(..), MaybeC(..), Shape(..), IndexedCO
   , NonLocal(entryLabel, successors)
   , emptyBody, addBlock, bodyList
+  , mapGraph, mapMaybeO, mapMaybeC, mapBlock
   )
 where
 
@@ -117,3 +118,29 @@ addBlock b body = nodupsInsert (entryLabel b) b body
 
 bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
 bodyList (Body body) = mapToList body
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph _ GNil = GNil
+mapGraph f (GUnit b) = GUnit (mapBlock f b)
+mapGraph f (GMany x y z)
+    = GMany (mapMaybeO f x)
+            (mapMap (mapBlock f) y)
+            (mapMaybeO f z)
+
+mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x)
+mapMaybeO _  NothingO = NothingO
+mapMaybeO f (JustO b) = JustO (mapBlock f b)
+
+mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x)
+mapMaybeC _  NothingC = NothingC
+mapMaybeC f (JustC b) = JustC (mapBlock f b)
+
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BFirst n)      = BFirst  (f n)
+mapBlock f (BMiddle n)     = BMiddle (f n)
+mapBlock f (BLast n)       = BLast   (f n)
+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BHead b n)     = BHead   (mapBlock f b)  (f n)
+mapBlock f (BTail n b)     = BTail   (f n)  (mapBlock f b)
+mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2)