src/TSN/XML/MLBBoxScore.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD \"MLB_Boxscore_XML.dtd\".
   9 --
  10 module TSN.XML.MLBBoxScore (
  11   dtd,
  12   pickle_message,
  13   -- * Tests
  14 --  auto_racing_results_tests,
  15   -- * WARNING: these are private but exported to silence warnings
  16   MLBBoxScoreConstructor(..) )
  17 --  AutoRacingResultsListingConstructor(..),
  18 --  AutoRacingResultsRaceInformationConstructor(..) )
  19 where
  20
  21 -- System imports.
  22 import Control.Monad ( forM_ )
  23 import Data.Time ( UTCTime(..) )
  24 import Data.Tuple.Curry ( uncurryN )
  25 import Database.Groundhog (
  26   countAll,
  27   deleteAll,
  28   insert,
  29   migrate,
  30   runMigration,
  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 (
  36   groundhog,
  37   mkPersist )
  38 import Test.Tasty ( TestTree, testGroup )
  39 import Test.Tasty.HUnit ( (@?=), testCase )
  40 import Text.XML.HXT.Core (
  41   PU,
  42   xp4Tuple,
  43   xp11Tuple,
  44   xp23Tuple,
  45   xpAttr,
  46   xpDefault,
  47   xpElem,
  48   xpInt,
  49   xpList,
  50   xpOption,
  51   xpPair,
  52   xpPrim,
  53   xpText,
  54   xpTriple,
  55   xpUnit,
  56   xpWrap )
  57
  58 -- Local imports.
  59 import TSN.Codegen ( tsn_codegen_config )
  60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  61 import TSN.Picklers (
  62   xp_date,
  63   xp_time,
  64   xp_time_stamp )
  65 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
  66 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  67 import Xml (
  68   Child(..),
  69   FromXml(..),
  70   FromXmlFk(..),
  71   ToDb(..),
  72   pickle_unpickle,
  73   unpickleable,
  74   unsafe_unpickle )
  75
  76
  77 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  78 --
  79 dtd :: String
  80 dtd = "MLB_Boxscore_XML.dtd"
  81
  82 --
  83 -- * DB/XML data types
  84 --
  85
  86 -- MLBBoxScore/Message
  87
  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.
  93 --
  94 data MLBBoxScore =
  95   MLBBoxScore {
  96     db_xml_file_id :: Int,
  97     db_heading :: String,
  98     db_category :: String,
  99     db_sport :: String,
 100     db_game_id :: Int,
 101     db_schedule_id :: Int,
 102     db_vteam_id :: DefaultKey Team,
 103     db_hteam_id :: DefaultKey Team,
 104     db_season :: String,
 105     db_season_type :: String,
 106     db_game_time :: UTCTime,
 107     db_game_number :: Int,
 108     db_capacity :: Int,
 109     db_title :: String,
 110     db_time_stamp :: UTCTime }
 111
 112
 113
 114
 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
 118 --   summaries.
 119 --
 120 data Message =
 121   Message {
 122     xml_xml_file_id :: Int,
 123     xml_heading :: String,
 124     xml_category :: String,
 125     xml_sport :: String,
 126     xml_game_id :: Int,
 127     xml_schedule_id :: Int,
 128     xml_vteam :: String,
 129     xml_hteam :: String,
 130     xml_vteam_id :: String,
 131     xml_hteam_id :: String,
 132     xml_season :: String,
 133     xml_season_type :: String,
 134     xml_title :: String,
 135     xml_game_date :: UTCTime,
 136     xml_game_time :: UTCTime,
 137     xml_game_number :: Int,
 138     xml_capacity :: 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 }
 145   deriving (Eq, Show)
 146
 147
 148 instance ToDb Message where
 149   -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
 150   --
 151   type Db Message = MLBBoxScore
 152
 153
 154
 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
 161
 162
 163 -- | The 'FromXml' instance for 'Message' is required for the
 164 --   'XmlImport' instance.
 165 --
 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.
 171   --
 172   --   The first \"missing\" argument is the foreign key to its
 173   --   parent, which it doesn't have. (See the 'Child' instance.)
 174   --
 175   from_xml_fk_teams _ vteam_id hteam_id Message{..} =
 176     MLBBoxScore {
 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 }
 192     where
 193       make_game_time =
 194         UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
 195
 196
 197
 198 data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
 199 data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
 200
 201 data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
 202 data MLBBoxScoreGameBreakdownXml =
 203   MLBBoxScoreGameBreakdownXml {
 204     xml_away_team :: MLBBoxScoreGameBreakdownTeamXml,
 205     xml_home_team :: MLBBoxScoreGameBreakdownTeamXml }
 206   deriving (Eq, Show)
 207
 208 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
 209 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
 210   deriving (Eq, Show)
 211
 212 data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
 213 data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
 214   deriving (Eq, Show)
 215
 216 data MLBBoxScoreGameBreakdownTeamXml =
 217   MLBBoxScoreGameBreakdownTeamXml {
 218     xml_runs_by_innings :: [MLBBoxScoreRunsByInningsXml],
 219     xml_runs :: Int,
 220     xml_hits :: Int,
 221     xml_errors :: Int }
 222   deriving (Eq, Show)
 223
 224 data MLBBoxScoreRunsByInningsXml =
 225   MLBBoxScoreRunsByInningsXml {
 226     xml_runs_by_innings_inning_number :: Int,
 227     xml_runs_by_innings_runs   :: Int }
 228   deriving (Eq, Show)
 229
 230
 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] }
 237   deriving (Eq, Show)
 238
 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 }
 244   deriving (Eq, Show)
 245
 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 }
 251   deriving (Eq, Show)
 252
 253 --
 254 -- * Database
 255 --
 256
 257 instance DbImport Message where
 258   dbmigrate _ =
 259     run_dbmigrate $ do
 260       migrate (undefined :: MLBBoxScore)
 261
 262   -- | We insert the message.
 263   dbimport m = do
 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)
 267
 268     -- Insert them...
 269     vteam_fk <- insert vteam
 270     hteam_fk <- insert hteam
 271
 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
 276
 277     -- Now get the hteam
 278     return ImportSucceeded
 279
 280
 281
 282 mkPersist tsn_codegen_config [groundhog|
 283 - entity: MLBBoxScore
 284   dbName: mlb_box_scores
 285   constructors:
 286     - name: MLBBoxScore
 287       uniques:
 288         - name: unique_mlb_box_scores
 289           type: constraint
 290           # Prevent multiple imports of the same message.
 291           fields: [db_xml_file_id]
 292
 293 |]
 294
 295
 296
 297 --
 298 -- * Pickling
 299 --
 300
 301 pickle_message :: PU Message
 302 pickle_message =
 303   xpElem "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
 325                 pickle_homerun_stats
 326                 pickle_miscellaneous_game_info
 327                 (xpElem "time_stamp" xp_time_stamp)
 328   where
 329     from_tuple = uncurryN Message
 330     to_tuple m = (xml_xml_file_id m,
 331                   xml_heading m,
 332                   xml_category m,
 333                   xml_sport m,
 334                   xml_game_id m,
 335                   xml_schedule_id m,
 336                   xml_vteam m,
 337                   xml_hteam m,
 338                   xml_vteam_id m,
 339                   xml_hteam_id m,
 340                   xml_season m,
 341                   xml_season_type m,
 342                   xml_title m,
 343                   xml_game_date m,
 344                   xml_game_time m,
 345                   xml_game_number m,
 346                   xml_capacity m,
 347                   xml_game_breakdown m,
 348                   xml_team_summaries m,
 349                   xml_misc_pitching_stats m,
 350                   xml_homerun_stats m,
 351                   xml_miscellaneous_game_info m,
 352                   xml_time_stamp m)
 353
 354
 355 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
 356 pickle_team_summary =
 357   xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 358   where
 359     from_tuple _ = MLBBoxScoreTeamSummaryXml
 360     to_tuple   _ = ()
 361
 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
 367              pickle_home_team
 368   where
 369     from_tuple = uncurry MLBBoxScoreGameBreakdownXml
 370     to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team)
 371
 372
 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)
 378              xpInt
 379   where
 380     from_tuple = uncurry MLBBoxScoreRunsByInningsXml
 381     to_tuple MLBBoxScoreRunsByInningsXml{..} =
 382       (xml_runs_by_innings_inning_number, xml_runs_by_innings_runs)
 383
 384 pickle_team =
 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)
 390   where
 391     from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml
 392     to_tuple MLBBoxScoreGameBreakdownTeamXml{..} =
 393       (xml_runs_by_innings, xml_runs, xml_hits, xml_errors)
 394
 395 pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml
 396 pickle_away_team =
 397   xpElem "AwayTeam" pickle_team
 398
 399 pickle_home_team :: PU MLBBoxScoreGameBreakdownTeamXml
 400 pickle_home_team =
 401   xpElem "HomeTeam" pickle_team
 402
 403 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
 404 pickle_homerun_stats =
 405   xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 406   where
 407     from_tuple _ = MLBBoxScoreHomerunStatsXml
 408     to_tuple   _ = ()
 409
 410
 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
 417                pickle_hits_by_pitch
 418   where
 419     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml
 420     to_tuple MLBBoxScoreMiscPitchingStatsXml{..} =
 421       (xml_wild_pitches, xml_intentional_walks, xml_hits_by_pitch)
 422
 423
 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)
 431   where
 432     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
 433     to_tuple MLBBoxScoreMiscPitchingStatsIntentionalWalkXml{..} =
 434       (xml_iw_batter_id, xml_iw_pitcher_id, xml_iw_number_of_times_walked)
 435
 436
 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)
 444   where
 445     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsHitByPitchXml
 446     to_tuple MLBBoxScoreMiscPitchingStatsHitByPitchXml{..} =
 447       (xml_hbp_batter_id, xml_hbp_pitcher_id, xml_hbp_number_of_times_hit)
 448
 449
 450
 451 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
 452 pickle_miscellaneous_game_info =
 453   xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 454   where
 455     from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml
 456     to_tuple   _ = ()