import qualified Test.HUnit as HU
import Test.HUnit.Utils
import qualified Data.Map as Map
-import System.IO
-import Text.Printf
import Data.List
+import Data.Maybe(catMaybes)
+import System.IO(stderr)
import Data.Syncable
+import TestInfrastructure
prop_empty :: Bool
prop_empty =
- syncThem emptymap emptymap emptymap == ([], [], []) -- ([DeleteItem 5], [], [])
+ syncBiDir (emptymap::Map.Map Int ()) emptymap emptymap == ([], []) -- ([DeleteItem 5], [], [])
-prop_delAllFromChild :: SyncCollection Int -> Bool
+prop_delAllFromChild :: SyncCollection Int () -> Result
prop_delAllFromChild inp =
- let (resMaster, resChild, resState) = syncThem emptymap inp inp
+ let (resMaster, resChild) = syncBiDir emptymap inp inp
expectedResChild = sort . map DeleteItem . Map.keys $ inp
- in resMaster == [] &&
- (sort resChild == expectedResChild) &&
- (sort resState == expectedResChild)
-
-prop_addFromMaster :: SyncCollection Int -> Bool
+ in ([], expectedResChild) @=?
+ (resMaster, sort resChild)
+
+prop_delAllFromMaster :: SyncCollection Int () -> Result
+prop_delAllFromMaster inp =
+ let (resMaster, resChild) = syncBiDir inp emptymap inp
+ expectedResMaster = sort . map DeleteItem . Map.keys $ inp
+ in (expectedResMaster, []) @=?
+ (sort resMaster, resChild)
+
+prop_addFromMaster :: SyncCollection Int Float -> Result
prop_addFromMaster inp =
- let (resMaster, resChild, resState) = syncThem inp emptymap emptymap
- expectedResChild = sort . map CopyItem . Map.keys $ inp
- in (resMaster == []) &&
- (sort resChild == expectedResChild) &&
- (sort resState == expectedResChild)
-
-keysToMap :: Ord k => [k] -> Map.Map k ()
-keysToMap = foldl (\map k -> Map.insert k () map) Map.empty
-
-emptymap :: Map.Map Int ()
-emptymap = Map.empty
-
-allt = [("Empty", prop_empty),
- ("Del all from child", prop_delAllFromChild)]
-alltHU = map (\(str, prop) -> qctest str prop) allt
-
-testh = HU.runTestTT $ HU.TestList alltHU
-testv = runVerbTestText (HU.putTextToHandle stderr True) $ HU.TestList alltHU
-
-testq = runTests "Test Stuff" defOpt (map (run . snd) allt)
-
-instance (Arbitrary k, Eq k, Ord k) => Arbitrary (Map.Map k ()) where
- arbitrary =
- do items <- arbitrary
- return $ keysToMap items
- coarbitrary = coarbitrary . Map.keys
-
--- Modified from HUnit
-runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st)
-runVerbTestText (HU.PutText put us) t = do
- (counts, us') <- HU.performTest reportStart reportError reportFailure us t
- us'' <- put (HU.showCounts counts) True us'
- return (counts, us'')
- where
- reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss))
- put (HU.showCounts (HU.counts ss)) False us
- reportError = reportProblem "Error:" "Error in: "
- reportFailure = reportProblem "Failure:" "Failure in: "
- reportProblem p0 p1 msg ss us = put line True us
- where line = "### " ++ kind ++ path' ++ '\n' : msg
- kind = if null path' then p0 else p1
- path' = HU.showPath (HU.path ss)
-
-
+ let (resMaster, resChild) = syncBiDir inp emptymap emptymap
+ expectedResChild = sort . map (\(k, v) -> CopyItem k v) . Map.toList $ inp
+ in ([], expectedResChild) @=?
+ (resMaster, sort resChild)
+
+-- FIXME: prop_addFromChild
+
+prop_allChangesToChild :: SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_allChangesToChild master child =
+ let (resMaster, resChild) = syncBiDir master child child
+ expectedResChild = sort $
+ (map (\(k, v) -> CopyItem k v) . Map.toList . Map.difference master $ child) ++
+ (map DeleteItem . Map.keys . Map.difference child $ master) ++
+ (map (pairToFunc ModifyContent) changeList)
+ changeList = foldl changefunc [] (Map.toList child)
+ changefunc accum (k, v) =
+ case Map.lookup k master of
+ Nothing -> accum
+ Just x -> if x /= v
+ then (k, x) : accum
+ else accum
+ masterChanges = map (pairToFunc ModifyContent) . catMaybes .
+ map checkIt . Map.toList . Map.intersection child
+ $ master
+ where checkIt (k, v) =
+ case Map.lookup k master of
+ Nothing -> Nothing
+ Just v' -> if v /= v'
+ then Just (k, v)
+ else Nothing
+ in (sort masterChanges, expectedResChild) @=?
+ (sort resMaster, sort resChild)
+
+prop_allChangesToMaster :: SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_allChangesToMaster master child =
+ let (resMaster, resChild) = syncBiDir master child master
+ expectedResMaster = sort $
+ (map (pairToFunc CopyItem) . Map.toList . Map.difference child $ master) ++
+ (map DeleteItem . Map.keys . Map.difference master $ child) ++
+ (map (pairToFunc ModifyContent) changeList)
+ changeList = foldl changefunc [] (Map.toList child)
+ changefunc accum (k, v) =
+ case Map.lookup k master of
+ Nothing -> accum
+ Just x -> if x /= v
+ then (k, v) : accum
+ else accum
+ in (expectedResMaster, []) @=?
+ (sort resMaster, resChild)
+
+-- FIXME: test findModified
+
+prop_allChanges :: SyncCollection Int Float -> SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_allChanges master child lastchild =
+ let (resMaster, resChild) = syncBiDir master child lastchild
+
+ masterMods = catMaybes . map procKV $ (Map.toList master)
+ where procKV (k, m) =
+ case (Map.lookup k child, Map.lookup k lastchild) of
+ (Just c, Just lc) ->
+ if c == lc -- child didn't change
+ then Nothing
+ else if c == m -- child and master changed
+ then Nothing
+ else Just (k, c) -- child changed, master didn't
+ (Nothing, Just lc) -> Nothing -- deleted on child
+ (Just c, Nothing) -> -- New on both c and m
+ if c == m -- Added the same
+ then Nothing
+ else Just (k, c) -- Added but differ
+ (Nothing, Nothing) -> Nothing -- New to master only
+
+ childMods = catMaybes . map procKV $ (Map.toList child)
+ where procKV (k, c) =
+ case (Map.lookup k master, Map.lookup k lastchild) of
+ (Just m, Just lc) ->
+ if lc == c
+ then if c == m
+ then Nothing
+ else Just (k, m)
+ else Nothing
+ (Nothing, Just lc) -> -- deleted; nothing to see here
+ Nothing
+ (Just m, Nothing) -> -- New on both; child takes precedence
+ Nothing
+ (Nothing, Nothing) -> Nothing -- New to child only
+
+ expectedResMaster = sort $
+ (map (pairToFunc CopyItem) . Map.toList . Map.difference child $ Map.union master lastchild) ++
+ (map DeleteItem . Map.keys . Map.intersection master $ Map.difference lastchild child) ++
+ (map (pairToFunc ModifyContent) masterMods)
+
+ expectedResChild = sort $
+ (map (pairToFunc CopyItem) . Map.toList . Map.difference master $ Map.union child lastchild) ++
+ (map DeleteItem . Map.keys . Map.intersection child $ Map.difference lastchild master) ++
+ (map (pairToFunc ModifyContent) childMods)
+
+ in (expectedResMaster, expectedResChild) @=?
+ (sort resMaster, sort resChild)
+
+{- | Basic validation that unaryApplyChanges works -}
+prop_unaryApplyChanges :: SyncCollection Int Float -> [(Bool, Int, Float)] -> Result
+prop_unaryApplyChanges collection randcommands =
+ let -- We use nubBy to make sure we don't get input that has reference
+ -- to the same key more than once. We then convert True/False to
+ -- commands.
+ commands = map toCommand . nubBy (\(x1, y1, z1) (x2, y2, z2) -> y1 == y2) $ randcommands
+ toCommand (True, x, v) = CopyItem x v
+ toCommand (False, x, _) = DeleteItem x
+
+ addedItems = catMaybes . map (\x -> case x of CopyItem y v -> Just (y, v); _ -> Nothing) $ commands
+ deletedKeys = catMaybes . map (\x -> case x of DeleteItem y -> Just y; _ -> Nothing) $ commands
+
+ collection' = foldl (flip Map.delete) collection deletedKeys
+ expectedCollection =
+ Map.union collection' (Map.fromList addedItems)
+ in (sort . Map.keys $ expectedCollection) @=?
+ (sort . Map.keys $ unaryApplyChanges collection commands)
+
+{- | Should validate both that unaryApplyChanges works, and that it is
+an identify -}
+prop_unaryApplyChangesId :: SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_unaryApplyChangesId master child =
+ let (resMaster, resChild) = syncBiDir master child child
+ newMaster = unaryApplyChanges master resMaster
+ newChild = unaryApplyChanges child resChild
+ newMasterKeys = sort . Map.keys $ newMaster
+ newChildKeys = sort . Map.keys $ newChild
+ in (True, sort (Map.keys master), sort (Map.keys master)) @=?
+ (newMasterKeys == newChildKeys, newMasterKeys, newChildKeys)
+
+prop_unaryApplyChanges3 :: SyncCollection Int Float -> SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_unaryApplyChanges3 master child lastChild =
+ let (resMaster, resChild) = syncBiDir master child lastChild
+ newMaster = unaryApplyChanges master resMaster
+ newChild = unaryApplyChanges child resChild
+ in newMaster @=? newChild
+
+prop_diffCollection :: SyncCollection Int Float -> SyncCollection Int Float -> Result
+prop_diffCollection coll1 coll2 =
+ let commands = diffCollection coll1 coll2
+ newcoll2 = unaryApplyChanges coll1 commands
+ in coll2 @=? newcoll2
+
+allt = [qctest "Empty" prop_empty,
+ qctest "Del all from child" prop_delAllFromChild,
+ qctest "Del all from master" prop_delAllFromMaster,
+ qctest "Add from master" prop_addFromMaster,
+ qctest "All changes to child" prop_allChangesToChild,
+ qctest "All changes to master" prop_allChangesToMaster,
+ qctest "All changes" prop_allChanges,
+ qctest "unaryApplyChanges" prop_unaryApplyChanges,
+ qctest "unaryApplyChangesId" prop_unaryApplyChangesId,
+ qctest "unaryApplyChanges3" prop_unaryApplyChanges3,
+ qctest "diffCollection" prop_diffCollection
+ ]
+
+testh = HU.runTestTT $ HU.TestList allt
+testv = runVerbTestText (HU.putTextToHandle stderr True) $ HU.TestList allt
+
+
main =
do testv
return ()