--
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 }
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.
--
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))
-- 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
-- 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
projects / dead / htsn-import.git / commitdiff