module Compiler.Hoopl.Zipper
( ZBlock(..), ZGraph, ZBody
, frontBiasBlock, backBiasBlock
)
where
import Compiler.Hoopl.Graph
data ZBlock n e x where
ZFirst :: n C O -> ZBlock n C O
ZMiddle :: n O O -> ZBlock n O O
ZLast :: n O C -> ZBlock n O C
ZCat :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
ZHead :: ZBlock n C O -> n O O -> ZBlock n C O
ZTail :: n O O -> ZBlock n O C -> ZBlock n O C
ZClosed :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
type ZGraph = Graph' ZBlock
type ZBody = Body' ZBlock
instance Edges n => Edges (ZBlock n) where
entryLabel (ZFirst n) = entryLabel n
entryLabel (ZHead h _) = entryLabel h
entryLabel (ZClosed h _) = entryLabel h
successors (ZLast n) = successors n
successors (ZTail _ t) = successors t
successors (ZClosed _ t) = successors t
frontBiasBlock :: ZBlock n e x -> ZBlock n e x
frontBiasBlock b@(ZFirst {}) = b
frontBiasBlock b@(ZMiddle {}) = b
frontBiasBlock b@(ZLast {}) = b
frontBiasBlock b@(ZCat {}) = rotate b
where
rotate :: ZBlock n O O -> ZBlock n O O
append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
rotate (ZCat h t) = append h (rotate t)
rotate b@(ZMiddle {}) = b
append b@(ZMiddle {}) t = b `ZCat` t
append (ZCat b1 b2) b3 = b1 `append` (b2 `append` b3)
frontBiasBlock b@(ZHead {}) = b
frontBiasBlock b@(ZTail {}) = b
frontBiasBlock (ZClosed h t) = shiftRight h t
where shiftRight :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
shiftRight (ZHead b1 b2) b3 = shiftRight b1 (ZTail b2 b3)
shiftRight b1@(ZFirst {}) b2 = ZClosed b1 b2
backBiasBlock :: ZBlock n e x -> ZBlock n e x
backBiasBlock b@(ZFirst {}) = b
backBiasBlock b@(ZMiddle {}) = b
backBiasBlock b@(ZLast {}) = b
backBiasBlock b@(ZCat {}) = rotate b
where
rotate :: ZBlock n O O -> ZBlock n O O
append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
rotate (ZCat h t) = append (rotate h) t
rotate b@(ZMiddle {}) = b
append h b@(ZMiddle {}) = h `ZCat` b
append b1 (ZCat b2 b3) = (b1 `append` b2) `append` b3
backBiasBlock b@(ZHead {}) = b
backBiasBlock b@(ZTail {}) = b
backBiasBlock (ZClosed h t) = shiftLeft h t
where shiftLeft :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
shiftLeft b1 (ZTail b2 b3) = shiftLeft (ZHead b1 b2) b3
shiftLeft b1 b2@(ZLast {}) = ZClosed b1 b2