module Data.Generics.Fixplate.Zipper where
import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
import Data.Foldable
import Data.Traversable
import Data.Maybe
import Text.Show
import Text.Read
import Data.Generics.Fixplate.Base
import Data.Generics.Fixplate.Open
import Data.Generics.Fixplate.Misc
#ifdef WITH_QUICKCHECK
import Test.QuickCheck
import Data.Generics.Fixplate.Attributes
import Data.Generics.Fixplate.Traversals
import Data.Generics.Fixplate.Test.Tools
import Control.Monad (liftM)
#endif
type Node f = Either (Mu f) (Path f)
data Path f = Top
| Path { unPath :: f (Node f) }
data Loc f = Loc { focus :: Mu f , path :: Path f }
instance EqF f => Eq (Path f) where
Top == Top = True
Path p1 == Path p2 = equalF p1 p2
_ == _ = False
instance EqF f => Eq (Loc f) where
Loc f1 p1 == Loc f2 p2 = f1 == f2 && p1 == p2
instance ShowF f => Show (Path f) where
showsPrec d Top = showString "Top"
showsPrec d (Path xs) = showParen (d>10)
$ showString "Path "
. showsPrecF 11 xs
instance ShowF f => Show (Loc f) where
showsPrec d (Loc foc path) = showParen (d>10)
$ showString "Loc "
. showsPrec 11 foc
. showChar ' '
. showsPrec 11 path
instance ReadF f => Read (Path f) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $
(do
{ Ident "Top" <- lexP
; return Top
})
+++
(prec app_prec $ do
{ Ident "Path" <- lexP
; p <- step readPrecF
; return (Path p)
})
#else
readsPrec d r = readParen (d > app_prec)
(\r -> [ (Top, s)
| ("Top", s) <- lex r]) r
++
(\r -> [ (Path p, t)
| ("Path", s) <- lex r
, (f,t) <- readsPrecF (app_prec+1) s]) r
#endif
instance ReadF f => Read (Loc f) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $
(prec app_prec $ do
{ Ident "Loc" <- lexP
; f <- step readPrec
; p <- step readPrec
; return (Loc f p)
})
#else
readsPrec d r = readParen (d > app_prec)
(\r -> [ (Loc f p, u)
| ("Loc", s) <- lex r
, (f,t) <- readsPrec (app_prec+1) s
, (p,u) <- readsPrec (app_prec+1) t]) r
#endif
root :: Mu f -> Loc f
root t = Loc t Top
defocus :: Traversable f => Loc f -> Mu f
defocus (Loc foc path) = go foc path where
go t Top = t
go t (Path xs) = go (Fix s) path' where
(Just path', s) = mapAccumL h Nothing xs
h old (Left y) = (old , y)
h _ (Right p) = (Just p , t)
locations :: Traversable f => Mu f -> Attr f (Loc f)
locations tree = go (root tree) tree where
go loc (Fix t) = Fix (Ann loc t') where
t' = enumerateWith_ (\j x -> go (unsafeMoveDown j loc) x) t
locationsList :: Traversable f => Mu f -> [Loc f]
locationsList = toList . Attrib . locations
locForget :: Functor f => Loc (Ann f a) -> Loc f
locForget (Loc foc path) = Loc (forget foc) (go path) where
go :: Functor f => Path (Ann f a) -> Path f
go Top = Top
go (Path (Ann _ nodes)) = Path (fmap h nodes)
h :: Functor f => Node (Ann f a) -> Node f
h (Left t) = Left (forget t)
h (Right p) = Right (go p)
extract :: Loc f -> Mu f
extract = focus
replace :: Mu f -> Loc f -> Loc f
replace new loc = loc { focus = new }
modify :: (Mu f -> Mu f) -> Loc f -> Loc f
modify h loc = replace (h (focus loc)) loc
moveDown :: Traversable f => Int -> Loc f -> Maybe (Loc f)
moveDown pos (Loc foc path) = new where
new = case mfoc' of
Nothing -> Nothing
Just foc' -> Just $ Loc foc' (Path nodes')
((mfoc',_),nodes') = mapAccumL g (Nothing,0) (unFix foc)
g (old,j) x = if j==pos
then ((Just x , j+1), Right path )
else ((old , j+1), Left x )
moveDownL :: Traversable f => Loc f -> Maybe (Loc f)
moveDownL (Loc foc path) = new where
new = case mfoc' of
Nothing -> Nothing
Just foc' -> Just $ Loc foc' (Path nodes')
(mfoc',nodes') = mapAccumL g Nothing (unFix foc)
g old x = case old of
Nothing -> (Just x , Right path )
_ -> (old , Left x )
moveDownR :: Traversable f => Loc f -> Maybe (Loc f)
moveDownR (Loc foc path) = new where
new = case mfoc' of
Nothing -> Nothing
Just foc' -> Just $ Loc foc' (Path nodes')
(mfoc',nodes') = mapAccumR g Nothing (unFix foc)
g old x = case old of
Nothing -> (Just x , Right path )
_ -> (old , Left x )
moveUp :: Traversable f => Loc f -> Maybe (Loc f)
moveUp (Loc foc path) = case path of
Top -> Nothing
Path nodes ->
case mpath of
Nothing -> error "moveUp: shouldn't happen"
Just path' -> Just $ case path' of
Path nodes' -> Loc (Fix foc') (Path nodes')
Top -> Loc (Fix foc') Top
where
(mpath,foc') = mapAccumL g Nothing nodes
g old ei = case ei of
Right p -> (Just p , foc)
Left x -> (old , x )
moveRight :: Traversable f => Loc f -> Maybe (Loc f)
moveRight (Loc foc path) = case path of
Top -> Nothing
Path nodes ->
case two of
Two foc' -> Just $ Loc foc' (Path nodes')
_ -> Nothing
where
(two,nodes') = mapAccumL g Empty nodes
g old ei = case ei of
Right p -> (One p , Left foc )
Left x -> case old of
One p -> (Two x , Right p )
_ -> (old , ei )
moveLeft :: Traversable f => Loc f -> Maybe (Loc f)
moveLeft (Loc foc path) = case path of
Top -> Nothing
Path nodes ->
case two of
Two foc' -> Just $ Loc foc' (Path nodes')
_ -> Nothing
where
(two,nodes') = mapAccumR g Empty nodes
g old ei = case ei of
Right p -> (One p , Left foc )
Left x -> case old of
One p -> (Two x , Right p )
_ -> (old , ei )
isTop :: Loc f -> Bool
isTop (Loc _ p) = case p of { Top -> True ; _ -> False }
isBottom :: Traversable f => Loc f -> Bool
isBottom = isNothing . moveDownL
isLeftmost :: Traversable f => Loc f -> Bool
isLeftmost = isNothing . moveLeft
isRightmost :: Traversable f => Loc f -> Bool
isRightmost = isNothing . moveRight
horizontalPos :: Foldable f => Loc f -> Int
horizontalPos (Loc _ path) = case path of
Top -> 0
Path nodes ->
case mpos of
Right pos -> pos
Left _ -> error "horizontalPos: shouldn't happen"
where
mpos = foldl g (Left 0) nodes
g old ei = case old of
Right _ -> old
Left j -> case ei of
Left _ -> Left (j+1)
Right _ -> Right j
fullPathDown :: Foldable f => Loc f -> [Int]
fullPathDown = reverse . fullPathUp
fullPathUp :: Foldable f => Loc f -> [Int]
fullPathUp (Loc _ pth) = go pth where
go path = case path of
Top -> []
Path nodes ->
case mpos of
Right (pos,parent) -> pos : go parent
Left _ -> error "fullPathUp: shouldn't happen"
where
mpos = foldl g (Left 0) nodes
g old ei = case old of
Right _ -> old
Left j -> case ei of
Left _ -> Left (j+1)
Right p -> Right (j,p)
moveTop :: Traversable f => Loc f -> Loc f
moveTop = tillNothing moveUp
leftmost :: Traversable f => Loc f -> Loc f
leftmost orig@(Loc foc path) = case path of
Top -> orig
Path nodes ->
case both of
Both {} -> Loc foc' (Path nodes')
_ -> error "leftmost: shouldn't happen"
where
(foc',pnew) = case both of { Both f p -> (f,p) ; _ -> error "leftmost: shouldn't happen" }
(both,nodes') = mapAccumL g None nodes
g old ei = case old of
None -> case ei of
Left x -> (First x , Right pnew)
Right p -> (Both foc p , ei )
First f -> case ei of
Left x -> (old , ei )
Right p -> (Both f p , Left foc )
Both {} -> (old, ei)
rightmost :: Traversable f => Loc f -> Loc f
rightmost orig@(Loc foc path) = case path of
Top -> orig
Path nodes ->
case both of
Both {} -> Loc foc' (Path nodes')
_ -> error "rightmost: shouldn't happen"
where
(foc',pnew) = case both of { Both f p -> (f,p) ; _ -> error "rightmost: shouldn't happen" }
(both,nodes') = mapAccumR g None nodes
g old ei = case old of
None -> case ei of
Left x -> (First x , Right pnew)
Right p -> (Both foc p , ei )
First f -> case ei of
Left x -> (old , ei )
Right p -> (Both f p , Left foc )
Both {} -> (old, ei)
unsafeMoveDown :: Traversable f => Int -> Loc f -> Loc f
unsafeMoveDown i = unsafe (moveDown i) "unsafeMoveDown: cannot move down"
unsafeMoveDownL :: Traversable f => Loc f -> Loc f
unsafeMoveDownR :: Traversable f => Loc f -> Loc f
unsafeMoveUp :: Traversable f => Loc f -> Loc f
unsafeMoveDownL = unsafe moveDownL "unsafeMoveDownL: cannot move down"
unsafeMoveDownR = unsafe moveDownR "unsafeMoveDownR: cannot move down"
unsafeMoveUp = unsafe moveUp "unsafeMoveUp: cannot move up"
unsafeMoveLeft, unsafeMoveRight :: Traversable f => Loc f -> Loc f
unsafeMoveLeft = unsafe moveLeft "unsafeMoveLeft: cannot move left"
unsafeMoveRight = unsafe moveRight "unsafeMoveRight: cannot move right"
#ifdef WITH_QUICKCHECK
type LocT a = Loc (TreeF a)
findLoc :: Traversable f => Int -> Loc (Ann f Int) -> Loc (Ann f Int)
findLoc k = go where
go loc =
case compare j k of
GT -> error "findLoc: shouldn't happen?"
EQ -> loc
LT -> case moveDownL loc of
Just xx -> go xx
Nothing -> case moveRight loc of
Just yy -> go yy
Nothing -> goUpR (unsafeMoveUp loc)
where
Fix (Ann j _) = focus loc
goUpR loc = case moveRight loc of
Nothing -> goUpR (unsafeMoveUp loc)
Just zz -> go zz
tmp = treeF "root"
[ treeF "a" [ treeF "a1" [] , treeF "a2" [] ]
, treeF "b" []
, treeF "c" [ treeF "c1" [] , treeF "c2" [] , treeF "c3" [] ]
]
instance Arbitrary a => Arbitrary (LocT a) where
arbitrary = do
tree <- arbitrary
let (n,numbered) = enumerateNodes tree
k <- choose (0,n1)
return $ locForget $ findLoc k (root numbered)
rndLoc :: IO (LocT Label)
rndLoc = liftM (!!7) $ sample' arbitrary
newtype ChildIndex = ChildIndex Int deriving Show
instance Arbitrary ChildIndex where
arbitrary = liftM ChildIndex $ choose (0,7)
runtests_Zipper :: IO ()
runtests_Zipper = do
quickCheck prop_ReadShowLoc
quickCheck prop_findLoc
quickCheck prop_locationsList
quickCheck prop_contextList
quickCheck prop_Top
quickCheck prop_defocus
quickCheck prop_horizontalPos
quickCheck prop_fullPathDown
quickCheck prop_fullPathUp
quickCheck prop_fullPathUp2
quickCheck prop_leftmost
quickCheck prop_rightmost
quickCheck prop_DownLUp
quickCheck prop_DownRUp
quickCheck prop_UpDownL
quickCheck prop_UpDownR
quickCheck prop_DownL
quickCheck prop_DownR
quickCheck prop_UpDownJ
quickCheck prop_LeftRight
quickCheck prop_RightLeft
leftmostNaive :: Traversable f => Loc f -> Loc f
leftmostNaive = tillNothing moveLeft
rightmostNaive :: Traversable f => Loc f -> Loc f
rightmostNaive = tillNothing moveRight
fullPathUpNaive :: Traversable f => Loc f -> [Int]
fullPathUpNaive = go where
go loc@(Loc _ path) = case path of
Top -> []
_ -> horizontalPos loc : go (unsafeMoveUp loc)
prop_ReadShowLoc :: LocT Label -> Bool
prop_ReadShowLoc loc = read (show loc) == loc
prop_locationsList :: FixT Label -> Bool
prop_locationsList tree = locationsList tree == [ locForget $ findLoc i top | i<-[0..n1] ] where
top = root numbered
(n,numbered) = enumerateNodes tree
prop_findLoc :: FixT Label -> Bool
prop_findLoc tree = [0..n1] == [ attribute $ focus $ findLoc i top | i<-[0..n1] ] where
top = root numbered
(n,numbered) = enumerateNodes tree
prop_contextList :: FixT Label -> Bool
prop_contextList tree =
map (\(Fix (TreeF l ts),replace) -> replace (Fix (TreeF (h l) ts))) (contextList tree)
==
[ defocus $ modify (\(Fix (TreeF l ts)) -> Fix (TreeF (h l) ts) ) $ locForget $ findLoc i top | i<-[0..n1] ]
where
top = root numbered
(n,numbered) = enumerateNodes tree
h (Label xs) = Label ('_':xs)
prop_Top :: LocT Label -> Bool
prop_Top loc = root (defocus loc) == moveTop loc
prop_defocus :: FixT Label -> Bool
prop_defocus tree =
Prelude.and [ defocus (findLoc i top) == numbered | i<-[0..n1] ]
where
top = root numbered
(n,numbered) = enumerateNodes tree
prop_horizontalPos :: LocT Label -> Bool
prop_horizontalPos loc =
loc == iterateN (horizontalPos loc) unsafeMoveRight (leftmost loc)
prop_fullPathDown :: LocT Label -> Bool
prop_fullPathDown loc =
loc == foldl (flip unsafeMoveDown) (moveTop loc) (fullPathDown loc)
prop_fullPathUp :: LocT Label -> Bool
prop_fullPathUp loc =
fullPathUp loc == fullPathUpNaive loc
prop_fullPathUp2 :: LocT Label -> Bool
prop_fullPathUp2 loc =
loc == foldr unsafeMoveDown (moveTop loc) (fullPathUp loc)
prop_leftmost :: LocT Label -> Bool
prop_leftmost loc = leftmost loc == leftmostNaive loc
prop_rightmost :: LocT Label -> Bool
prop_rightmost loc = rightmost loc == rightmostNaive loc
prop_DownLUp :: LocT Label -> Property
prop_DownLUp loc =
(not $ isBottom loc)
==> unsafeMoveUp (unsafeMoveDownL loc) == loc
prop_DownRUp :: LocT Label -> Property
prop_DownRUp loc =
(not $ isBottom loc)
==> unsafeMoveUp (unsafeMoveDownR loc) == loc
prop_UpDownL :: LocT Label -> Property
prop_UpDownL loc =
(not $ isTop loc)
==> unsafeMoveDownL (unsafeMoveUp loc) == leftmost loc
prop_UpDownR :: LocT Label -> Property
prop_UpDownR loc =
(not $ isTop loc)
==> unsafeMoveDownR (unsafeMoveUp loc) == rightmost loc
prop_DownL :: LocT Label -> Property
prop_DownL loc =
(not $ isBottom loc)
==> unsafeMoveDownL loc == unsafeMoveDown 0 loc
prop_DownR :: LocT Label -> Property
prop_DownR loc =
(not $ isBottom loc)
==> let k = length $ children $ focus loc
in unsafeMoveDownR loc == unsafeMoveDown (k1) loc
prop_UpDownJ :: ChildIndex -> LocT Label -> Property
prop_UpDownJ (ChildIndex j) loc =
(not $ isTop loc)
==> (j < (length $ children $ focus $ unsafeMoveUp loc))
==> unsafeMoveDown j (unsafeMoveUp loc) == iterateN j unsafeMoveRight (leftmost loc)
prop_LeftRight :: LocT Label -> Property
prop_LeftRight loc =
(not $ isLeftmost loc)
==> unsafeMoveRight (unsafeMoveLeft loc) == loc
prop_RightLeft :: LocT Label -> Property
prop_RightLeft loc =
(not $ isRightmost loc)
==> (unsafeMoveLeft (unsafeMoveRight loc) == loc)
#endif