add an FAQ file
[packages/hoopl.git] / prototypes / Zipper.hs
1 {-# LANGUAGE GADTs #-}
2
3 module Compiler.Hoopl.Zipper
4 ( ZBlock(..), ZGraph, ZBody
5 , frontBiasBlock, backBiasBlock
6 )
7 where
8
9 import Compiler.Hoopl.Graph
10
11 data ZBlock n e x where
12 -- nodes
13 ZFirst :: n C O -> ZBlock n C O
14 ZMiddle :: n O O -> ZBlock n O O
15 ZLast :: n O C -> ZBlock n O C
16
17 -- concatenation operations
18 ZCat :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O -- non-list-like
19 ZHead :: ZBlock n C O -> n O O -> ZBlock n C O
20 ZTail :: n O O -> ZBlock n O C -> ZBlock n O C
21
22 ZClosed :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C -- the zipper
23
24 type ZGraph = Graph' ZBlock
25 type ZBody = Body' ZBlock
26
27 instance Edges n => Edges (ZBlock n) where
28 entryLabel (ZFirst n) = entryLabel n
29 entryLabel (ZHead h _) = entryLabel h
30 entryLabel (ZClosed h _) = entryLabel h
31 successors (ZLast n) = successors n
32 successors (ZTail _ t) = successors t
33 successors (ZClosed _ t) = successors t
34
35
36 ----------------------------------------------------------------
37
38 -- | A block is "front biased" if the left child of every
39 -- concatenation operation is a node, not a general block; a
40 -- front-biased block is analogous to an ordinary list. If a block is
41 -- front-biased, then its nodes can be traversed from front to back
42 -- without general recusion; tail recursion suffices. Not all shapes
43 -- can be front-biased; a closed/open block is inherently back-biased.
44
45 frontBiasBlock :: ZBlock n e x -> ZBlock n e x
46 frontBiasBlock b@(ZFirst {}) = b
47 frontBiasBlock b@(ZMiddle {}) = b
48 frontBiasBlock b@(ZLast {}) = b
49 frontBiasBlock b@(ZCat {}) = rotate b
50 where -- rotate and append ensure every left child of ZCat is ZMiddle
51 -- provided 2nd argument to append already has this property
52 rotate :: ZBlock n O O -> ZBlock n O O
53 append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
54 rotate (ZCat h t) = append h (rotate t)
55 rotate b@(ZMiddle {}) = b
56 append b@(ZMiddle {}) t = b `ZCat` t
57 append (ZCat b1 b2) b3 = b1 `append` (b2 `append` b3)
58 frontBiasBlock b@(ZHead {}) = b -- back-biased by nature; cannot fix
59 frontBiasBlock b@(ZTail {}) = b -- statically front-biased
60 frontBiasBlock (ZClosed h t) = shiftRight h t
61 where shiftRight :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
62 shiftRight (ZHead b1 b2) b3 = shiftRight b1 (ZTail b2 b3)
63 shiftRight b1@(ZFirst {}) b2 = ZClosed b1 b2
64
65 -- | A block is "back biased" if the right child of every
66 -- concatenation operation is a node, not a general block; a
67 -- back-biased block is analogous to a snoc-list. If a block is
68 -- back-biased, then its nodes can be traversed from back to back
69 -- without general recusion; tail recursion suffices. Not all shapes
70 -- can be back-biased; an open/closed block is inherently front-biased.
71
72 backBiasBlock :: ZBlock n e x -> ZBlock n e x
73 backBiasBlock b@(ZFirst {}) = b
74 backBiasBlock b@(ZMiddle {}) = b
75 backBiasBlock b@(ZLast {}) = b
76 backBiasBlock b@(ZCat {}) = rotate b
77 where -- rotate and append ensure every right child of ZCat is ZMiddle
78 -- provided 1st argument to append already has this property
79 rotate :: ZBlock n O O -> ZBlock n O O
80 append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
81 rotate (ZCat h t) = append (rotate h) t
82 rotate b@(ZMiddle {}) = b
83 append h b@(ZMiddle {}) = h `ZCat` b
84 append b1 (ZCat b2 b3) = (b1 `append` b2) `append` b3
85 backBiasBlock b@(ZHead {}) = b -- statically back-biased
86 backBiasBlock b@(ZTail {}) = b -- front-biased by nature; cannot fix
87 backBiasBlock (ZClosed h t) = shiftLeft h t
88 where shiftLeft :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
89 shiftLeft b1 (ZTail b2 b3) = shiftLeft (ZHead b1 b2) b3
90 shiftLeft b1 b2@(ZLast {}) = ZClosed b1 b2