1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD \"MLB_Boxscore_XML.dtd\".
10 module TSN.XML.MLBBoxScore (
14 -- auto_racing_results_tests,
15 -- * WARNING: these are private but exported to silence warnings
16 MLBBoxScoreConstructor(..) )
17 -- AutoRacingResultsListingConstructor(..),
18 -- AutoRacingResultsRaceInformationConstructor(..) )
22 import Control.Monad ( forM_ )
23 import Data.Time ( UTCTime(..) )
24 import Data.Tuple.Curry ( uncurryN )
25 import Database.Groundhog (
31 silentMigrationLogger )
32 import Database.Groundhog.Core ( DefaultKey )
33 import Database.Groundhog.Generic ( runDbConn )
34 import Database.Groundhog.Sqlite ( withSqliteConn )
35 import Database.Groundhog.TH (
38 import Test.Tasty ( TestTree, testGroup )
39 import Test.Tasty.HUnit ( (@?=), testCase )
40 import Text.XML.HXT.Core (
59 import TSN.Codegen ( tsn_codegen_config )
60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
65 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
66 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
77 -- | The DTD to which this module corresponds. Used to invoke dbimport.
80 dtd = "MLB_Boxscore_XML.dtd"
83 -- * DB/XML data types
86 -- MLBBoxScore/Message
88 -- | Database representation of a 'Message'. The vteam/hteam have been
89 -- removed since they use the TSN.Team representation. The
90 -- 'xml_game_date' and 'xml_game_time' fields have also been
91 -- combined into 'db_game_time'. Finally, the summaries are missing
92 -- since they'll be keyed to us.
96 db_xml_file_id :: Int,
98 db_category :: String,
101 db_schedule_id :: Int,
102 db_vteam_id :: DefaultKey Team,
103 db_hteam_id :: DefaultKey Team,
105 db_season_type :: String,
106 db_game_time :: UTCTime,
107 db_game_number :: Int,
110 db_time_stamp :: UTCTime }
115 -- | XML Representation of an 'MBLBoxScore'. It has the same fields,
116 -- but in addition contains the hteam/vteams and a game_date that
117 -- will eventually be combined with the time. It also has a list of
122 xml_xml_file_id :: Int,
123 xml_heading :: String,
124 xml_category :: String,
127 xml_schedule_id :: Int,
130 xml_vteam_id :: String,
131 xml_hteam_id :: String,
132 xml_season :: String,
133 xml_season_type :: String,
135 xml_game_date :: UTCTime,
136 xml_game_time :: UTCTime,
137 xml_game_number :: Int,
139 xml_game_breakdown :: MLBBoxScoreGameBreakdownXml,
140 xml_team_summaries :: [MLBBoxScoreTeamSummaryXml],
141 xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml,
142 xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
143 xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
144 xml_time_stamp :: UTCTime }
148 instance ToDb Message where
149 -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
151 type Db Message = MLBBoxScore
155 -- | This ugly hack allows us to make 'Message' an instance of
156 -- 'FromXmlFkTeams'. That class usually requires that its instances
157 -- have a parent, but 'Message' does not. So we declare it the
158 -- parent of itself, and then ignore it.
159 instance Child Message where
160 type Parent Message = MLBBoxScore
163 -- | The 'FromXml' instance for 'Message' is required for the
164 -- 'XmlImport' instance.
166 instance FromXmlFkTeams Message where
167 -- | To convert a 'Message' to an 'MLBBoxScore', we drop the
168 -- teams/summaries and combine the date/time. Also missing are the
169 -- embedded elements game_breakdown, homerun_stats, and
170 -- miscellaneous_game_info.
172 -- The first \"missing\" argument is the foreign key to its
173 -- parent, which it doesn't have. (See the 'Child' instance.)
175 from_xml_fk_teams _ vteam_id hteam_id Message{..} =
177 db_xml_file_id = xml_xml_file_id,
178 db_heading = xml_heading,
179 db_category = xml_category,
180 db_sport = xml_sport,
181 db_game_id = xml_game_id,
182 db_schedule_id = xml_schedule_id,
183 db_vteam_id = vteam_id,
184 db_hteam_id = hteam_id,
185 db_season = xml_season,
186 db_season_type = xml_season_type,
187 db_game_time = make_game_time,
188 db_game_number = xml_game_number,
189 db_capacity = xml_capacity,
190 db_title = xml_title,
191 db_time_stamp = xml_time_stamp }
194 UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
198 data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
199 data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
201 data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
202 data MLBBoxScoreGameBreakdownXml =
203 MLBBoxScoreGameBreakdownXml {
204 xml_away_team :: MLBBoxScoreGameBreakdownTeamXml,
205 xml_home_team :: MLBBoxScoreGameBreakdownTeamXml }
208 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
209 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
212 data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
213 data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
216 data MLBBoxScoreGameBreakdownTeamXml =
217 MLBBoxScoreGameBreakdownTeamXml {
218 xml_runs_by_innings :: [MLBBoxScoreRunsByInningsXml],
224 data MLBBoxScoreRunsByInningsXml =
225 MLBBoxScoreRunsByInningsXml {
226 xml_runs_by_innings_inning_number :: Int,
227 xml_runs_by_innings_runs :: Int }
231 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
232 data MLBBoxScoreMiscPitchingStatsXml =
233 MLBBoxScoreMiscPitchingStatsXml {
234 xml_wild_pitches :: Maybe Int,
235 xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml],
236 xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] }
239 data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml =
240 MLBBoxScoreMiscPitchingStatsIntentionalWalkXml {
241 xml_iw_batter_id :: Int,
242 xml_iw_pitcher_id :: Int,
243 xml_iw_number_of_times_walked :: Int }
246 data MLBBoxScoreMiscPitchingStatsHitByPitchXml =
247 MLBBoxScoreMiscPitchingStatsHitByPitchXml {
248 xml_hbp_batter_id :: Int,
249 xml_hbp_pitcher_id :: Int,
250 xml_hbp_number_of_times_hit :: Int }
257 instance DbImport Message where
260 migrate (undefined :: MLBBoxScore)
262 -- | We insert the message.
264 -- First, get the vteam/hteam out of the XML message.
265 let vteam = Team (xml_vteam_id m) Nothing (Just $ xml_vteam m)
266 let hteam = Team (xml_hteam_id m) Nothing (Just $ xml_hteam m)
269 vteam_fk <- insert vteam
270 hteam_fk <- insert hteam
272 -- Now we can key the message to the teams we just inserted.
273 -- The message has no parent, so we pass in undefined.
274 let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m
275 msg_id <- insert db_msg
278 return ImportSucceeded
282 mkPersist tsn_codegen_config [groundhog|
283 - entity: MLBBoxScore
284 dbName: mlb_box_scores
288 - name: unique_mlb_box_scores
290 # Prevent multiple imports of the same message.
291 fields: [db_xml_file_id]
301 pickle_message :: PU Message
304 xpWrap (from_tuple, to_tuple) $
305 xp23Tuple (xpElem "XML_File_ID" xpInt)
306 (xpElem "heading" xpText)
307 (xpElem "category" xpText)
308 (xpElem "sport" xpText)
309 (xpElem "game_id" xpInt)
310 (xpElem "schedule_id" xpInt)
311 (xpElem "vteam" xpText)
312 (xpElem "hteam" xpText)
313 (xpElem "vteam_id" xpText)
314 (xpElem "hteam_id" xpText)
315 (xpElem "Season" xpText)
316 (xpElem "SeasonType" xpText)
317 (xpElem "title" xpText)
318 (xpElem "Game_Date" xp_date)
319 (xpElem "Game_Time" xp_time)
320 (xpElem "GameNumber" xpInt)
321 (xpElem "Capacity" xpInt)
322 pickle_game_breakdown
323 (xpList pickle_team_summary)
324 pickle_misc_pitching_stats
326 pickle_miscellaneous_game_info
327 (xpElem "time_stamp" xp_time_stamp)
329 from_tuple = uncurryN Message
330 to_tuple m = (xml_xml_file_id m,
347 xml_game_breakdown m,
348 xml_team_summaries m,
349 xml_misc_pitching_stats m,
351 xml_miscellaneous_game_info m,
355 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
356 pickle_team_summary =
357 xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
359 from_tuple _ = MLBBoxScoreTeamSummaryXml
362 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
363 pickle_game_breakdown =
364 xpElem "Game_Breakdown" $
365 xpWrap (from_tuple, to_tuple) $
366 xpPair pickle_away_team
369 from_tuple = uncurry MLBBoxScoreGameBreakdownXml
370 to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team)
373 pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml
374 pickle_runs_by_innings =
375 xpElem "Runs_By_Innings" $
376 xpWrap (from_tuple, to_tuple) $
377 xpPair (xpAttr "Inning" xpInt)
380 from_tuple = uncurry MLBBoxScoreRunsByInningsXml
381 to_tuple MLBBoxScoreRunsByInningsXml{..} =
382 (xml_runs_by_innings_inning_number, xml_runs_by_innings_runs)
385 xpWrap (from_tuple, to_tuple) $
386 xp4Tuple (xpList pickle_runs_by_innings)
387 (xpElem "Runs" xpInt)
388 (xpElem "Hits" xpInt)
389 (xpElem "Errors" xpInt)
391 from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml
392 to_tuple MLBBoxScoreGameBreakdownTeamXml{..} =
393 (xml_runs_by_innings, xml_runs, xml_hits, xml_errors)
395 pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml
397 xpElem "AwayTeam" pickle_team
399 pickle_home_team :: PU MLBBoxScoreGameBreakdownTeamXml
401 xpElem "HomeTeam" pickle_team
403 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
404 pickle_homerun_stats =
405 xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
407 from_tuple _ = MLBBoxScoreHomerunStatsXml
411 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
412 pickle_misc_pitching_stats =
413 xpElem "Misc_Pitching_Stats" $
414 xpWrap (from_tuple, to_tuple) $
415 xpTriple (xpOption $ xpElem "Wild_Pitches" xpInt)
416 pickle_intentional_walks
419 from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml
420 to_tuple MLBBoxScoreMiscPitchingStatsXml{..} =
421 (xml_wild_pitches, xml_intentional_walks, xml_hits_by_pitch)
424 pickle_intentional_walks :: PU [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml]
425 pickle_intentional_walks =
426 xpElem "Intentional_Walks" $ xpList $ xpElem "IW_Listing" $
427 xpWrap (from_tuple, to_tuple) $
428 xpTriple (xpElem "IW_Batter_ID" xpInt)
429 (xpElem "IW_Pitcher_ID" xpInt)
430 (xpElem "IW_Number_Of_Times_Walked" xpInt)
432 from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
433 to_tuple MLBBoxScoreMiscPitchingStatsIntentionalWalkXml{..} =
434 (xml_iw_batter_id, xml_iw_pitcher_id, xml_iw_number_of_times_walked)
437 pickle_hits_by_pitch :: PU [MLBBoxScoreMiscPitchingStatsHitByPitchXml]
438 pickle_hits_by_pitch =
439 xpElem "Hit_By_Pitch" $ xpList $ xpElem "HBP_Listing" $
440 xpWrap (from_tuple, to_tuple) $
441 xpTriple (xpElem "HBP_Batter_ID" xpInt)
442 (xpElem "HBP_Pitcher_ID" xpInt)
443 (xpElem "HBP_Number_Of_Times_Hit" xpInt)
445 from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsHitByPitchXml
446 to_tuple MLBBoxScoreMiscPitchingStatsHitByPitchXml{..} =
447 (xml_hbp_batter_id, xml_hbp_pitcher_id, xml_hbp_number_of_times_hit)
451 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
452 pickle_miscellaneous_game_info =
453 xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
455 from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml