X-Git-Url: https://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FEarlyLine.hs;h=5ec81a37e14bb18a6f197ab1f68a4d134e1a8649;hb=7f22e74b4e21b1fd943c69214bffbd39961baa66;hp=5aa2254614d5ca16ecba341c59e2c4843d5f81c4;hpb=6674a915d50cc41e4c5b12e42f2fcbb65e2bf195;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs index 5aa2254..5ec81a3 100644 --- a/src/TSN/XML/EarlyLine.hs +++ b/src/TSN/XML/EarlyLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -36,6 +37,7 @@ where import Control.Monad ( join ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, @@ -49,6 +51,7 @@ import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -120,7 +123,11 @@ data Message = xml_title :: String, xml_dates :: [EarlyLineDate], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector Message instance ToDb Message where @@ -171,10 +178,21 @@ instance XmlImport Message -- with. But it allows us to pickle and unpickle correctly at least. -- data EarlyLineGameWithNote = - EarlyLineGameWithNote { - date_note :: Maybe String, - date_game :: EarlyLineGameXml } - deriving (Eq, Show) + EarlyLineGameWithNote + (Maybe String) -- date_note, unused + EarlyLineGameXml -- date_game + deriving (Eq, GHC.Generic, Show) + +-- | Accessor for the game within a 'EarlyLineGameWithNote'. We define +-- this ourselves to avoid an unused field warning for date_note. +-- +date_game :: EarlyLineGameWithNote -> EarlyLineGameXml +date_game (EarlyLineGameWithNote _ g) = g + +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineGameWithNote + -- | XML representation of a \. It has a \"value\" attribute @@ -186,7 +204,11 @@ data EarlyLineDate = EarlyLineDate { date_value :: UTCTime, date_games_with_notes :: [EarlyLineGameWithNote] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineDate @@ -227,13 +249,18 @@ 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 } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineGameXml + -- * EarlyLineGameTeam / EarlyLineGameTeamXml @@ -249,7 +276,7 @@ data EarlyLineGameXml = -- data EarlyLineGameTeam = EarlyLineGameTeam { - db_rotation_number :: Int, + db_rotation_number :: Maybe Int, -- ^ Usually there but sometimes empty. db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\". db_team_name :: Maybe String, -- ^ NOT optional, see the data type docs. db_pitcher :: Maybe String -- ^ Optional in MLB_earlylineXML.dtd, @@ -280,7 +307,7 @@ data EarlyLineGameTeam = -- data EarlyLineGameTeamXml = EarlyLineGameTeamXml { - xml_rotation_number :: Int, + xml_rotation_number :: Maybe Int, xml_line_attr :: Maybe String, xml_team_name_attr :: Maybe String, xml_team_name_text :: Maybe String, @@ -345,22 +372,26 @@ 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 :: Maybe UTCTime -> UTCTime + combine_date_time (Just t) = + UTCTime (utctDay $ date_value date) (utctDayTime t) + combine_date_time Nothing = date_value date -- | Convert an XML game to a database one. -- convert_game :: EarlyLineGameXml -> EarlyLineGame - convert_game gx = + convert_game EarlyLineGameXml{..} = EarlyLineGame { db_early_lines_id = fk, - db_game_time = combine_date_time gx, - db_away_team = from_xml (xml_away_team gx), - db_home_team = from_xml (xml_home_team gx), - db_over_under = xml_over_under gx } + db_game_time = combine_date_time xml_game_time, + db_away_team = from_xml xml_away_team, + db_home_team = from_xml xml_home_team, + db_over_under = xml_over_under } -- @@ -449,7 +480,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp7Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -459,13 +490,6 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_category m, - xml_sport m, - xml_title m, - xml_dates m, - xml_time_stamp m) @@ -474,12 +498,11 @@ pickle_message = -- pickle_game_with_note :: PU EarlyLineGameWithNote pickle_game_with_note = - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpOption $ xpElem "note" xpText) pickle_game where from_tuple = uncurry EarlyLineGameWithNote - to_tuple m = (date_note m, date_game m) -- | Pickler for the \ elements within each \. @@ -487,12 +510,11 @@ pickle_game_with_note = pickle_date :: PU EarlyLineDate pickle_date = xpElem "date" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "value" xp_early_line_date) (xpList pickle_game_with_note) where from_tuple = uncurry EarlyLineDate - to_tuple m = (date_value m, date_games_with_notes m) @@ -501,17 +523,13 @@ pickle_date = pickle_game :: PU EarlyLineGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ - xp4Tuple (xpElem "time" xp_ambiguous_time) + xpWrap (from_tuple, H.convert) $ + xp4Tuple (xpElem "time" (xpOption xp_ambiguous_time)) pickle_away_team pickle_home_team (xpElem "over_under" (xpOption xpText)) where from_tuple = uncurryN EarlyLineGameXml - to_tuple m = (xml_game_time m, - xml_away_team m, - xml_home_team m, - xml_over_under m) @@ -542,8 +560,8 @@ pickle_home_team = xpElem "teamH" pickle_team -- pickle_team :: PU EarlyLineGameTeamXml pickle_team = - xpWrap (from_tuple, to_tuple) $ - xp6Tuple (xpAttr "rotation" xpInt) + xpWrap (from_tuple, to_tuple') $ + xp6Tuple (xpAttr "rotation" (xpOption xpInt)) (xpOption $ xpAttr "line" (xpOption xpText)) (xpOption $ xpAttr "name" xpText) (xpOption xpText) @@ -553,7 +571,7 @@ pickle_team = from_tuple (u,v,w,x,y,z) = EarlyLineGameTeamXml u (join v) w x (join y) (join z) - to_tuple (EarlyLineGameTeamXml u v w x y z) = + to_tuple' (EarlyLineGameTeamXml u v w x y z) = (u, double_just v, w, x, double_just y, double_just z) where double_just val = case val of @@ -582,24 +600,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 +634,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