-- | 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)  

--------------------------------------------------------------------------------