--- | Warning, succeess of this test does not mean that unpickling
--- succeeded.
-test_pickle_of_unpickle_is_identity1 :: TestTree
-test_pickle_of_unpickle_is_identity1 =
- testCase "pickle composed with unpickle is the identity" $ do
- let path = "test/xml/newsxml.xml"
- (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
- actual @?= expected
-
--- | Repeat of 'test_pickle_of_unpickle_is_identity1' with a different
--- XML file.
-test_pickle_of_unpickle_is_identity2 :: TestTree
-test_pickle_of_unpickle_is_identity2 =
- testCase "pickle composed with unpickle is the identity (with Editor)" $ do
- let path = "test/xml/newsxml-with-editor.xml"
- (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
- actual @?= expected
-
-test_unpickle_succeeds1 :: TestTree
-test_unpickle_succeeds1 =
- testCase "unpickling succeeds" $ do
- let path = "test/xml/newsxml.xml"
- actual <- unpickleable path pickle_message
- let expected = True
- actual @?= expected
-
-test_unpickle_succeeds2 :: TestTree
-test_unpickle_succeeds2 =
- testCase "unpickling succeeds (with Editor)" $ do
- let path = "test/xml/newsxml-with-editor.xml"
- actual <- unpickleable path pickle_message
- let expected = True
- actual @?= expected
+-- | If we unpickle something and then pickle it, we should wind up
+-- with the same thing we started with. WARNING: success of this
+-- test does not mean that unpickling succeeded.
+--
+test_pickle_of_unpickle_is_identity :: TestTree
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+ [ check "pickle composed with unpickle is the identity"
+ "test/xml/newsxml.xml",
+
+ check "pickle composed with unpickle is the identity (with Editor)"
+ "test/xml/newsxml-with-editor.xml",
+
+ check "pickle composed with unpickle is the identity (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml" ]
+ where
+ check desc path = testCase desc $ do
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds = testGroup "unpickle tests"
+ [ check "unpickling succeeds"
+ "test/xml/newsxml.xml",
+
+ check "unpickling succeeds (with Editor)"
+ "test/xml/newsxml-with-editor.xml",
+
+ check "unpickling succeeds (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml" ]
+ where
+ check desc path = testCase desc $ do
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+-- record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade = testGroup "cascading delete tests"
+ [ check "deleting news deletes its children"
+ "test/xml/newsxml.xml"
+ 4 -- 2 news_teams and 2 news_locations that should remain.
+ ,
+ check "deleting news deletes its children (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml"
+ 4 -- 2 news_teams and 2 news_locations
+ ]
+ where
+ check desc path expected = testCase desc $ do
+ news <- unsafe_unpickle path pickle_message
+ let a = undefined :: Location
+ let b = undefined :: News
+ let c = undefined :: Team
+ let d = undefined :: News_Team
+ let e = undefined :: News_Location
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ migrate c
+ migrate d
+ migrate e
+ _ <- dbimport news
+ deleteAll b
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ count_d <- countAll d
+ count_e <- countAll e
+ return $ count_a + count_b + count_c + count_d + count_e
+ actual @?= expected
+
+
+-- | We want to make sure the single-SMS documents and the multi-SMS
+-- documents are identified correctly.
+--
+test_sms_detected_correctly :: TestTree
+test_sms_detected_correctly =
+ testGroup "newsxml SMS count determined correctly"
+ [ check "test/xml/newsxml.xml"
+ "single SMS detected correctly"
+ True,
+ check "test/xml/newsxml-multiple-sms.xml"
+ "multiple SMS detected correctly"
+ False ]
+ where
+ check path desc expected = testCase desc $ do
+ xmltree <- unsafe_read_document path
+ let actual = has_only_single_sms xmltree
+ actual @?= expected