Allow empty game <time> elements (with a test case) in TSN.XML.EarlyLine.

[dead/htsn-import.git] / src / TSN / XML / EarlyLine.hs

diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs
index 5aa2254614d5ca16ecba341c59e2c4843d5f81c4..b0d118d046f0905134ad9c91324188b3d55d3103 100644 (file)
--- a/src/TSN/XML/EarlyLine.hs
+++ b/src/TSN/XML/EarlyLine.hs
@@ -227,7 +227,8 @@ data EarlyLineGame =
 --
 data EarlyLineGameXml =
   EarlyLineGameXml {
-    xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
+    xml_game_time :: Maybe UTCTime, -- ^ Only an ambiguous time string,
+                                    --   e.g. \"8:30\". Can be empty.
     xml_away_team :: EarlyLineGameTeamXml,
     xml_home_team :: EarlyLineGameTeamXml,
     xml_over_under :: Maybe String }
@@ -345,11 +346,15 @@ date_to_games fk date =
     games_only :: [EarlyLineGameXml]
     games_only = (map date_game (date_games_with_notes date))
 
-    -- | Stick the date value into the given game.
+    -- | Stick the date value into the given game. If our
+    --   'EarlyLineGameXml' has an 'xml_game_time', then we combine it
+    --   with the day portion of the supplied @date@. If not, then we
+    --   just use @date as-is.
     --
     combine_date_time :: EarlyLineGameXml -> UTCTime
-    combine_date_time elgx =
-      UTCTime (utctDay $ date_value date) (utctDayTime $ xml_game_time elgx)
+    combine_date_time (EarlyLineGameXml (Just t) _ _ _) =
+      UTCTime (utctDay $ date_value date) (utctDayTime t)
+    combine_date_time (EarlyLineGameXml Nothing _ _ _ ) = date_value date
 
     -- | Convert an XML game to a database one.
     --
@@ -502,7 +507,7 @@ pickle_game :: PU EarlyLineGameXml
 pickle_game =
   xpElem "game" $
     xpWrap (from_tuple, to_tuple) $
-    xp4Tuple (xpElem "time" xp_ambiguous_time)
+    xp4Tuple (xpElem "time" (xpOption xp_ambiguous_time))
              pickle_away_team
              pickle_home_team
              (xpElem "over_under" (xpOption xpText))
@@ -582,24 +587,33 @@ early_line_tests =
 --   test does not mean that unpickling succeeded.
 --
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
-  testCase "pickle composed with unpickle is the identity" $ do
-    let path = "test/xml/earlylineXML.xml"
-    (expected, actual) <- pickle_unpickle pickle_message path
-    actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $
+  [ check "pickle composed with unpickle is the identity"
+          "test/xml/earlylineXML.xml",
+
+    check "pickle composed with unpickle is the identity (empty game time)"
+          "test/xml/earlylineXML-empty-game-time.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 =
-  testCase "unpickling succeeds" $ do
-    let path = "test/xml/earlylineXML.xml"
-    actual <- unpickleable path pickle_message
+test_unpickle_succeeds = testGroup "unpickle tests" $
+  [ check "unpickling succeeds"
+          "test/xml/earlylineXML.xml",
 
-    let expected = True
-    actual @?= expected
+    check "unpickling succeeds (empty game time)"
+          "test/xml/earlylineXML-empty-game-time.xml" ]
+  where
+    check desc path = testCase desc $ do
+      actual <- unpickleable path pickle_message
+      let expected = True
+      actual @?= expected
 
 
 
@@ -607,21 +621,26 @@ test_unpickle_succeeds =
 --   record.
 --
 test_on_delete_cascade :: TestTree
-test_on_delete_cascade =
-  testCase "deleting early_lines deletes its children" $ do
-    let path = "test/xml/earlylineXML.xml"
-    results <- unsafe_unpickle path pickle_message
-    let a = undefined :: EarlyLine
-    let b = undefined :: EarlyLineGame
-
-    actual <- withSqliteConn ":memory:" $ runDbConn $ do
-                runMigration silentMigrationLogger $ do
-                  migrate a
-                  migrate b
-                _ <- dbimport results
-                deleteAll a
-                count_a <- countAll a
-                count_b <- countAll b
-                return $ sum [count_a, count_b]
-    let expected = 0
-    actual @?= expected
+test_on_delete_cascade = testGroup "cascading delete tests" $
+  [ check "deleting early_lines deletes its children"
+          "test/xml/earlylineXML.xml",
+
+    check "deleting early_lines deletes its children (empty game time)"
+          "test/xml/earlylineXML-empty-game-time.xml" ]
+  where
+    check desc path = testCase desc $ do
+      results <- unsafe_unpickle path pickle_message
+      let a = undefined :: EarlyLine
+      let b = undefined :: EarlyLineGame
+
+      actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                  runMigration silentMigrationLogger $ do
+                    migrate a
+                    migrate b
+                  _ <- dbimport results
+                  deleteAll a
+                  count_a <- countAll a
+                  count_b <- countAll b
+                  return $ sum [count_a, count_b]
+      let expected = 0
+      actual @?= expected