X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FMLBBoxScore.hs;h=b7388991b9ce2b8d5aaa68bdf01be4992fda63ac;hb=7e243c5b8f2d34f31c81df78ba799d1e2123ade2;hp=ee6ad443e6ba188de142af92bfc7cea307923510;hpb=9a2ac3406dfffd9d0af4c95c3eb038fa4df145c1;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs index ee6ad44..b738899 100644 --- a/src/TSN/XML/MLBBoxScore.hs +++ b/src/TSN/XML/MLBBoxScore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,9 +12,17 @@ module TSN.XML.MLBBoxScore ( dtd, pickle_message, -- * Tests --- auto_racing_results_tests, + -- auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings - MLBBoxScoreConstructor(..) ) + MLBBoxScore_MLBBoxScoreTeamBreakdownConstructor(..), + MLBBoxScoreConstructor(..), + MLBBoxScoreHomerunStats(..), + MLBBoxScoreMiscellaneousGameInfo(..), + MLBBoxScoreMiscPitchingStats(..), + MLBBoxScoreRunsByInningsConstructor(..), + MLBBoxScoreTeamBreakdownConstructor(..), + MLBBoxScoreTeamSummary(..) + ) -- AutoRacingResultsListingConstructor(..), -- AutoRacingResultsRaceInformationConstructor(..) ) where @@ -23,39 +32,31 @@ import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( - countAll, - deleteAll, insert, - migrate, - runMigration, - silentMigrationLogger ) + insert_, + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) -import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) -import Test.Tasty ( TestTree, testGroup ) -import Test.Tasty.HUnit ( (@?=), testCase ) +import qualified GHC.Generics as GHC ( Generic ) import Text.XML.HXT.Core ( PU, xp4Tuple, - xp11Tuple, xp23Tuple, xpAttr, - xpDefault, xpElem, xpInt, xpList, xpOption, xpPair, - xpPrim, xpText, xpTriple, xpUnit, xpWrap ) -- Local imports. +import Generics ( Generic(..), to_tuple ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( @@ -68,10 +69,7 @@ import Xml ( Child(..), FromXml(..), FromXmlFk(..), - ToDb(..), - pickle_unpickle, - unpickleable, - unsafe_unpickle ) + ToDb(..) ) -- | The DTD to which this module corresponds. Used to invoke dbimport. @@ -142,8 +140,12 @@ data Message = xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml, xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message instance ToDb Message where -- | The database analogue of a 'Message' is a 'MLBBoxScore'. @@ -159,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, @@ -194,16 +191,19 @@ 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 } - deriving (Eq, Show) + xml_away_team :: MLBBoxScoreTeamBreakdownXml, + xml_home_team :: MLBBoxScoreTeamBreakdownXml } + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple' +-- +instance Generic MLBBoxScoreGameBreakdownXml + data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml @@ -213,19 +213,114 @@ 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, xml_errors :: Int } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +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 { xml_runs_by_innings_inning_number :: Int, xml_runs_by_innings_runs :: Int } - deriving (Eq, Show) + 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 @@ -234,21 +329,37 @@ data MLBBoxScoreMiscPitchingStatsXml = xml_wild_pitches :: Maybe Int, xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml], xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +instance Generic MLBBoxScoreMiscPitchingStatsXml + data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml = MLBBoxScoreMiscPitchingStatsIntentionalWalkXml { xml_iw_batter_id :: Int, xml_iw_pitcher_id :: Int, xml_iw_number_of_times_walked :: Int } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +instance Generic MLBBoxScoreMiscPitchingStatsIntentionalWalkXml + data MLBBoxScoreMiscPitchingStatsHitByPitchXml = MLBBoxScoreMiscPitchingStatsHitByPitchXml { xml_hbp_batter_id :: Int, xml_hbp_pitcher_id :: Int, xml_hbp_number_of_times_hit :: Int } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic MLBBoxScoreMiscPitchingStatsHitByPitchXml + -- -- * Database @@ -269,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 msg_id <- insert db_msg - -- Now get the hteam + -- 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 + return ImportSucceeded @@ -290,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 |] @@ -327,37 +492,14 @@ 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_game_id m, - xml_schedule_id m, - xml_vteam m, - xml_hteam m, - xml_vteam_id m, - xml_hteam_id m, - xml_season m, - xml_season_type m, - xml_title m, - xml_game_date m, - xml_game_time m, - xml_game_number m, - xml_capacity m, - xml_game_breakdown m, - xml_team_summaries m, - xml_misc_pitching_stats m, - xml_homerun_stats m, - xml_miscellaneous_game_info m, - xml_time_stamp m) pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml pickle_team_summary = - xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit + xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple') $ xpUnit where from_tuple _ = MLBBoxScoreTeamSummaryXml - to_tuple _ = () + to_tuple' _ = () pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml pickle_game_breakdown = @@ -367,7 +509,6 @@ pickle_game_breakdown = pickle_home_team where from_tuple = uncurry MLBBoxScoreGameBreakdownXml - to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team) pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml @@ -378,9 +519,9 @@ pickle_runs_by_innings = xpInt where from_tuple = uncurry MLBBoxScoreRunsByInningsXml - to_tuple MLBBoxScoreRunsByInningsXml{..} = - (xml_runs_by_innings_inning_number, xml_runs_by_innings_runs) + +pickle_team :: PU MLBBoxScoreTeamBreakdownXml pickle_team = xpWrap (from_tuple, to_tuple) $ xp4Tuple (xpList pickle_runs_by_innings) @@ -388,24 +529,23 @@ pickle_team = (xpElem "Hits" xpInt) (xpElem "Errors" xpInt) where - from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml - to_tuple MLBBoxScoreGameBreakdownTeamXml{..} = - (xml_runs_by_innings, xml_runs, xml_hits, xml_errors) + 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 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml) pickle_homerun_stats = - xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit + xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple') $ xpUnit where from_tuple _ = MLBBoxScoreHomerunStatsXml - to_tuple _ = () + to_tuple' _ = () pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml @@ -417,8 +557,7 @@ pickle_misc_pitching_stats = pickle_hits_by_pitch where from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml - to_tuple MLBBoxScoreMiscPitchingStatsXml{..} = - (xml_wild_pitches, xml_intentional_walks, xml_hits_by_pitch) + pickle_intentional_walks :: PU [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml] @@ -430,8 +569,7 @@ pickle_intentional_walks = (xpElem "IW_Number_Of_Times_Walked" xpInt) where from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml - to_tuple MLBBoxScoreMiscPitchingStatsIntentionalWalkXml{..} = - (xml_iw_batter_id, xml_iw_pitcher_id, xml_iw_number_of_times_walked) + pickle_hits_by_pitch :: PU [MLBBoxScoreMiscPitchingStatsHitByPitchXml] @@ -443,14 +581,12 @@ pickle_hits_by_pitch = (xpElem "HBP_Number_Of_Times_Hit" xpInt) where from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsHitByPitchXml - to_tuple MLBBoxScoreMiscPitchingStatsHitByPitchXml{..} = - (xml_hbp_batter_id, xml_hbp_pitcher_id, xml_hbp_number_of_times_hit) pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml pickle_miscellaneous_game_info = - xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit + xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple') $ xpUnit where from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml - to_tuple _ = () + to_tuple' _ = ()