{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Main where import Control.Exception import Data.Function (on) import Data.List (sortBy) import qualified Data.List.UniqueUnsorted as U import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), getCurrentTime , secondsToDiffTime) import Message_QCA import Network.Mattermost.Types import System.Exit import Test.QuickCheck.Checkers import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import TimeUtils import Types.DirectionalSeq import Types.Messages import Types.Posts import Prelude.MH main :: IO () main = defaultMain tests `catch` (\e -> do if e == ExitSuccess then putStrLn "Passed" else do putStrLn "FAILED" throwIO e) tests :: TestTree tests = testGroup "Messages Tests" [ createTests , lookupTests , movementTests , reversalTests , splitTests , removeTests , instanceTests ] test_m1 :: IO Message test_m1 = do t1 <- ServerTime <$> getCurrentTime return $ makeMsg t1 Nothing test_m2 :: IO Message test_m2 = do t2 <- ServerTime <$> getCurrentTime return $ (makeMsg t2 (Just $ MessagePostId $ fromId $ Id "m2")) { _mType = CP Emote } test_m3 :: IO Message test_m3 = do t3 <- ServerTime <$> getCurrentTime return $ makeMsg t3 (Just $ MessagePostId $ fromId $ Id "m3") setDateOrderMessages :: [Message] -> [Message] setDateOrderMessages = snd . foldl setTimeAndInsert (startTime, []) where setTimeAndInsert (t, ml) m = let t2 = tick t in (t2, ml ++ [m {_mDate = t2}]) startTime = ServerTime $ UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0) tick (ServerTime (UTCTime d t)) = ServerTime $ UTCTime d $ succ t makeMsg :: ServerTime -> Maybe MessageId -> Message makeMsg t mId = Message Seq.empty mempty NoUser t (CP NormalPost) False False Seq.empty NotAReply mId Map.empty Nothing False Nothing makeMsgs :: [Message] -> Messages makeMsgs = foldr addMessage noMessages idlist :: Foldable t => t Message -> [Maybe MessageId] idlist = foldr (\m s -> m^.mMessageId : s) [] postids :: (Foldable t) => String -> t Message -> String postids names msgs = let zipf = (\(n,z) m -> if null n then ("", ('?', m) : z) else (init n, (last n, m) : z)) zipped = snd $ foldr (flip zipf) (names, []) msgs pid (n, m) = show n <> ".mPostID=" <> show (m^.mMessageId) in intercalate ", " $ map pid zipped uniqueIds :: Foldable t => t Message -> Bool uniqueIds msgs = let ids = idlist msgs in length ids == length (U.unique ids) validIds :: Foldable t => t Message -> Bool validIds = null . filter isNothing . idlist tastyBatch :: TestBatch -> TestTree tastyBatch b = testGroup (fst b) $ tastyTests (snd b) where tastyTests = map tastyTest tastyTest = uncurry testProperty createTests :: TestTree createTests = testGroup "Create" [ testCase "no messages" $ 0 @=? length noMessages , testProperty "has messages" $ \x -> not (null (x :: Messages)) ==> 0 /= length x , testProperty "add to empty" $ \x -> 1 == (length $ addMessage x noMessages) , testProperty "add to add to empty" $ \(x, y) -> 2 == (length $ makeMsgs [x, y]) , testProperty "join to empty" $ \(x, y) -> let m1 = makeMsgs [x, y] m2 = noMessages in (2 == (length $ m1 `appendDirSeq` m2) && 2 == (length $ m2 `appendDirSeq` m1)) , testProperty "join one to many" $ \(x, y, z) -> let l1 = setDateOrderMessages [x, y] m1 = makeMsgs l1 m2 = addMessage z noMessages j2 = m2 `appendDirSeq` m1 in idlist [z, x, y] === idlist j2 , testProperty "join many to one" $ \(x, y, z) -> let l1 = setDateOrderMessages [x, y] m1 = makeMsgs l1 m2 = addMessage z noMessages j1 = m1 `appendDirSeq` m2 in idlist [x, y, z] === idlist j1 , testProperty "join to many" $ \(w, x, y, z) -> let l1 = setDateOrderMessages [x, y] l2 = setDateOrderMessages [w, z] m1 = makeMsgs l1 m2 = makeMsgs l2 -- note that mappend is literal: there is -- no date relationship between the -- members l1 and l2 and mappend doesn't -- enforce one. j1 = m1 `appendDirSeq` m2 j2 = m2 `appendDirSeq` m1 in (4 == (length j1) && 4 == (length j2) && idlist (l1 <> l2) == idlist j1 && idlist (l2 <> l1) == idlist j2) , testProperty "natural ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] in idlist l === idlist (makeMsgs l) , testProperty "reverse ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] in idlist l === idlist (makeMsgs $ reverse l) , testProperty "mirrored ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs [y', z', w', x']) , testProperty "ordering 1 of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs [y', w', z', x']) , testProperty "ordering 2 of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs [x', z', w', y']) , testProperty "duplicated last addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ map postMsg [w, x, y, z] in uniqueIds l ==> idlist l === idlist (makeMsgs $ [last l] <> l) , testProperty "duplicated natural ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ map postMsg [w, x, y, z] in idlist l === idlist (makeMsgs $ l <> l) , testProperty "duplicated reverse ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ map postMsg [w, x, y, z] in idlist l === idlist (makeMsgs $ reverse l <> l) , testProperty "duplicated mirrored ordering of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ map postMsg [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs $ [y', z', w', x'] <> l) , testProperty "duplicated ordering 1 of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ postMsg <$> [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs $ [y', w', z', x'] <> l) , testProperty "duplicated ordering 2 of addMessage" $ \(w, x, y, z) -> let l = setDateOrderMessages $ postMsg <$> [w, x, y, z] [w', x', y', z'] = l in idlist l === idlist (makeMsgs $ [x', z', w', y'] <> l) , testProperty "non-posted are not duplicate removed" $ \(w, x, y, z) -> let l = setDateOrderMessages [w, x, y, z] [w', x', y', z'] = l l' = [x', z', w', y'] ex = sortBy (\a b -> compare (a^.mDate) (b^.mDate)) ([e | e <- l', isNothing (messagePostId e) ] <> l) in idlist ex === idlist (makeMsgs $ l' <> l) , testProperty "duplicate dates different IDs in posted order" $ \(w, x, y, z) -> let d = ServerTime $ UTCTime (ModifiedJulianDay 1234) (secondsToDiffTime 9876) l = foldl (setTime d) [] $ postMsg <$> [w, x, y, z] setTime t ml m = ml ++ [m {_mDate = t}] [w', x', y', z'] = l l' = [x', z', w', y'] ex = l in uniqueIds l ==> idlist ex === idlist (makeMsgs $ l' <> l) ] movementTests :: TestTree movementTests = testGroup "Movement" [ moveUpTestEmpty , moveUpTestSingle , moveUpTestMultipleStart , moveUpTestMultipleEnd , moveUpTestMultipleSkipDeleted , moveUpTestMultipleSkipDeletedAll , moveDownTestEmpty , moveDownTestMultipleStart , moveDownTestSingle , moveDownTestMultipleEnd , moveDownTestMultipleSkipDeleted , moveDownTestMultipleSkipDeletedAll ] moveDownTestEmpty :: TestTree moveDownTestEmpty = testProperty "Move up in empty messages" $ \x -> Nothing == getNextPostId x noMessages moveUpTestEmpty :: TestTree moveUpTestEmpty = testProperty "Move down in empty messages" $ \x -> Nothing == getPrevPostId x noMessages moveDownTestSingle :: TestTree moveDownTestSingle = testProperty "Move up from single message" $ \x -> let msgs = addMessage x noMessages in Nothing == (getNextPostId (messagePostId x) msgs) moveUpTestSingle :: TestTree moveUpTestSingle = testProperty "Move down from single message" $ \x -> let msgs = addMessage x noMessages in Nothing == (getPrevPostId (messagePostId x) msgs) moveDownTestMultipleStart :: TestTree moveDownTestMultipleStart = testProperty "Move down in multiple messages from the start" $ \(x', y', z') -> let [x, y, z] = setDateOrderMessages [ postMsg x' , postMsg y' , postMsg z' ] msgs = makeMsgs [x, y, z] msgid = getNextMessageId (x^.mMessageId) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in counterexample info $ y^.mMessageId == msgid moveUpTestMultipleStart :: TestTree moveUpTestMultipleStart = testProperty "Move up in multiple messages from the start" $ \(x', y', z') -> let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z] msgid = getPrevPostId (messagePostId x) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==> counterexample info $ Nothing == msgid moveDownTestMultipleEnd :: TestTree moveDownTestMultipleEnd = testProperty "Move down in multiple messages from the end" $ \(x', y', z') -> let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z] msgid = getNextPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==> counterexample info $ Nothing == msgid moveUpTestMultipleEnd :: TestTree moveUpTestMultipleEnd = testProperty "Move up in multiple messages from the end" $ \(x', y', z') -> let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z] msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==> counterexample info $ (messagePostId y) == msgid moveDownTestMultipleSkipDeleted :: TestTree moveDownTestMultipleSkipDeleted = testProperty "Move down in multiple messages skipping deleteds" $ \(w', x', y', z') -> let [w, x, y, z] = setDateOrderMessages [ postMsg w' , delMsg x' , delMsg y' , postMsg z'] msgs = makeMsgs [w, x, y, z] msgid = getNextPostId (messagePostId w) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid in counterexample info $ (messagePostId z) == msgid moveUpTestMultipleSkipDeleted :: TestTree moveUpTestMultipleSkipDeleted = testProperty "Move one up in multiple messages skipping deleteds" $ \(w', x', y', z') -> let [w, x, y, z] = setDateOrderMessages [ postMsg w' , delMsg x' , delMsg y' , postMsg z'] msgs = makeMsgs [w, x, y, z] msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==> counterexample info $ (messagePostId w) == msgid moveDownTestMultipleSkipDeletedAll :: TestTree moveDownTestMultipleSkipDeletedAll = testProperty "Move one down in multiple deleted messages skipping deleteds" $ \(w', x', y', z') -> -- n.b. current selected is also deleted, -- which can happen due to multi-user async -- server changes. let [w, x, y, z] = setDateOrderMessages [ delMsg w' , delMsg x' , delMsg y' , delMsg z'] msgs = makeMsgs [w, x, y, z] msgid = getNextPostId (messagePostId w) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid in counterexample info $ Nothing == msgid moveUpTestMultipleSkipDeletedAll :: TestTree moveUpTestMultipleSkipDeletedAll = testProperty "Move one up in multiple deleted messages skipping deleteds" $ \(w', x', y', z') -> -- n.b. current selected is also deleted, -- which can happen due to multi-user async -- server changes. let [w, x, y, z] = setDateOrderMessages [ delMsg w' , delMsg x' , delMsg y' , delMsg z'] msgs = makeMsgs [w, x, y, z] msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==> counterexample info $ Nothing == msgid reversalTests :: TestTree reversalTests = testGroup "Reversal" [ testProperty "round trip" $ \l -> let rr = unreverseMessages (reverseMessages l) in idlist l === idlist rr , testProperty "getLatestMessage finds same in either dir" $ \l -> let rr = unreverseMessages (reverseMessages l) -- KWQ: just one reverse, not two in (messagePostId <$> getLatestPostMsg l) === (messagePostId <$> getLatestPostMsg rr) , testCase "reverse nothing" $ (null $ unreverseMessages $ reverseMessages noMessages) @? "reverse of empty Messages" , testProperty "reverse order" $ \l -> let r = reverseMessages l in idlist l === reverse (idlist r) ] lookupTests :: TestTree lookupTests = testGroup "Lookup" [ testProperty "getEarliestPostMsg" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate)) $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist firstPostId = messagePostId <$> getEarliestPostMsg msgs in if null postIds then Nothing === firstPostId else Just (head postIds) === firstPostId , testProperty "getLatestPostMsg" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate)) $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist lastPostId = messagePostId <$> getLatestPostMsg msgs in counterexample ("ids: " <> show (idlist msgs) <> "\n dates: " <> (show $ fmap show $ foldr (\m l -> m^.mDate : l) [] msgs) <> "\n deleted: " <> (show $ fmap show $ foldr (\m l -> m^.mDeleted : l) [] msgs) <> "\n postIds:" <> show postIds) ( if null postIds then Nothing === lastPostId else Just (last postIds) === lastPostId) , testProperty "findLatestUserMessage" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate)) $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist lastPostId = messagePostId <$> findLatestUserMessage (const True) msgs firstPostId = messagePostId <$> findLatestUserMessage (\m -> messagePostId m == head postIds) msgs in counterexample ("ids: " <> show (idlist msgs) <> "\n dates: " <> (show $ fmap show $ foldr (\m l -> m^.mDate : l) [] msgs) <> "\n deleted: " <> (show $ fmap show $ foldr (\m l -> m^.mDeleted : l) [] msgs) <> "\n postIds:" <> show postIds) ( if null postIds then Nothing === lastPostId else Just (last postIds) === lastPostId .&&. Just (head postIds) === firstPostId) ] splitTests :: TestTree splitTests = testGroup "Split" [ testCase "split nothing on empty" $ let (m, _) = splitDirSeqOn (const False) noMessages in isNothing m @? "must be nothing" , testProperty "split just on empty" $ \x -> let (m, _) = splitDirSeqOn (\m2 -> m2^.mMessageId == x) noMessages in isNothing m , testProperty "split nothing on list" $ \(x::Messages) -> let (m, _) = splitDirSeqOn (const False) x in isNothing m , testProperty "split nothing on not found" $ \(w', x', y', z') -> let (m, _) = splitDirSeqOn (\m2 -> m2^.mMessageId == w^.mMessageId) msgs [w, x, y, z] = setDateOrderMessages [w', x', y', z'] msgs = makeMsgs [x, y, z] idents = postids "wxyz" msgs info = idents <> " against " <> show (messagePostId (fromJust m)) in uniqueIds [w, x, y, z] ==> counterexample info $ isNothing m , testProperty "all before reversed on split nothing" $ \(w, x, y, z) -> let (_, (before, _)) = splitDirSeqOn (const False) msgs msgs = makeMsgs inpl inpl = setDateOrderMessages [w, x, y, z] control = idlist (reverse inpl) result = idlist before info = show control <> " /= " <> show result in counterexample info $ control == result , testProperty "all before reversed on not found" $ \(w', x', y', z') -> let (_, (before, _)) = splitDirSeqOn (\m2 -> m2^.mMessageId == w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] in uniqueIds [w, x, y, z] ==> idlist (reverse inpl) == idlist before , testProperty "found at first position" $ \(w', x', y', z') -> let (m, _) = splitDirSeqOn (\m2 -> m2^.mMessageId == w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] in validIds inpl && uniqueIds inpl ==> messagePostId w == messagePostId (fromJust m) , testProperty "no before when found at first position" $ \(w', x', y', z') -> let (_, (before, _)) = splitDirSeqOn (\m2 -> m2^.mMessageId == w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist before) in validIds inpl && uniqueIds inpl ==> counterexample info $ null $ unreverseMessages before , testProperty "remaining after when found at first position" $ \(w', x', y', z') -> let (_, (_, afterMsgs)) = splitDirSeqOn (\m2 -> m2^.mMessageId == w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $ idlist (tail inpl) == idlist afterMsgs , testProperty "found at last position" $ \(w', x', y', z') -> let (m, _) = splitDirSeqOn (\m2 -> m2^.mMessageId == z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] in validIds inpl && uniqueIds inpl ==> messagePostId z == messagePostId (fromJust m) , testProperty "reversed before when found at last position" $ \(w', x', y', z') -> let (_, (before, _)) = splitDirSeqOn (\m2 -> m2^.mMessageId == z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist before) in validIds inpl && uniqueIds inpl ==> counterexample info $ idlist (reverse $ init inpl) == idlist before , testProperty "no after when found at last position" $ \(w', x', y', z') -> let (_, (_, afterMsgs)) = splitDirSeqOn (\m2 -> m2^.mMessageId == z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $ null afterMsgs , testProperty "found at midpoint position" $ \(v', w', x', y', z') -> let (m, _) = splitDirSeqOn (\m2 -> m2^.mMessageId == x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z'] in validIds inpl && uniqueIds inpl ==> messagePostId x == messagePostId (fromJust m) , testProperty "reversed before when found at midpoint position" $ \(v', w', x', y', z') -> let (_, (before, _)) = splitDirSeqOn (\m2 -> m2^.mMessageId == x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist before) in validIds inpl && uniqueIds inpl ==> counterexample info $ idlist [w, v] == idlist before , testProperty "after when found at midpoint position" $ \(v', w', x', y', z') -> let (_, (_, afterMsgs)) = splitDirSeqOn (\m2 -> m2^.mMessageId == x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z'] info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $ idlist [y, z] == idlist afterMsgs ] removeTests :: TestTree removeTests = adjustOption (\(QuickCheckMaxRatio n) -> QuickCheckMaxRatio (n*10)) $ testGroup "Remove" [ testProperty "remove on empty" $ \(id1, id2) -> let (remaining, removed) = removeMatchesFromSubset (const True) id1 id2 noMessages in counterexample "got something from nothing" $ null remaining && null removed , testProperty "remove range not found (C9)" $ \(id1, id2, msglist) -> let msgs = makeMsgs msglist ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs in (not $ Just id1 `elem` ids || Just id2 `elem` ids) ==> counterexample "got something from invalid range" $ null removed && length remaining == length ids , testProperty "remove first in range (C6)" $ \(id1, id2, msglist) -> let msgs = makeMsgs msglist ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs in Just id1 `elem` ids && (not $ Just id2 `elem` ids) ==> counterexample ("with idlist " <> show ids <> " remove id1=" <> show id1 <> " should be in " <> show (idlist removed) <> " but not id2=" <> show id2 <> " and remaining=" <> show (idlist remaining)) $ (not $ null removed) && (length remaining /= length ids) && Just id1 `elem` idlist removed && (not $ Just id1 `elem` idlist remaining) , testProperty "remove nothing first in range" $ \(id1, id2, msglist) -> let msgs = makeMsgs msglist ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const False) (Just id1) (Just id2) msgs in Just id1 `elem` ids && (not $ Just id2 `elem` ids) ==> counterexample ("with idlist " <> show ids <> " remove id1=" <> show id1 <> " should be in " <> show (idlist removed) <> " but not id2=" <> show id2 <> " and remaining=" <> show (idlist remaining)) $ (idlist remaining == ids && null removed) , testCase "remove only as last" $ let (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs id1 = MessagePostId $ fromId $ Id "id1" id2 = MessagePostId $ fromId $ Id "id2" msgs = makeMsgs [makeMsg (ServerTime originTime) (Just id2)] in null remaining && length removed == 1 @? "removed" , testProperty "remove last in range (C8)" $ \(idx2, msg, msglist) -> let msgs = makeMsgs $ msg : msglist ids = idlist msgs id2 = ids !! idx2' id1 = MessagePostId $ PI $ Id $ T.intercalate "-" $ map (unId . unPI) $ catMaybes ((\i -> i >>= messageIdPostId) <$> ids) idx2' = abs idx2 `mod` length ids (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) id2 msgs in (isJust id2) && uniqueIds msgs ==> counterexample ("with idlist " <> show ids <> " remove id2=" <> show id2 <> " should be in " <> show (idlist removed) <> " but not id1=" <> show id1 <> " and remaining=" <> show (idlist remaining) ) $ (not $ null removed) && (length remaining /= length ids) && id2 `elem` idlist removed && (not $ id2 `elem` idlist remaining) , testProperty "remove sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (ids', postIds) = splitAt (idx2' + 1) ids (preIds, matchIds) = splitAt idx1' ids' id1 = head matchIds id2 = last matchIds idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] idx1' = head idxl idx2' = last idxl (remaining, removed) = removeMatchesFromSubset (const True) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n idx2=" <> show idx2' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) <> "\n from " <> show preIds <> " and " <> show postIds ) $ (idlist remaining == (preIds <> postIds) && idlist removed == matchIds) , testProperty "remove nothing sub range" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (ids', postIds) = splitAt (idx2' + 1) ids (preIds, matchIds) = splitAt idx1' ids' id1 = head matchIds id2 = last matchIds idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] idx1' = head idxl idx2' = last idxl (remaining, removed) = removeMatchesFromSubset (const False) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n idx2=" <> show idx2' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) <> "\n from " <> show preIds <> " and " <> show postIds ) $ (idlist remaining == ids && null removed) , testProperty "remove first in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (ids', _) = splitAt (idx2' + 1) ids (_, matchIds) = splitAt idx1' ids' id1 = head matchIds id2 = last matchIds idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] idx1' = head idxl idx2' = last idxl (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId == id1) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n idx2=" <> show idx2' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == (filter (/= id1) ids) && idlist removed == [id1]) , testProperty "remove last in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (ids', _) = splitAt (idx2' + 1) ids (_, matchIds) = splitAt idx1' ids' id1 = head matchIds id2 = last matchIds idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] idx1' = head idxl idx2' = last idxl (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId == id2) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n idx2=" <> show idx2' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == (filter (/= id2) ids) && idlist removed == [id2]) , testProperty "remove some in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (ids', _) = splitAt (idx2' + 1) ids (_, matchIds) = splitAt idx1' ids' id1 = head matchIds id2 = last matchIds idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] idx1' = head idxl idx2' = last idxl rmvIds = map snd $ filter (odd . fst) $ zip [(0::Int)..] matchIds (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId `elem` rmvIds) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n idx2=" <> show idx2' <> "\n matching=" <> show matchIds <> "\n removing=" <> show rmvIds <> "\n extracts=" <> show (idlist removed) <> "\n and leaves remaining=" <> show (idlist remaining) <> "\n from " <> show (filter (not . flip elem rmvIds) ids) ) $ (idlist remaining == (filter (not . flip elem rmvIds) ids) && idlist removed == rmvIds) , testProperty "remove from start last Nothing (C4)" $ \(m1, m2, m3, m4, m5, idx1) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (leftIds, matchIds) = splitAt idx1' ids id1 = head matchIds idx1' = abs idx1 `mod` 5 (remaining, removed) = removeMatchesFromSubset (const True) id1 Nothing msgs in uniqueIds msgs && isJust id1 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == leftIds && idlist removed == matchIds) , testProperty "remove from Nothing to offset (C2)" $ \(m1, m2, m3, m4, m5, idx1) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (matchIds, leftIds) = splitAt (idx1' + 1) ids id1 = last matchIds idx1' = abs idx1 `mod` 4 (remaining, removed) = removeMatchesFromSubset (const True) Nothing id1 msgs in uniqueIds msgs && isJust id1 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <> "\n extracts=" <> show (idlist removed) <> "\n matching=" <> show matchIds <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == leftIds && idlist removed == matchIds) , testProperty "remove from start not found last Nothing (C7)" $ \(m1, m2, m3, m4, m5, id1) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const True) id1 Nothing msgs in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> counterexample ("with idlist " <> show ids <> "\n extracts=" <> show (idlist removed) <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == ids && null removed) , testProperty "remove from Nothing to end not found (C3)" $ \(m1, m2, m3, m4, m5, id1) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const True) Nothing id1 msgs in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> counterexample ("with idlist " <> show ids <> "\n extracts=" <> show (idlist removed) <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist remaining == ids && null removed) , testProperty "remove from Nothing to Nothing (C1)" $ \(m1, m2, m3, m4, m5, id1) -> let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] ids = idlist msgs (remaining, removed) = removeMatchesFromSubset (const True) Nothing Nothing msgs in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> counterexample ("with idlist " <> show ids <> "\n extracts=" <> show (idlist removed) <> "\n and leaves remaining=" <> show (idlist remaining) ) $ (idlist removed == ids && null remaining) ] monoid' :: (Show t, Arbitrary t, EqProp t) => t -> (t -> t -> t) -> TestBatch monoid' mempty' mappend' = ( "monoid" , [ ("left identity", leftId mappend' mempty') , ("right identity", rightId mappend' mempty') , ("associativity" , isAssoc mappend') ] ) instanceTests :: TestTree instanceTests = testGroup "Messages Instances" $ map tastyBatch [ (monoid' (emptyDirSeq :: Messages) appendDirSeq) , (monoid' (emptyDirSeq :: RetrogradeMessages) appendDirSeq) ] instance EqProp Messages where a =-= b = idlist a =-= idlist b instance EqProp RetrogradeMessages where a =-= b = idlist a =-= idlist b instance EqProp PostId where a =-= b = (show $ idString a) =-= (show $ idString b) instance EqProp MessageId where (MessagePostId a) =-= (MessagePostId b) = (show $ idString a) =-= (show $ idString b) (MessageUUID a) =-= (MessageUUID b) = (show a) =-= (show b) _ =-= _ = eq True False