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