From a8657d01ab3d8c2f7f698ec4c613c76078adfc19 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Thu, 1 Jan 2015 17:27:27 -0500 Subject: [PATCH] Add database code for some existing TSN.XML.MLBBoxScore types. --- src/TSN/XML/MLBBoxScore.hs | 227 ++++++++++++++++++++++++++++++++++--- 1 file changed, 211 insertions(+), 16 deletions(-) diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs index b738899..8a15a88 100644 --- a/src/TSN/XML/MLBBoxScore.hs +++ b/src/TSN/XML/MLBBoxScore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -16,21 +17,23 @@ module TSN.XML.MLBBoxScore ( -- * WARNING: these are private but exported to silence warnings MLBBoxScore_MLBBoxScoreTeamBreakdownConstructor(..), MLBBoxScoreConstructor(..), - MLBBoxScoreHomerunStats(..), + MLBBoxScoreHomerunStatsListingConstructor(..), + MLBBoxScoreHomerunStatsListingPitcherConstructor(..), MLBBoxScoreMiscellaneousGameInfo(..), - MLBBoxScoreMiscPitchingStats(..), + MLBBoxScoreMiscPitchingStats(..), -- can go eventually MLBBoxScoreRunsByInningsConstructor(..), MLBBoxScoreTeamBreakdownConstructor(..), - MLBBoxScoreTeamSummary(..) - ) --- AutoRacingResultsListingConstructor(..), --- AutoRacingResultsRaceInformationConstructor(..) ) + MLBBoxScoreTeamSummary(..) -- can go eventually + ) where -- System imports. import Control.Monad ( forM_ ) +import Data.Data ( Data ) +import Data.Maybe ( fromMaybe ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import Data.Typeable ( Typeable ) import Database.Groundhog ( insert, insert_, @@ -137,7 +140,7 @@ data Message = xml_game_breakdown :: MLBBoxScoreGameBreakdownXml, xml_team_summaries :: [MLBBoxScoreTeamSummaryXml], xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml, - xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml, + xml_homerun_stats_listings :: Maybe [MLBBoxScoreHomerunStatsListingXml], xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml, xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) @@ -205,9 +208,125 @@ data MLBBoxScoreGameBreakdownXml = instance Generic MLBBoxScoreGameBreakdownXml -data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats -data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml - deriving (Eq, Show) +data MLBBoxScoreHomerunStatsListingBatter = + MLBBoxScoreHomerunStatsListingBatter { + db_batter_first_name :: String, + db_batter_last_name :: String, + db_batter_rbis :: Int, + db_batter_id :: Int } + deriving (Data, Eq, GHC.Generic, Show, Typeable) + +-- | For 'Generics.to_tuple' +-- +instance Generic MLBBoxScoreHomerunStatsListingBatter + + +data MLBBoxScoreHomerunStatsListing = + MLBBoxScoreHomerunStatsListing { + db_mlb_box_scores_id :: DefaultKey MLBBoxScore, + db_batter :: MLBBoxScoreHomerunStatsListingBatter, -- embedded + db_season_homeruns :: Int } + +data MLBBoxScoreHomerunStatsListingXml = + MLBBoxScoreHomerunStatsListingXml { + xml_batter :: MLBBoxScoreHomerunStatsListingBatter, + xml_season_homeruns :: Int, + xml_pitchers :: [MLBBoxScoreHomerunStatsListingPitcherXml] } + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple' +-- +instance Generic MLBBoxScoreHomerunStatsListingXml + +instance Child MLBBoxScoreHomerunStatsListingXml where + -- | Each 'MLBBoxScoreHomerunStatsListingXml' is contained in (i.e. has a + -- foreign key to) a 'MLBBoxScore'. + -- + type Parent MLBBoxScoreHomerunStatsListingXml = MLBBoxScore + + +instance ToDb MLBBoxScoreHomerunStatsListingXml where + -- | The database representation of + -- 'MLBBoxScoreHomerunStatsListingXml' is + -- 'MLBBoxScoreHomerunStatsListing'. + -- + type Db MLBBoxScoreHomerunStatsListingXml = MLBBoxScoreHomerunStatsListing + +instance FromXmlFk MLBBoxScoreHomerunStatsListingXml where + -- | To convert an 'MLBBoxScoreHomerunStatsListingXml' to an + -- 'MLBBoxScoreHomerunStatsListing', we add the foreign key and + -- drop the pitchers. + -- + from_xml_fk fk MLBBoxScoreHomerunStatsListingXml{..} = + MLBBoxScoreHomerunStatsListing { + db_mlb_box_scores_id = fk, + db_batter = xml_batter, + db_season_homeruns = xml_season_homeruns } + + +-- | This allows us to insert the XML representation +-- 'MLBBoxScoreHomerunStatsListingXml' directly. +-- +instance XmlImportFk MLBBoxScoreHomerunStatsListingXml + + +data MLBBoxScoreHomerunStatsListingPitcher = + MLBBoxScoreHomerunStatsListingPitcher { + db_mlb_box_score_homerun_stats_listings_id :: + DefaultKey MLBBoxScoreHomerunStatsListing, + db_homeruns_off_pitcher :: Int, + db_pitcher_first_name :: String, + db_pitcher_last_name :: String, + db_pitchers_pitcher_id :: Int } + +data MLBBoxScoreHomerunStatsListingPitcherXml = + MLBBoxScoreHomerunStatsListingPitcherXml { + xml_homeruns_off_pitcher :: Int, + xml_pitcher_first_name :: String, + xml_pitcher_last_name :: String, + xml_pitchers_pitcher_id :: Int } + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple' +-- +instance Generic MLBBoxScoreHomerunStatsListingPitcherXml + +instance Child MLBBoxScoreHomerunStatsListingPitcherXml where + -- | Each 'MLBBoxScoreHomerunStatsListingPitcherXml' is contained in + -- (i.e. has a foreign key to) a 'MLBBoxScoreHomerunStatsListing'. + -- + type Parent MLBBoxScoreHomerunStatsListingPitcherXml = + MLBBoxScoreHomerunStatsListing + + +instance ToDb MLBBoxScoreHomerunStatsListingPitcherXml where + -- | The database representation of + -- 'MLBBoxScoreHomerunStatsListingPitcherXml' is + -- 'MLBBoxScoreHomerunStatsListingPitcher'. + -- + type Db MLBBoxScoreHomerunStatsListingPitcherXml = MLBBoxScoreHomerunStatsListingPitcher + + +instance FromXmlFk MLBBoxScoreHomerunStatsListingPitcherXml where + -- | To convert an 'MLBBoxScoreHomerunStatsListingPitcherXml' to an + -- 'MLBBoxScoreHomerunStatsListingPitcher', we add the foreign key. + -- + from_xml_fk fk MLBBoxScoreHomerunStatsListingPitcherXml{..} = + MLBBoxScoreHomerunStatsListingPitcher { + db_mlb_box_score_homerun_stats_listings_id = fk, + db_homeruns_off_pitcher = xml_homeruns_off_pitcher, + db_pitcher_first_name = xml_pitcher_first_name, + db_pitcher_last_name = xml_pitcher_last_name, + db_pitchers_pitcher_id = xml_pitchers_pitcher_id } + + +-- | This allows us to insert the XML representation +-- 'MLBBoxScoreHomerunStatsListingPitcherXml' directly. +-- +instance XmlImportFk MLBBoxScoreHomerunStatsListingPitcherXml + + + data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml @@ -407,6 +526,17 @@ instance DbImport Message where insert_ msg__breakdown + -- Now insert the homerun stats listings, keyed to the message. + -- They need not be present, but we're going to loop through them + -- all anyway, so if we have 'Nothing', we convert that to an + -- empty list instead. This simplifies the `forM_` code. + let listings = fromMaybe [] (xml_homerun_stats_listings m) + forM_ listings $ \listing -> do + -- Insert the listing itself. + listing_id <- insert_xml_fk msg_id listing + -- And all of its pitchers + forM_ (xml_pitchers listing) $ insert_xml_fk listing_id + return ImportSucceeded @@ -423,6 +553,38 @@ mkPersist tsn_codegen_config [groundhog| fields: [db_xml_file_id] +- embedded: MLBBoxScoreHomerunStatsListingBatter + fields: + - name: db_batter_first_name + dbName: batter_first_name + - name: db_batter_last_name + dbName: batter_last_name + - name: db_batter_rbis + dbName: batter_rbis + - name: db_batter_id + dbName: batter_id + +- entity: MLBBoxScoreHomerunStatsListing + dbName: mlb_box_score_homerun_stats_listings + constructors: + - name: MLBBoxScoreHomerunStatsListing + fields: + - name: db_batter + embeddedType: + - {name: batter_first_name, dbName: batter_first_name} + - {name: batter_last_name, dbName: batter_last_name} + - {name: batter_rbis, dbName: batter_rbis} + - {name: batter_id, dbName: batter_id} + +- entity: MLBBoxScoreHomerunStatsListingPitcher + dbName: mlb_box_score_homerun_stats_listing_pitchers + constructors: + - name: MLBBoxScoreHomerunStatsListingPitcher + fields: + - name: db_mlb_box_score_homerun_stats_listings_id + reference: + onDelete: cascade + - entity: MLBBoxScoreTeamBreakdown dbName: mlb_box_scores_team_breakdowns constructors: @@ -487,7 +649,7 @@ pickle_message = pickle_game_breakdown (xpList pickle_team_summary) pickle_misc_pitching_stats - pickle_homerun_stats + (xpOption pickle_homerun_stats_listings) pickle_miscellaneous_game_info (xpElem "time_stamp" xp_time_stamp) where @@ -540,12 +702,45 @@ pickle_home_team :: PU MLBBoxScoreTeamBreakdownXml pickle_home_team = xpElem "HomeTeam" pickle_team -pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml) -pickle_homerun_stats = - xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple') $ xpUnit + +pickle_batter :: PU MLBBoxScoreHomerunStatsListingBatter +pickle_batter = + xpElem "HRS_Batter_ID" $ + xpWrap (from_tuple, to_tuple) $ + xp4Tuple (xpAttr "HRS_Batter_FirstName" $ xpText) + (xpAttr "HRS_Batter_LastName" $ xpText) + (xpAttr "RBIs" $ xpInt) + xpInt where - from_tuple _ = MLBBoxScoreHomerunStatsXml - to_tuple' _ = () + from_tuple = uncurryN MLBBoxScoreHomerunStatsListingBatter + + +pickle_pitcher :: PU MLBBoxScoreHomerunStatsListingPitcherXml +pickle_pitcher = + xpElem "HRS_Pitcher_ID" $ + xpWrap (from_tuple, to_tuple) $ + xp4Tuple (xpAttr "HRS_Homeruns_Off_Pitcher" $ xpInt) + (xpAttr "HRS_Pitcher_FirstName" $ xpText) + (xpAttr "HRS_Pitcher_LastName" $ xpText) + xpInt + where + from_tuple = uncurryN MLBBoxScoreHomerunStatsListingPitcherXml + + +pickle_homerun_stats_listing :: PU MLBBoxScoreHomerunStatsListingXml +pickle_homerun_stats_listing = + xpElem "HRS_Listing" $ + xpWrap (from_tuple, to_tuple) $ + xpTriple pickle_batter + (xpElem "Season_Homeruns" xpInt) + (xpList pickle_pitcher) + where + from_tuple = uncurryN MLBBoxScoreHomerunStatsListingXml + + +pickle_homerun_stats_listings :: PU [MLBBoxScoreHomerunStatsListingXml] +pickle_homerun_stats_listings = + xpElem "Homerun_Stats" $ xpList pickle_homerun_stats_listing pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml -- 2.43.2