fixplate-0.1.7: tests/TestSuite/Zipper.hs
-- | Tests for zippers
{-# LANGUAGE FlexibleInstances #-}
module TestSuite.Zipper where
--------------------------------------------------------------------------------
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck
import Control.Applicative
import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
import Data.Foldable
import Data.Traversable
import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
import Data.Generics.Fixplate.Base
-- import Data.Generics.Fixplate.Misc
import Data.Generics.Fixplate.Attributes
import Data.Generics.Fixplate.Morphisms
import Data.Generics.Fixplate.Traversals
import Data.Generics.Fixplate.Zipper
import TestSuite.Tools
import TestSuite.Misc
--------------------------------------------------------------------------------
testgroup_Zipper :: TestTree
testgroup_Zipper = testGroup "Zipper"
[ testProperty "Loc: Read/Show" prop_ReadShowLoc
, testProperty "findLoc" prop_findLoc
, testProperty "locationsList" prop_locationsList
, testProperty "contextList" prop_contextList
, testProperty "Top" prop_Top
, testProperty "defocus" prop_defocus
, testProperty "horizontalDown" prop_horizontalPos
, testProperty "pathDown" prop_fullPathDown
, testProperty "pathUp" prop_fullPathUp
, testProperty "pathUp /2" prop_fullPathUp2
, testProperty "leftmost" prop_leftmost
, testProperty "rightmost" prop_rightmost
, testProperty "up . downL" prop_DownLUp
, testProperty "up . downR" prop_DownRUp
, testProperty "downL . up" prop_UpDownL
, testProperty "downR . up" prop_UpDownR
, testProperty "downL" prop_DownL
, testProperty "downR" prop_DownR
, testProperty "downJ . up" prop_UpDownJ
, testProperty "right . left" prop_LeftRight
, testProperty "left . right" prop_RightLeft
]
--------------------------------------------------------------------------------
-- Tests
type LocT a = Loc (TreeF a)
{-
data Step
= StepUp
| StepLeft
| StepRight
| StepDown Int
| StepDownL
| StepDownR
deriving (Eq,Ord,Show)
newtype Walk = Walk [Step] deriving (Eq,Ord,Show)
walk :: Traversable f => Walk -> Loc f -> Loc f
walk (Walk steps) loc = foldl (flip singleStep) loc steps
singleStep :: Traversable f => Step -> Loc f -> Loc f
singleStep s loc = case stepMaybe s loc of { Nothing -> loc ; Just new -> new }
stepMaybe :: Traversable f => Step -> Loc f -> Maybe (Loc f)
stepMaybe s = case s of
StepUp -> moveUp
StepLeft -> moveLeft
StepRight -> moveRight
StepDown j -> moveDown j
StepDownL -> moveLeft
StepDownR -> moveRight
instance Arbitrary Step where
arbitrary = oneof
[ return StepUp
, return StepLeft
, return StepRight
, do { j <- choose (1,7) ; return (StepDown j) }
, return StepDownL
, return StepDownR
]
instance Arbitrary Walk where
arbitrary = liftM Walk arbitrary
shrink (Walk steps) = map Walk (shrink steps)
-}
-- | Assuming a left-to-right canonical numbering, we find the given
-- location.
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,n-1)
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..n-1] ] where
top = root numbered
(n,numbered) = enumerateNodes tree
prop_findLoc :: FixT Label -> Bool
prop_findLoc tree = [0..n-1] == [ attribute $ focus $ findLoc i top | i<-[0..n-1] ] 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..n-1] ]
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..n-1] ]
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 (k-1) 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)
--------------------------------------------------------------------------------