From 7e243c5b8f2d34f31c81df78ba799d1e2123ade2 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 31 Dec 2014 19:24:02 -0500 Subject: [PATCH] Add more DB code to TSN.XML.MLBBoxScore. --- src/TSN/XML/MLBBoxScore.hs | 184 ++++++++++++++++++++++++++++++++----- 1 file changed, 161 insertions(+), 23 deletions(-) diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs index 39109b2..b738899 100644 --- a/src/TSN/XML/MLBBoxScore.hs +++ b/src/TSN/XML/MLBBoxScore.hs @@ -14,11 +14,13 @@ module TSN.XML.MLBBoxScore ( -- * Tests -- auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings + MLBBoxScore_MLBBoxScoreTeamBreakdownConstructor(..), MLBBoxScoreConstructor(..), - MLBBoxScoreGameBreakdown(..), MLBBoxScoreHomerunStats(..), MLBBoxScoreMiscellaneousGameInfo(..), MLBBoxScoreMiscPitchingStats(..), + MLBBoxScoreRunsByInningsConstructor(..), + MLBBoxScoreTeamBreakdownConstructor(..), MLBBoxScoreTeamSummary(..) ) -- AutoRacingResultsListingConstructor(..), @@ -26,10 +28,12 @@ module TSN.XML.MLBBoxScore ( where -- System imports. +import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( insert, + insert_, migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( @@ -60,8 +64,11 @@ import TSN.Picklers ( xp_time, xp_time_stamp ) import TSN.Team ( Team(..), FromXmlFkTeams(..) ) +import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), + FromXml(..), + FromXmlFk(..), ToDb(..) ) @@ -140,7 +147,6 @@ data Message = -- instance Generic Message - instance ToDb Message where -- | The database analogue of a 'Message' is a 'MLBBoxScore'. -- @@ -155,19 +161,14 @@ instance ToDb Message where instance Child Message where type Parent Message = MLBBoxScore - --- | The 'FromXml' instance for 'Message' is required for the +-- | The 'FromXmlFk' instance for 'Message' is required for the -- 'XmlImport' instance. --- instance FromXmlFkTeams Message where -- | To convert a 'Message' to an 'MLBBoxScore', we drop the -- teams/summaries and combine the date/time. Also missing are the -- embedded elements game_breakdown, homerun_stats, and -- miscellaneous_game_info. -- - -- The first \"missing\" argument is the foreign key to its - -- parent, which it doesn't have. (See the 'Child' instance.) - -- from_xml_fk_teams _ vteam_id hteam_id Message{..} = MLBBoxScore { db_xml_file_id = xml_xml_file_id, @@ -190,15 +191,13 @@ instance FromXmlFkTeams Message where UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time) - data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show) -data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown data MLBBoxScoreGameBreakdownXml = MLBBoxScoreGameBreakdownXml { - xml_away_team :: MLBBoxScoreGameBreakdownTeamXml, - xml_home_team :: MLBBoxScoreGameBreakdownTeamXml } + xml_away_team :: MLBBoxScoreTeamBreakdownXml, + xml_home_team :: MLBBoxScoreTeamBreakdownXml } deriving (Eq, GHC.Generic, Show) -- | For 'Generics.to_tuple' @@ -214,8 +213,15 @@ data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml deriving (Eq, Show) -data MLBBoxScoreGameBreakdownTeamXml = - MLBBoxScoreGameBreakdownTeamXml { + +-- Team Breakdown +data MLBBoxScoreTeamBreakdown = + MLBBoxScoreTeamBreakdown { + db_runs :: Int, + db_hits :: Int, + db_errors :: Int } +data MLBBoxScoreTeamBreakdownXml = + MLBBoxScoreTeamBreakdownXml { xml_runs_by_innings :: [MLBBoxScoreRunsByInningsXml], xml_runs :: Int, xml_hits :: Int, @@ -224,8 +230,38 @@ data MLBBoxScoreGameBreakdownTeamXml = -- | For 'Generics.to_tuple'. -instance Generic MLBBoxScoreGameBreakdownTeamXml +instance Generic MLBBoxScoreTeamBreakdownXml +instance ToDb MLBBoxScoreTeamBreakdownXml where + -- | The database analogue of a 'MLBBoxScoreTeamBreakdownXml' is + -- a 'MLBBoxScoreTeamBreakdown'. + -- + type Db MLBBoxScoreTeamBreakdownXml = MLBBoxScoreTeamBreakdown + + +-- | The 'FromXml' instance for 'MLBBoxScoreTeamBreakdownXml' is +-- required for the 'XmlImport' instance. +-- +instance FromXml MLBBoxScoreTeamBreakdownXml where + -- | To convert a 'MLBBoxScoreTeamBreakdownXml' to an + -- 'MLBBoxScoreTeamBreakdown', we just drop the + -- 'xml_runs_by_innings'. + -- + from_xml MLBBoxScoreTeamBreakdownXml{..} = + MLBBoxScoreTeamBreakdown { + db_runs = xml_runs, + db_hits = xml_hits, + db_errors = xml_errors } + +instance XmlImport MLBBoxScoreTeamBreakdownXml + +-- Runs by innings +data MLBBoxScoreRunsByInnings = + MLBBoxScoreRunsByInnings { + db_mlb_box_scores_team_breakdowns_id :: DefaultKey + MLBBoxScoreTeamBreakdown, + db_runs_by_innings_inning_number :: Int, + db_runs_by_innings_runs :: Int } data MLBBoxScoreRunsByInningsXml = MLBBoxScoreRunsByInningsXml { @@ -234,11 +270,59 @@ data MLBBoxScoreRunsByInningsXml = deriving (Eq, GHC.Generic, Show) +-- * MLBBoxScore_MLBBoxScoreTeamSummary + +-- | Mapping between 'MLBBoxScore' records and +-- 'MLBBoxScoreTeamSummary' records in the database. We don't use +-- the names anywhere, so we let Groundhog choose them. +-- +data MLBBoxScore_MLBBoxScoreTeamBreakdown = + MLBBoxScore_MLBBoxScoreTeamBreakdown + (DefaultKey MLBBoxScore) + (DefaultKey MLBBoxScoreTeamBreakdown) -- Away team + (DefaultKey MLBBoxScoreTeamBreakdown) -- Home team + + + -- | For 'Generics.to_tuple'. -- instance Generic MLBBoxScoreRunsByInningsXml +instance ToDb MLBBoxScoreRunsByInningsXml where + -- | The database analogue of a 'MLBBoxScoreRunsByInningsXml' is + -- a 'MLBBoxScoreRunsByInnings'. + -- + type Db MLBBoxScoreRunsByInningsXml = MLBBoxScoreRunsByInnings + + +instance Child MLBBoxScoreRunsByInningsXml where + -- | Each 'MLBBoxScoreRunsByInningsXml' is contained in (i.e. has a + -- foreign key to) a 'MLBBoxScoreTeamBreakdownXml'. + -- + type Parent MLBBoxScoreRunsByInningsXml = MLBBoxScoreTeamBreakdown + + +instance FromXmlFk MLBBoxScoreRunsByInningsXml where + -- | To convert an 'MLBBoxScoreRunsByInningsXml' to an + -- 'MLBBoxScoreRunsByInnings', we add the foreign key and copy + -- everything else verbatim. + -- + from_xml_fk fk MLBBoxScoreRunsByInningsXml{..} = + MLBBoxScoreRunsByInnings { + db_mlb_box_scores_team_breakdowns_id = fk, + db_runs_by_innings_inning_number = xml_runs_by_innings_inning_number, + db_runs_by_innings_runs = xml_runs_by_innings_runs } + + +-- | This allows us to insert the XML representation +-- 'MLBBoxScoreRunsByInningsXml' directly. +-- +instance XmlImportFk MLBBoxScoreRunsByInningsXml + + + + data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats data MLBBoxScoreMiscPitchingStatsXml = MLBBoxScoreMiscPitchingStatsXml { @@ -296,12 +380,33 @@ instance DbImport Message where vteam_fk <- insert vteam hteam_fk <- insert hteam - -- Now we can key the message to the teams we just inserted. - -- The message has no parent, so we pass in undefined. + -- Now we can key the message to the teams/breakdowns we just + -- inserted. let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m - _ <- insert db_msg + msg_id <- insert db_msg + + -- Next, the vteam/hteam breakdowns, also needed to construct the + -- main message record + let vteam_bd = xml_away_team $ xml_game_breakdown m + let hteam_bd = xml_home_team $ xml_game_breakdown m + + vteam_bd_fk <- insert_xml vteam_bd + hteam_bd_fk <- insert_xml hteam_bd + + -- Insert the runs-by-innings associated with the vteam/hteam + -- breakdowns. + forM_ (xml_runs_by_innings vteam_bd) $ insert_xml_fk_ vteam_bd_fk + forM_ (xml_runs_by_innings hteam_bd) $ insert_xml_fk_ hteam_bd_fk + + -- Now the join table record that ties the message to its two team + -- breakdowns. + let msg__breakdown = MLBBoxScore_MLBBoxScoreTeamBreakdown + msg_id + vteam_bd_fk + hteam_bd_fk + + insert_ msg__breakdown - -- Now get the hteam return ImportSucceeded @@ -317,6 +422,39 @@ mkPersist tsn_codegen_config [groundhog| # Prevent multiple imports of the same message. fields: [db_xml_file_id] + +- entity: MLBBoxScoreTeamBreakdown + dbName: mlb_box_scores_team_breakdowns + constructors: + - name: MLBBoxScoreTeamBreakdown + +- entity: MLBBoxScoreRunsByInnings + dbName: mlb_box_scores_team_breakdowns_runs_by_innings + constructors: + - name: MLBBoxScoreRunsByInnings + fields: + - name: db_mlb_box_scores_team_breakdowns_id + reference: + onDelete: cascade + + +- entity: MLBBoxScore_MLBBoxScoreTeamBreakdown + dbName: mlb_box_scores__mlb_box_scores_team_breakdowns + constructors: + - name: MLBBoxScore_MLBBoxScoreTeamBreakdown + fields: + - name: mLBBoxScore_MLBBoxScoreTeamBreakdown0 + dbName: mlb_box_scores_id + reference: + onDelete: cascade + - name: mLBBoxScore_MLBBoxScoreTeamBreakdown1 + dbName: mlb_box_scores_team_breakdowns_away_team_id + reference: + onDelete: cascade + - name: mLBBoxScore_MLBBoxScoreTeamBreakdown2 + dbName: db_mlb_box_scores_team_breakdowns_home_team_id + reference: + onDelete: cascade |] @@ -383,7 +521,7 @@ pickle_runs_by_innings = from_tuple = uncurry MLBBoxScoreRunsByInningsXml -pickle_team :: PU MLBBoxScoreGameBreakdownTeamXml +pickle_team :: PU MLBBoxScoreTeamBreakdownXml pickle_team = xpWrap (from_tuple, to_tuple) $ xp4Tuple (xpList pickle_runs_by_innings) @@ -391,14 +529,14 @@ pickle_team = (xpElem "Hits" xpInt) (xpElem "Errors" xpInt) where - from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml + from_tuple = uncurryN MLBBoxScoreTeamBreakdownXml -pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml +pickle_away_team :: PU MLBBoxScoreTeamBreakdownXml pickle_away_team = xpElem "AwayTeam" pickle_team -pickle_home_team :: PU MLBBoxScoreGameBreakdownTeamXml +pickle_home_team :: PU MLBBoxScoreTeamBreakdownXml pickle_home_team = xpElem "HomeTeam" pickle_team -- 2.43.2