1{-|
2A zipper is a structure for walking a value and manipulating it in constant time.
3
4This module was inspired by the paper:
5/Michael D. Adams. Scrap Your Zippers: A Generic Zipper for Heterogeneous Types, Workshop on Generic Programming 2010/.
6-}
7
8
9module Data.Generics.Uniplate.Zipper(
10    -- * Create a zipper and get back the value
11    Zipper, zipper, zipperBi, fromZipper,
12    -- * Navigate within a zipper
13    left, right, up, down,
14    -- * Manipulate the zipper hole
15    hole, replaceHole
16    ) where
17
18import Data.Generics.Uniplate.Operations
19import Data.Generics.Str
20import Control.Monad
21import Data.Maybe
22
23
24-- | Create a zipper, focused on the top-left value.
25zipper :: Uniplate to => to -> Zipper to to
26zipper = fromJust . toZipper (\x -> (One x, \(One x) -> x))
27
28
29-- | Create a zipper with a different focus type from the outer type. Will return
30--   @Nothing@ if there are no instances of the focus type within the original value.
31zipperBi :: Biplate from to => from -> Maybe (Zipper from to)
32zipperBi = toZipper biplate
33
34
35-- | Zipper structure, whose root type is the first type argument, and whose
36--   focus type is the second type argument.
37data Zipper from to = Zipper
38    {reform :: Str to -> from
39    ,zipp :: ZipN to
40    }
41
42rezipp f (Zipper a b) = fmap (Zipper a) $ f b
43
44instance (Eq from, Eq to) => Eq (Zipper from to) where
45    a == b = fromZipper a == fromZipper b && zipp a == zipp b
46
47
48toZipper :: Uniplate to => (from -> (Str to, Str to -> from)) -> from -> Maybe (Zipper from to)
49toZipper biplate x = fmap (Zipper gen) $ zipN cs
50    where (cs,gen) = biplate x
51
52
53-- | From a zipper take the whole structure, including any modifications.
54fromZipper :: Zipper from to -> from
55fromZipper x = reform x $ top1 $ topN $ zipp x
56
57
58-- | Move one step left from the current position.
59left :: Zipper from to -> Maybe (Zipper from to)
60left = rezipp leftN
61
62-- | Move one step right from the current position.
63right :: Zipper from to -> Maybe (Zipper from to)
64right = rezipp rightN
65
66-- | Move one step down from the current position.
67down :: Uniplate to => Zipper from to -> Maybe (Zipper from to)
68down = rezipp downN
69
70-- | Move one step up from the current position.
71up :: Zipper from to -> Maybe (Zipper from to)
72up = rezipp upN
73
74
75-- | Retrieve the current focus of the zipper..
76hole :: Zipper from to -> to
77hole = holeN . zipp
78
79
80-- | Replace the value currently at the focus of the zipper.
81replaceHole :: to -> Zipper from to -> Zipper from to
82replaceHole x z = z{zipp=replaceN x (zipp z)}
83
84
85---------------------------------------------------------------------
86-- N LEVEL ZIPPER ON Str
87
88data ZipN x = ZipN [Str x -> Zip1 x] (Zip1 x)
89
90instance Eq x => Eq (ZipN x) where
91    x@(ZipN _ xx) == y@(ZipN _ yy) = xx == yy && upN x == upN y
92
93zipN :: Str x -> Maybe (ZipN x)
94zipN x = fmap (ZipN []) $ zip1 x
95
96leftN  (ZipN p x) = fmap (ZipN p) $ left1  x
97rightN (ZipN p x) = fmap (ZipN p) $ right1 x
98holeN (ZipN _ x) = hole1 x
99replaceN v (ZipN p x) = ZipN p $ replace1 x v
100
101upN (ZipN [] x) = Nothing
102upN (ZipN (p:ps) x) = Just $ ZipN ps $ p $ top1 x
103
104topN (ZipN [] x) = x
105topN x = topN $ fromJust $ upN x
106
107downN :: Uniplate x => ZipN x -> Maybe (ZipN x)
108downN (ZipN ps x) = fmap (ZipN $ replace1 x . gen : ps) $ zip1 cs
109    where (cs,gen) = uniplate $ hole1 x
110
111
112---------------------------------------------------------------------
113-- 1 LEVEL ZIPPER ON Str
114
115data Diff1 a = TwoLeft (Str a) | TwoRight (Str a) deriving Eq
116
117undiff1 r (TwoLeft  l) = Two l r
118undiff1 l (TwoRight r) = Two l r
119
120-- Warning: this definition of Eq may look too strong (Str Left/Right is not relevant)
121--          but you don't know what the uniplate.gen function will do
122data Zip1 a = Zip1 [Diff1 a] a deriving Eq
123
124zip1 :: Str x -> Maybe (Zip1 x)
125zip1 = insert1 True []
126
127insert1 :: Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)
128insert1 leftmost c Zero = Nothing
129insert1 leftmost c (One x) = Just $ Zip1 c x
130insert1 leftmost c (Two l r) = if leftmost then ll `mplus` rr else rr `mplus` ll
131    where ll = insert1 leftmost (TwoRight r:c) l
132          rr = insert1 leftmost (TwoLeft  l:c) r
133
134left1, right1 :: Zip1 a -> Maybe (Zip1 a)
135left1  = move1 True
136right1 = move1 False
137
138move1 :: Bool -> Zip1 a -> Maybe (Zip1 a)
139move1 leftward (Zip1 p x) = f p $ One x
140    where
141        f p x = msum $
142            [insert1 False (TwoRight x:ps) l | TwoLeft  l:ps <- [p], leftward] ++
143            [insert1 True  (TwoLeft  x:ps) r | TwoRight r:ps <- [p], not leftward] ++
144            [f ps (x `undiff1` p) | p:ps <- [p]]
145
146top1 :: Zip1 a -> Str a
147top1 (Zip1 p x) = f p (One x)
148    where f :: [Diff1 a] -> Str a -> Str a
149          f [] x = x
150          f (p:ps) x = f ps (x `undiff1` p)
151
152hole1 :: Zip1 a -> a
153hole1 (Zip1 _ x) = x
154
155-- this way round so the a can be disguarded quickly
156replace1 :: Zip1 a -> a -> Zip1 a
157replace1 (Zip1 p _) = Zip1 p
158