blockMapNodes and BlockMapNodes3 get their properly general types
[packages/hoopl.git] / src / Compiler / Hoopl / Util.hs
index faa4956..bda7f06 100644 (file)
@@ -2,8 +2,11 @@
 
 module Compiler.Hoopl.Util
   ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
+  , catGraphNodeOC, catGraphNodeOO
+  , catNodeCOGraph, catNodeOOGraph
   , graphMapBlocks
-  , zblockGraph
+  , blockMapNodes, blockMapNodes3
+  , blockGraph
   , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
   , preorder_dfs, preorder_dfs_from_except
   , labelsDefined, labelsUsed, externalEntryLabels
@@ -13,9 +16,9 @@ where
 
 import Control.Monad
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
-import Compiler.Hoopl.Zipper
 
 
 ----------------------------------------------------------------
@@ -23,22 +26,60 @@ import Compiler.Hoopl.Zipper
 gUnitOO :: block n O O -> Graph' block n O O
 gUnitOC :: block n O C -> Graph' block n O C
 gUnitCO :: block n C O -> Graph' block n C O
-gUnitCC :: block n C C -> Graph' block n C C
+gUnitCC :: Edges (block n) => block n C C -> Graph' block n C C
 gUnitOO b = GUnit b
-gUnitOC b = GMany (JustO b) BodyEmpty   NothingO
-gUnitCO b = GMany NothingO  BodyEmpty   (JustO b)
-gUnitCC b = GMany NothingO  (BodyUnit b) NothingO
+gUnitOC b = GMany (JustO b) emptyBody  NothingO
+gUnitCO b = GMany NothingO  emptyBody (JustO b)
+gUnitCC b = GMany NothingO  (addBlock b $ emptyBody) NothingO
 
-zblockGraph :: ZBlock n e x -> ZGraph n e x
-zblockGraph b@(ZFirst  {}) = gUnitCO b
-zblockGraph b@(ZMiddle {}) = gUnitOO b
-zblockGraph b@(ZLast   {}) = gUnitOC b
-zblockGraph b@(ZCat {})    = gUnitOO b
-zblockGraph b@(ZHead {})   = gUnitCO b
-zblockGraph b@(ZTail {})   = gUnitOC b
-zblockGraph b@(ZClosed {}) = gUnitCC b
 
+catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O
+catGraphNodeOC :: Edges n => Graph n e O -> n O C -> Graph n e C
+catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x
+catNodeCOGraph :: Edges n => n C O -> Graph n O x -> Graph n C x
 
+catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n
+catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n
+catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)
+
+catGraphNodeOC GNil                     n = gUnitOC $ BLast n
+catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n
+  where addToLeft :: Block n O O -> Block n O C -> Block n O C
+        addToLeft (BMiddle m)    g = m `BTail` g
+        addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g
+catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO
+  where body' = addBlock (x `BClosed` BLast n) body
+
+catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n
+catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b
+catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x
+
+catNodeCOGraph n GNil                     = gUnitCO $ BFirst n
+catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b
+  where addToRight :: Block n C O -> Block n O O -> Block n C O
+        addToRight g (BMiddle m)    = g `BHead` m
+        addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2
+catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x
+  where body' = addBlock (BFirst n `BClosed` e) body
+
+
+
+
+
+blockGraph :: Edges n => Block n e x -> Graph n e x
+blockGraph b@(BFirst  {}) = gUnitCO b
+blockGraph b@(BMiddle {}) = gUnitOO b
+blockGraph b@(BLast   {}) = gUnitOC b
+blockGraph b@(BCat {})    = gUnitOO b
+blockGraph b@(BHead {})   = gUnitCO b
+blockGraph b@(BTail {})   = gUnitOC b
+blockGraph b@(BClosed {}) = gUnitCC b
+
+
+-- | Function 'graphMapBlocks' enables a change of representation of blocks,
+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
+-- graph transform.  When the block representation stabilizes, a similar
+-- function should be provided for blocks.
 graphMapBlocks :: forall block n block' n' e x .
                   (forall e x . block n e x -> block' n' e x)
                -> (Graph' block n e x -> Graph' block' n' e x)
@@ -52,11 +93,24 @@ graphMapBlocks f = map
         map (GUnit b) = GUnit (f b)
         map (GMany e b x) = GMany (fmap f e) (bodyMapBlocks f b) (fmap f x)
 
-bodyMapBlocks f = map
-  where map BodyEmpty = BodyEmpty
-        map (BodyUnit b) = BodyUnit (f b)
-        map (BodyCat b1 b2) = BodyCat (map b1) (map b2)
-
+bodyMapBlocks f (Body body) = Body $ mapMap f body
+
+-- | Function 'blockMapNodes' enables a change of nodes in a block.
+blockMapNodes3 :: ( n C O -> n' C O
+                  , n O O -> n' O O
+                  , n O C -> n' O C)
+               -> Block n e x -> Block n' e x
+blockMapNodes3 (f, _, _) (BFirst n)     = BFirst (f n)
+blockMapNodes3 (_, m, _) (BMiddle n)    = BMiddle (m n)
+blockMapNodes3 (_, _, l) (BLast n)      = BLast (l n)
+blockMapNodes3 fs (BCat x y)            = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y)
+blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n)
+blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x)
+blockMapNodes3 fs (BClosed x y)         = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y)
+
+blockMapNodes :: (forall e x. n e x -> n' e x)
+              -> (Block n e x -> Block n' e x)
+blockMapNodes f = blockMapNodes3 (f, f, f)
 
 ----------------------------------------------------------------
 
@@ -70,7 +124,7 @@ instance LabelsPtr Label where
   targetLabels l = [l]
 
 instance LabelsPtr LabelSet where
-  targetLabels = labelSetElems
+  targetLabels = setElems
 
 instance LabelsPtr l => LabelsPtr [l] where
   targetLabels = concatMap targetLabels
@@ -122,8 +176,7 @@ graphDfs :: (Edges (block n))
          -> (Graph' block n O x -> [block n C C])
 graphDfs _     (GNil)    = []
 graphDfs _     (GUnit{}) = []
-graphDfs order (GMany (JustO entry) body _) = order blockenv entry emptyLabelSet
-  where blockenv = bodyMap body
+graphDfs order (GMany (JustO entry) (Body body) _) = order body entry setEmpty
 
 postorder_dfs = graphDfs postorder_dfs_from_except
 preorder_dfs  = graphDfs preorder_dfs_from_except
@@ -135,24 +188,24 @@ postorder_dfs_from_except blocks b visited =
  where
    vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
    vnode block cont acc visited =
-        if elemLabelSet id visited then
+        if setMember id visited then
             cont acc visited
         else
             let cont' acc visited = cont (block:acc) visited in
-            vchildren (get_children block) cont' acc (extendLabelSet visited id)
+            vchildren (get_children block) cont' acc (setInsert id visited)
       where id = entryLabel block
    vchildren bs cont acc visited = next bs acc visited
       where next children acc visited =
                 case children of []     -> cont acc visited
                                  (b:bs) -> vnode b (next bs) acc visited
    get_children block = foldr add_id [] $ targetLabels block
-   add_id id rst = case lookupFact blocks id of
+   add_id id rst = case lookupFact id blocks of
                       Just b -> b : rst
                       Nothing -> rst
 
 postorder_dfs_from
     :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyLabelSet
+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
 
 
 ----------------------------------------------------------------
@@ -163,8 +216,8 @@ mark   :: Label -> VM ()
 instance Monad VM where
   return a = VM $ \visited -> (a, visited)
   m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
-marked l = VM $ \v -> (elemLabelSet l v, v)
-mark   l = VM $ \v -> ((), extendLabelSet v l)
+marked l = VM $ \v -> (setMember l v, v)
+mark   l = VM $ \v -> ((), setInsert l v)
 
 preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]
@@ -179,7 +232,7 @@ preorder_dfs_from_except blocks b visited =
                               bs <- children $ get_children b
                               return $ b `cons` bs
         get_children block = foldr add_id [] $ targetLabels block
-        add_id id rst = case lookupFact blocks id of
+        add_id id rst = case lookupFact id blocks of
                           Just b -> b : rst
                           Nothing -> rst
 
@@ -190,30 +243,28 @@ cons a as tail = a : as tail
 ----------------------------------------------------------------
 
 labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet
-labelsDefined GNil      = emptyLabelSet
-labelsDefined (GUnit{}) = emptyLabelSet
+labelsDefined GNil      = setEmpty
+labelsDefined (GUnit{}) = setEmpty
 labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x
-  where addEntry block labels = extendLabelSet labels (entryLabel block)
+  where addEntry block labels = setInsert (entryLabel block) labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
-        exitLabel NothingO = emptyLabelSet
-        exitLabel (JustO b) = mkLabelSet [entryLabel b]
+        exitLabel NothingO = setEmpty
+        exitLabel (JustO b) = setFromList [entryLabel b]
 
 labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet
-labelsUsed GNil      = emptyLabelSet
-labelsUsed (GUnit{}) = emptyLabelSet
+labelsUsed GNil      = setEmpty
+labelsUsed (GUnit{}) = setEmpty
 labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e
-  where addTargets block labels = foldl extendLabelSet labels (successors block)
+  where addTargets block labels = setInsertList (successors block) labels
         entryTargets :: MaybeO e (block n O C) -> LabelSet
-        entryTargets NothingO = emptyLabelSet
-        entryTargets (JustO b) = addTargets b emptyLabelSet
+        entryTargets NothingO = setEmpty
+        entryTargets (JustO b) = addTargets b setEmpty
 
 foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a
-foldBodyBlocks _ BodyEmpty      = id
-foldBodyBlocks f (BodyUnit b)   = f b
-foldBodyBlocks f (BodyCat b b') = foldBodyBlocks f b . foldBodyBlocks f b'
+foldBodyBlocks f (Body body) z = mapFold f z body
 
 externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet
-externalEntryLabels body = defined `minusLabelSet` used
+externalEntryLabels body = defined `setDifference` used
   where defined = labelsDefined g
         used = labelsUsed g
         g = GMany NothingO body NothingO