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 (
58 import TSN.Codegen ( tsn_codegen_config )
59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
64 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
65 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
79 dtd = "MLB_Boxscore_XML.dtd"
82 -- * DB/XML data types
85 -- MLBBoxScore/Message
87 -- | Database representation of a 'Message'. The vteam/hteam have been
88 -- removed since they use the TSN.Team representation. The
89 -- 'xml_game_date' and 'xml_game_time' fields have also been
90 -- combined into 'db_game_time'. Finally, the summaries are missing
91 -- since they'll be keyed to us.
95 db_xml_file_id :: Int,
97 db_category :: String,
100 db_schedule_id :: Int,
101 db_vteam_id :: DefaultKey Team,
102 db_hteam_id :: DefaultKey Team,
104 db_season_type :: String,
105 db_game_time :: UTCTime,
106 db_game_number :: Int,
109 db_time_stamp :: UTCTime }
114 -- | XML Representation of an 'MBLBoxScore'. It has the same fields,
115 -- but in addition contains the hteam/vteams and a game_date that
116 -- will eventually be combined with the time. It also has a list of
121 xml_xml_file_id :: Int,
122 xml_heading :: String,
123 xml_category :: String,
126 xml_schedule_id :: Int,
129 xml_vteam_id :: String,
130 xml_hteam_id :: String,
131 xml_season :: String,
132 xml_season_type :: String,
134 xml_game_date :: UTCTime,
135 xml_game_time :: UTCTime,
136 xml_game_number :: Int,
138 xml_game_breakdown :: MLBBoxScoreGameBreakdownXml,
139 xml_team_summaries :: [MLBBoxScoreTeamSummaryXml],
140 xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml,
141 xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
142 xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
143 xml_time_stamp :: UTCTime }
147 instance ToDb Message where
148 -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
150 type Db Message = MLBBoxScore
154 -- | This ugly hack allows us to make 'Message' an instance of
155 -- 'FromXmlFkTeams'. That class usually requires that its instances
156 -- have a parent, but 'Message' does not. So we declare it the
157 -- parent of itself, and then ignore it.
158 instance Child Message where
159 type Parent Message = MLBBoxScore
162 -- | The 'FromXml' instance for 'Message' is required for the
163 -- 'XmlImport' instance.
165 instance FromXmlFkTeams Message where
166 -- | To convert a 'Message' to an 'MLBBoxScore', we drop the
167 -- teams/summaries and combine the date/time. Also missing are the
168 -- embedded elements game_breakdown, homerun_stats, and
169 -- miscellaneous_game_info.
171 -- The first \"missing\" argument is the foreign key to its
172 -- parent, which it doesn't have. (See the 'Child' instance.)
174 from_xml_fk_teams _ vteam_id hteam_id Message{..} =
176 db_xml_file_id = xml_xml_file_id,
177 db_heading = xml_heading,
178 db_category = xml_category,
179 db_sport = xml_sport,
180 db_game_id = xml_game_id,
181 db_schedule_id = xml_schedule_id,
182 db_vteam_id = vteam_id,
183 db_hteam_id = hteam_id,
184 db_season = xml_season,
185 db_season_type = xml_season_type,
186 db_game_time = make_game_time,
187 db_game_number = xml_game_number,
188 db_capacity = xml_capacity,
189 db_title = xml_title,
190 db_time_stamp = xml_time_stamp }
193 UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
197 data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
198 data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
200 data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
201 data MLBBoxScoreGameBreakdownXml = MLBBoxScoreGameBreakdownXml
204 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
205 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
208 data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
209 data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
212 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
213 data MLBBoxScoreMiscPitchingStatsXml = MLBBoxScoreMiscPitchingStatsXml
220 instance DbImport Message where
223 migrate (undefined :: MLBBoxScore)
225 -- | We insert the message.
227 -- First, get the vteam/hteam out of the XML message.
228 let vteam = Team (xml_vteam_id m) Nothing (Just $ xml_vteam m)
229 let hteam = Team (xml_hteam_id m) Nothing (Just $ xml_hteam m)
232 vteam_fk <- insert vteam
233 hteam_fk <- insert hteam
235 -- Now we can key the message to the teams we just inserted.
236 -- The message has no parent, so we pass in undefined.
237 let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m
238 msg_id <- insert db_msg
241 return ImportSucceeded
245 mkPersist tsn_codegen_config [groundhog|
246 - entity: MLBBoxScore
247 dbName: mlb_box_scores
251 - name: unique_mlb_box_scores
253 # Prevent multiple imports of the same message.
254 fields: [db_xml_file_id]
264 pickle_message :: PU Message
267 xpWrap (from_tuple, to_tuple) $
268 xp23Tuple (xpElem "XML_File_ID" xpInt)
269 (xpElem "heading" xpText)
270 (xpElem "category" xpText)
271 (xpElem "sport" xpText)
272 (xpElem "game_id" xpInt)
273 (xpElem "schedule_id" xpInt)
274 (xpElem "vteam" xpText)
275 (xpElem "hteam" xpText)
276 (xpElem "vteam_id" xpText)
277 (xpElem "hteam_id" xpText)
278 (xpElem "Season" xpText)
279 (xpElem "SeasonType" xpText)
280 (xpElem "title" xpText)
281 (xpElem "Game_Date" xp_date)
282 (xpElem "Game_Time" xp_time)
283 (xpElem "GameNumber" xpInt)
284 (xpElem "Capacity" xpInt)
285 pickle_game_breakdown
286 (xpList pickle_team_summary)
287 pickle_misc_pitching_stats
289 pickle_miscellaneous_game_info
290 (xpElem "time_stamp" xp_time_stamp)
292 from_tuple = uncurryN Message
293 to_tuple m = (xml_xml_file_id m,
310 xml_game_breakdown m,
311 xml_team_summaries m,
312 xml_misc_pitching_stats m,
314 xml_miscellaneous_game_info m,
318 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
319 pickle_team_summary =
320 xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
322 from_tuple _ = MLBBoxScoreTeamSummaryXml
325 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
326 pickle_game_breakdown =
327 xpElem "Game_Breakdown" $ xpWrap (from_tuple, to_tuple) $ xpUnit
329 from_tuple _ = MLBBoxScoreGameBreakdownXml
332 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
333 pickle_homerun_stats =
334 xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
336 from_tuple _ = MLBBoxScoreHomerunStatsXml
339 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
340 pickle_misc_pitching_stats =
341 xpElem "Misc_Pitching_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
343 from_tuple _ = MLBBoxScoreMiscPitchingStatsXml
346 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
347 pickle_miscellaneous_game_info =
348 xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
350 from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml