{-| A zipper is a structure for walking a value and manipulating it in constant time. This module was inspired by the paper: /Michael D. Adams. Scrap Your Zippers: A Generic Zipper for Heterogeneous Types, Workshop on Generic Programming 2010/. -} module Data.Generics.Uniplate.Zipper( -- * Create a zipper and get back the value Zipper, zipper, zipperBi, fromZipper, -- * Navigate within a zipper left, right, up, down, -- * Manipulate the zipper hole hole, replaceHole ) where import Data.Generics.Uniplate.Operations import Data.Generics.Str import Control.Monad import Data.Maybe -- | Create a zipper, focused on the top-left value. zipper :: Uniplate to => to -> Zipper to to zipper = fromJust . toZipper (\x -> (One x, \(One x) -> x)) -- | Create a zipper with a different focus type from the outer type. Will return -- @Nothing@ if there are no instances of the focus type within the original value. zipperBi :: Biplate from to => from -> Maybe (Zipper from to) zipperBi = toZipper biplate -- | Zipper structure, whose root type is the first type argument, and whose -- focus type is the second type argument. data Zipper from to = Zipper {reform :: Str to -> from ,zipp :: ZipN to } rezipp f (Zipper a b) = fmap (Zipper a) $ f b instance (Eq from, Eq to) => Eq (Zipper from to) where a == b = fromZipper a == fromZipper b && zipp a == zipp b toZipper :: Uniplate to => (from -> (Str to, Str to -> from)) -> from -> Maybe (Zipper from to) toZipper biplate x = fmap (Zipper gen) $ zipN cs where (cs,gen) = biplate x -- | From a zipper take the whole structure, including any modifications. fromZipper :: Zipper from to -> from fromZipper x = reform x $ top1 $ topN $ zipp x -- | Move one step left from the current position. left :: Zipper from to -> Maybe (Zipper from to) left = rezipp leftN -- | Move one step right from the current position. right :: Zipper from to -> Maybe (Zipper from to) right = rezipp rightN -- | Move one step down from the current position. down :: Uniplate to => Zipper from to -> Maybe (Zipper from to) down = rezipp downN -- | Move one step up from the current position. up :: Zipper from to -> Maybe (Zipper from to) up = rezipp upN -- | Retrieve the current focus of the zipper.. hole :: Zipper from to -> to hole = holeN . zipp -- | Replace the value currently at the focus of the zipper. replaceHole :: to -> Zipper from to -> Zipper from to replaceHole x z = z{zipp=replaceN x (zipp z)} --------------------------------------------------------------------- -- N LEVEL ZIPPER ON Str data ZipN x = ZipN [Str x -> Zip1 x] (Zip1 x) instance Eq x => Eq (ZipN x) where x@(ZipN _ xx) == y@(ZipN _ yy) = xx == yy && upN x == upN y zipN :: Str x -> Maybe (ZipN x) zipN x = fmap (ZipN []) $ zip1 x leftN (ZipN p x) = fmap (ZipN p) $ left1 x rightN (ZipN p x) = fmap (ZipN p) $ right1 x holeN (ZipN _ x) = hole1 x replaceN v (ZipN p x) = ZipN p $ replace1 x v upN (ZipN [] x) = Nothing upN (ZipN (p:ps) x) = Just $ ZipN ps $ p $ top1 x topN (ZipN [] x) = x topN x = topN $ fromJust $ upN x downN :: Uniplate x => ZipN x -> Maybe (ZipN x) downN (ZipN ps x) = fmap (ZipN $ replace1 x . gen : ps) $ zip1 cs where (cs,gen) = uniplate $ hole1 x --------------------------------------------------------------------- -- 1 LEVEL ZIPPER ON Str data Diff1 a = TwoLeft (Str a) | TwoRight (Str a) deriving Eq undiff1 r (TwoLeft l) = Two l r undiff1 l (TwoRight r) = Two l r -- Warning: this definition of Eq may look too strong (Str Left/Right is not relevant) -- but you don't know what the uniplate.gen function will do data Zip1 a = Zip1 [Diff1 a] a deriving Eq zip1 :: Str x -> Maybe (Zip1 x) zip1 = insert1 True [] insert1 :: Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a) insert1 leftmost c Zero = Nothing insert1 leftmost c (One x) = Just $ Zip1 c x insert1 leftmost c (Two l r) = if leftmost then ll `mplus` rr else rr `mplus` ll where ll = insert1 leftmost (TwoRight r:c) l rr = insert1 leftmost (TwoLeft l:c) r left1, right1 :: Zip1 a -> Maybe (Zip1 a) left1 = move1 True right1 = move1 False move1 :: Bool -> Zip1 a -> Maybe (Zip1 a) move1 leftward (Zip1 p x) = f p $ One x where f p x = msum $ [insert1 False (TwoRight x:ps) l | TwoLeft l:ps <- [p], leftward] ++ [insert1 True (TwoLeft x:ps) r | TwoRight r:ps <- [p], not leftward] ++ [f ps (x `undiff1` p) | p:ps <- [p]] top1 :: Zip1 a -> Str a top1 (Zip1 p x) = f p (One x) where f :: [Diff1 a] -> Str a -> Str a f [] x = x f (p:ps) x = f ps (x `undiff1` p) hole1 :: Zip1 a -> a hole1 (Zip1 _ x) = x -- this way round so the a can be disguarded quickly replace1 :: Zip1 a -> a -> Zip1 a replace1 (Zip1 p _) = Zip1 p