{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"MLB_Boxscore_XML.dtd\". -- module TSN.XML.MLBBoxScore ( dtd, pickle_message, -- * Tests -- auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings MLBBoxScoreConstructor(..) ) -- AutoRacingResultsListingConstructor(..), -- AutoRacingResultsRaceInformationConstructor(..) ) where -- System imports. import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( countAll, deleteAll, insert, migrate, runMigration, silentMigrationLogger ) 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 Text.XML.HXT.Core ( PU, xp4Tuple, xp11Tuple, xp23Tuple, xpAttr, xpDefault, xpElem, xpInt, xpList, xpOption, xpPair, xpPrim, xpText, xpTriple, xpUnit, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date, xp_time, xp_time_stamp ) import TSN.Team ( Team(..), FromXmlFkTeams(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "MLB_Boxscore_XML.dtd" -- -- * DB/XML data types -- -- MLBBoxScore/Message -- | Database representation of a 'Message'. The vteam/hteam have been -- removed since they use the TSN.Team representation. The -- 'xml_game_date' and 'xml_game_time' fields have also been -- combined into 'db_game_time'. Finally, the summaries are missing -- since they'll be keyed to us. -- data MLBBoxScore = MLBBoxScore { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_game_id :: Int, db_schedule_id :: Int, db_vteam_id :: DefaultKey Team, db_hteam_id :: DefaultKey Team, db_season :: String, db_season_type :: String, db_game_time :: UTCTime, db_game_number :: Int, db_capacity :: Int, db_title :: String, db_time_stamp :: UTCTime } -- | XML Representation of an 'MBLBoxScore'. It has the same fields, -- but in addition contains the hteam/vteams and a game_date that -- will eventually be combined with the time. It also has a list of -- summaries. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_game_id :: Int, xml_schedule_id :: Int, xml_vteam :: String, xml_hteam :: String, xml_vteam_id :: String, xml_hteam_id :: String, xml_season :: String, xml_season_type :: String, xml_title :: String, xml_game_date :: UTCTime, xml_game_time :: UTCTime, xml_game_number :: Int, xml_capacity :: Int, xml_game_breakdown :: MLBBoxScoreGameBreakdownXml, xml_team_summaries :: [MLBBoxScoreTeamSummaryXml], xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml, xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml, xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database analogue of a 'Message' is a 'MLBBoxScore'. -- type Db Message = MLBBoxScore -- | This ugly hack allows us to make 'Message' an instance of -- 'FromXmlFkTeams'. That class usually requires that its instances -- have a parent, but 'Message' does not. So we declare it the -- parent of itself, and then ignore it. instance Child Message where type Parent Message = MLBBoxScore -- | The 'FromXml' 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, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_game_id = xml_game_id, db_schedule_id = xml_schedule_id, db_vteam_id = vteam_id, db_hteam_id = hteam_id, db_season = xml_season, db_season_type = xml_season_type, db_game_time = make_game_time, db_game_number = xml_game_number, db_capacity = xml_capacity, db_title = xml_title, db_time_stamp = xml_time_stamp } where make_game_time = 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) data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml deriving (Eq, Show) data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml deriving (Eq, Show) data MLBBoxScoreGameBreakdownTeamXml = MLBBoxScoreGameBreakdownTeamXml { xml_runs_by_innings :: [MLBBoxScoreRunsByInningsXml], xml_runs :: Int, xml_hits :: Int, xml_errors :: Int } deriving (Eq, Show) data MLBBoxScoreRunsByInningsXml = MLBBoxScoreRunsByInningsXml { xml_runs_by_innings_inning_number :: Int, xml_runs_by_innings_runs :: Int } deriving (Eq, Show) data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats data MLBBoxScoreMiscPitchingStatsXml = MLBBoxScoreMiscPitchingStatsXml { xml_wild_pitches :: Maybe Int, xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml], xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] } deriving (Eq, Show) data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml = MLBBoxScoreMiscPitchingStatsIntentionalWalkXml { xml_iw_batter_id :: Int, xml_iw_pitcher_id :: Int, xml_iw_number_of_times_walked :: Int } deriving (Eq, Show) data MLBBoxScoreMiscPitchingStatsHitByPitchXml = MLBBoxScoreMiscPitchingStatsHitByPitchXml { xml_hbp_batter_id :: Int, xml_hbp_pitcher_id :: Int, xml_hbp_number_of_times_hit :: Int } deriving (Eq, Show) -- -- * Database -- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: MLBBoxScore) -- | We insert the message. dbimport m = do -- First, get the vteam/hteam out of the XML message. let vteam = Team (xml_vteam_id m) Nothing (Just $ xml_vteam m) let hteam = Team (xml_hteam_id m) Nothing (Just $ xml_hteam m) -- Insert them... 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. let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m msg_id <- insert db_msg -- Now get the hteam return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: MLBBoxScore dbName: mlb_box_scores constructors: - name: MLBBoxScore uniques: - name: unique_mlb_box_scores type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] |] -- -- * Pickling -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ xp23Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) (xpElem "vteam" xpText) (xpElem "hteam" xpText) (xpElem "vteam_id" xpText) (xpElem "hteam_id" xpText) (xpElem "Season" xpText) (xpElem "SeasonType" xpText) (xpElem "title" xpText) (xpElem "Game_Date" xp_date) (xpElem "Game_Time" xp_time) (xpElem "GameNumber" xpInt) (xpElem "Capacity" xpInt) pickle_game_breakdown (xpList pickle_team_summary) pickle_misc_pitching_stats pickle_homerun_stats pickle_miscellaneous_game_info (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 where from_tuple _ = MLBBoxScoreTeamSummaryXml to_tuple _ = () pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml pickle_game_breakdown = xpElem "Game_Breakdown" $ xpWrap (from_tuple, to_tuple) $ xpPair pickle_away_team pickle_home_team where from_tuple = uncurry MLBBoxScoreGameBreakdownXml to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team) pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml pickle_runs_by_innings = xpElem "Runs_By_Innings" $ xpWrap (from_tuple, to_tuple) $ xpPair (xpAttr "Inning" xpInt) xpInt where from_tuple = uncurry MLBBoxScoreRunsByInningsXml to_tuple MLBBoxScoreRunsByInningsXml{..} = (xml_runs_by_innings_inning_number, xml_runs_by_innings_runs) pickle_team = xpWrap (from_tuple, to_tuple) $ xp4Tuple (xpList pickle_runs_by_innings) (xpElem "Runs" xpInt) (xpElem "Hits" xpInt) (xpElem "Errors" xpInt) where from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml to_tuple MLBBoxScoreGameBreakdownTeamXml{..} = (xml_runs_by_innings, xml_runs, xml_hits, xml_errors) pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml pickle_away_team = xpElem "AwayTeam" pickle_team pickle_home_team :: PU MLBBoxScoreGameBreakdownTeamXml 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 where from_tuple _ = MLBBoxScoreHomerunStatsXml to_tuple _ = () pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml pickle_misc_pitching_stats = xpElem "Misc_Pitching_Stats" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpOption $ xpElem "Wild_Pitches" xpInt) pickle_intentional_walks 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] pickle_intentional_walks = xpElem "Intentional_Walks" $ xpList $ xpElem "IW_Listing" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpElem "IW_Batter_ID" xpInt) (xpElem "IW_Pitcher_ID" xpInt) (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] pickle_hits_by_pitch = xpElem "Hit_By_Pitch" $ xpList $ xpElem "HBP_Listing" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpElem "HBP_Batter_ID" xpInt) (xpElem "HBP_Pitcher_ID" xpInt) (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 where from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml to_tuple _ = ()