src/TSN/XML/MLBBoxScore.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD \"MLB_Boxscore_XML.dtd\".
  10 --
  11 module TSN.XML.MLBBoxScore (
  12   dtd,
  13   pickle_message,
  14   -- * Tests
  15   --  auto_racing_results_tests,
  16   -- * WARNING: these are private but exported to silence warnings
  17   MLBBoxScoreConstructor(..),
  18   MLBBoxScoreGameBreakdown(..),
  19   MLBBoxScoreHomerunStats(..),
  20   MLBBoxScoreMiscellaneousGameInfo(..),
  21   MLBBoxScoreMiscPitchingStats(..),
  22   MLBBoxScoreTeamSummary(..)
  23  )
  24 --  AutoRacingResultsListingConstructor(..),
  25 --  AutoRacingResultsRaceInformationConstructor(..) )
  26 where
  27
  28 -- System imports.
  29 import Data.Time ( UTCTime(..) )
  30 import Data.Tuple.Curry ( uncurryN )
  31 import Database.Groundhog (
  32   insert,
  33   migrate )
  34 import Database.Groundhog.Core ( DefaultKey )
  35 import Database.Groundhog.TH (
  36   groundhog,
  37   mkPersist )
  38 import qualified GHC.Generics as GHC ( Generic )
  39 import Text.XML.HXT.Core (
  40   PU,
  41   xp4Tuple,
  42   xp23Tuple,
  43   xpAttr,
  44   xpElem,
  45   xpInt,
  46   xpList,
  47   xpOption,
  48   xpPair,
  49   xpText,
  50   xpTriple,
  51   xpUnit,
  52   xpWrap )
  53
  54 -- Local imports.
  55 import Generics ( Generic(..), to_tuple )
  56 import TSN.Codegen ( tsn_codegen_config )
  57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  58 import TSN.Picklers (
  59   xp_date,
  60   xp_time,
  61   xp_time_stamp )
  62 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
  63 import Xml (
  64   Child(..),
  65   ToDb(..) )
  66
  67
  68 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  69 --
  70 dtd :: String
  71 dtd = "MLB_Boxscore_XML.dtd"
  72
  73 --
  74 -- * DB/XML data types
  75 --
  76
  77 -- MLBBoxScore/Message
  78
  79 -- | Database representation of a 'Message'. The vteam/hteam have been
  80 --   removed since they use the TSN.Team representation. The
  81 --   'xml_game_date' and 'xml_game_time' fields have also been
  82 --   combined into 'db_game_time'. Finally, the summaries are missing
  83 --   since they'll be keyed to us.
  84 --
  85 data MLBBoxScore =
  86   MLBBoxScore {
  87     db_xml_file_id :: Int,
  88     db_heading :: String,
  89     db_category :: String,
  90     db_sport :: String,
  91     db_game_id :: Int,
  92     db_schedule_id :: Int,
  93     db_vteam_id :: DefaultKey Team,
  94     db_hteam_id :: DefaultKey Team,
  95     db_season :: String,
  96     db_season_type :: String,
  97     db_game_time :: UTCTime,
  98     db_game_number :: Int,
  99     db_capacity :: Int,
 100     db_title :: String,
 101     db_time_stamp :: UTCTime }
 102
 103
 104
 105
 106 -- | XML Representation of an 'MBLBoxScore'. It has the same fields,
 107 --   but in addition contains the hteam/vteams and a game_date that
 108 --   will eventually be combined with the time. It also has a list of
 109 --   summaries.
 110 --
 111 data Message =
 112   Message {
 113     xml_xml_file_id :: Int,
 114     xml_heading :: String,
 115     xml_category :: String,
 116     xml_sport :: String,
 117     xml_game_id :: Int,
 118     xml_schedule_id :: Int,
 119     xml_vteam :: String,
 120     xml_hteam :: String,
 121     xml_vteam_id :: String,
 122     xml_hteam_id :: String,
 123     xml_season :: String,
 124     xml_season_type :: String,
 125     xml_title :: String,
 126     xml_game_date :: UTCTime,
 127     xml_game_time :: UTCTime,
 128     xml_game_number :: Int,
 129     xml_capacity :: Int,
 130     xml_game_breakdown :: MLBBoxScoreGameBreakdownXml,
 131     xml_team_summaries :: [MLBBoxScoreTeamSummaryXml],
 132     xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml,
 133     xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
 134     xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
 135     xml_time_stamp :: UTCTime }
 136   deriving (Eq, GHC.Generic, Show)
 137
 138
 139 -- | For 'Generics.to_tuple'.
 140 --
 141 instance Generic Message
 142
 143
 144 instance ToDb Message where
 145   -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
 146   --
 147   type Db Message = MLBBoxScore
 148
 149
 150
 151 -- | This ugly hack allows us to make 'Message' an instance of
 152 --   'FromXmlFkTeams'. That class usually requires that its instances
 153 --   have a parent, but 'Message' does not. So we declare it the
 154 --   parent of itself, and then ignore it.
 155 instance Child Message where
 156   type Parent Message = MLBBoxScore
 157
 158
 159 -- | The 'FromXml' instance for 'Message' is required for the
 160 --   'XmlImport' instance.
 161 --
 162 instance FromXmlFkTeams Message where
 163   -- | To convert a 'Message' to an 'MLBBoxScore', we drop the
 164   --   teams/summaries and combine the date/time. Also missing are the
 165   --   embedded elements game_breakdown, homerun_stats, and
 166   --   miscellaneous_game_info.
 167   --
 168   --   The first \"missing\" argument is the foreign key to its
 169   --   parent, which it doesn't have. (See the 'Child' instance.)
 170   --
 171   from_xml_fk_teams _ vteam_id hteam_id Message{..} =
 172     MLBBoxScore {
 173       db_xml_file_id = xml_xml_file_id,
 174       db_heading = xml_heading,
 175       db_category = xml_category,
 176       db_sport = xml_sport,
 177       db_game_id = xml_game_id,
 178       db_schedule_id = xml_schedule_id,
 179       db_vteam_id = vteam_id,
 180       db_hteam_id = hteam_id,
 181       db_season = xml_season,
 182       db_season_type = xml_season_type,
 183       db_game_time = make_game_time,
 184       db_game_number = xml_game_number,
 185       db_capacity = xml_capacity,
 186       db_title = xml_title,
 187       db_time_stamp = xml_time_stamp }
 188     where
 189       make_game_time =
 190         UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
 191
 192
 193
 194 data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
 195 data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
 196
 197 data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
 198 data MLBBoxScoreGameBreakdownXml =
 199   MLBBoxScoreGameBreakdownXml {
 200     xml_away_team :: MLBBoxScoreGameBreakdownTeamXml,
 201     xml_home_team :: MLBBoxScoreGameBreakdownTeamXml }
 202   deriving (Eq, GHC.Generic, Show)
 203
 204 -- | For 'Generics.to_tuple'
 205 --
 206 instance Generic MLBBoxScoreGameBreakdownXml
 207
 208
 209 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
 210 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
 211   deriving (Eq, Show)
 212
 213 data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
 214 data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
 215   deriving (Eq, Show)
 216
 217 data MLBBoxScoreGameBreakdownTeamXml =
 218   MLBBoxScoreGameBreakdownTeamXml {
 219     xml_runs_by_innings :: [MLBBoxScoreRunsByInningsXml],
 220     xml_runs :: Int,
 221     xml_hits :: Int,
 222     xml_errors :: Int }
 223   deriving (Eq, GHC.Generic, Show)
 224
 225
 226 -- | For 'Generics.to_tuple'.
 227 instance Generic MLBBoxScoreGameBreakdownTeamXml
 228
 229
 230 data MLBBoxScoreRunsByInningsXml =
 231   MLBBoxScoreRunsByInningsXml {
 232     xml_runs_by_innings_inning_number :: Int,
 233     xml_runs_by_innings_runs   :: Int }
 234   deriving (Eq, GHC.Generic, Show)
 235
 236
 237 -- | For 'Generics.to_tuple'.
 238 --
 239 instance Generic MLBBoxScoreRunsByInningsXml
 240
 241
 242 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
 243 data MLBBoxScoreMiscPitchingStatsXml =
 244   MLBBoxScoreMiscPitchingStatsXml {
 245     xml_wild_pitches :: Maybe Int,
 246     xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml],
 247     xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] }
 248   deriving (Eq, GHC.Generic, Show)
 249
 250
 251 -- | For 'Generics.to_tuple'.
 252 instance Generic MLBBoxScoreMiscPitchingStatsXml
 253
 254
 255 data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml =
 256   MLBBoxScoreMiscPitchingStatsIntentionalWalkXml {
 257     xml_iw_batter_id :: Int,
 258     xml_iw_pitcher_id :: Int,
 259     xml_iw_number_of_times_walked :: Int }
 260   deriving (Eq, GHC.Generic, Show)
 261
 262
 263 -- | For 'Generics.to_tuple'.
 264 instance Generic MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
 265
 266
 267 data MLBBoxScoreMiscPitchingStatsHitByPitchXml =
 268   MLBBoxScoreMiscPitchingStatsHitByPitchXml {
 269     xml_hbp_batter_id :: Int,
 270     xml_hbp_pitcher_id :: Int,
 271     xml_hbp_number_of_times_hit :: Int }
 272   deriving (Eq, GHC.Generic, Show)
 273
 274
 275 -- | For 'Generics.to_tuple'.
 276 --
 277 instance Generic MLBBoxScoreMiscPitchingStatsHitByPitchXml
 278
 279
 280 --
 281 -- * Database
 282 --
 283
 284 instance DbImport Message where
 285   dbmigrate _ =
 286     run_dbmigrate $ do
 287       migrate (undefined :: MLBBoxScore)
 288
 289   -- | We insert the message.
 290   dbimport m = do
 291     -- First, get the vteam/hteam out of the XML message.
 292     let vteam = Team (xml_vteam_id m) Nothing (Just $ xml_vteam m)
 293     let hteam = Team (xml_hteam_id m) Nothing (Just $ xml_hteam m)
 294
 295     -- Insert them...
 296     vteam_fk <- insert vteam
 297     hteam_fk <- insert hteam
 298
 299     -- Now we can key the message to the teams we just inserted.
 300     -- The message has no parent, so we pass in undefined.
 301     let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m
 302     _ <- insert db_msg
 303
 304     -- Now get the hteam
 305     return ImportSucceeded
 306
 307
 308
 309 mkPersist tsn_codegen_config [groundhog|
 310 - entity: MLBBoxScore
 311   dbName: mlb_box_scores
 312   constructors:
 313     - name: MLBBoxScore
 314       uniques:
 315         - name: unique_mlb_box_scores
 316           type: constraint
 317           # Prevent multiple imports of the same message.
 318           fields: [db_xml_file_id]
 319
 320 |]
 321
 322
 323
 324 --
 325 -- * Pickling
 326 --
 327
 328 pickle_message :: PU Message
 329 pickle_message =
 330   xpElem "message" $
 331     xpWrap (from_tuple, to_tuple) $
 332       xp23Tuple (xpElem "XML_File_ID" xpInt)
 333                 (xpElem "heading" xpText)
 334                 (xpElem "category" xpText)
 335                 (xpElem "sport" xpText)
 336                 (xpElem "game_id" xpInt)
 337                 (xpElem "schedule_id" xpInt)
 338                 (xpElem "vteam" xpText)
 339                 (xpElem "hteam" xpText)
 340                 (xpElem "vteam_id" xpText)
 341                 (xpElem "hteam_id" xpText)
 342                 (xpElem "Season" xpText)
 343                 (xpElem "SeasonType" xpText)
 344                 (xpElem "title" xpText)
 345                 (xpElem "Game_Date" xp_date)
 346                 (xpElem "Game_Time" xp_time)
 347                 (xpElem "GameNumber" xpInt)
 348                 (xpElem "Capacity" xpInt)
 349                 pickle_game_breakdown
 350                 (xpList pickle_team_summary)
 351                 pickle_misc_pitching_stats
 352                 pickle_homerun_stats
 353                 pickle_miscellaneous_game_info
 354                 (xpElem "time_stamp" xp_time_stamp)
 355   where
 356     from_tuple = uncurryN Message
 357
 358
 359 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
 360 pickle_team_summary =
 361   xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple') $ xpUnit
 362   where
 363     from_tuple _ = MLBBoxScoreTeamSummaryXml
 364     to_tuple'   _ = ()
 365
 366 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
 367 pickle_game_breakdown =
 368   xpElem "Game_Breakdown" $
 369     xpWrap (from_tuple, to_tuple) $
 370       xpPair pickle_away_team
 371              pickle_home_team
 372   where
 373     from_tuple = uncurry MLBBoxScoreGameBreakdownXml
 374
 375
 376 pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml
 377 pickle_runs_by_innings =
 378   xpElem "Runs_By_Innings" $
 379     xpWrap (from_tuple, to_tuple) $
 380       xpPair (xpAttr "Inning" xpInt)
 381              xpInt
 382   where
 383     from_tuple = uncurry MLBBoxScoreRunsByInningsXml
 384
 385
 386 pickle_team :: PU MLBBoxScoreGameBreakdownTeamXml
 387 pickle_team =
 388   xpWrap (from_tuple, to_tuple) $
 389     xp4Tuple (xpList pickle_runs_by_innings)
 390              (xpElem "Runs" xpInt)
 391              (xpElem "Hits" xpInt)
 392              (xpElem "Errors" xpInt)
 393   where
 394     from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml
 395
 396
 397 pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml
 398 pickle_away_team =
 399   xpElem "AwayTeam" pickle_team
 400
 401 pickle_home_team :: PU MLBBoxScoreGameBreakdownTeamXml
 402 pickle_home_team =
 403   xpElem "HomeTeam" pickle_team
 404
 405 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
 406 pickle_homerun_stats =
 407   xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple') $ xpUnit
 408   where
 409     from_tuple _ = MLBBoxScoreHomerunStatsXml
 410     to_tuple'   _ = ()
 411
 412
 413 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
 414 pickle_misc_pitching_stats =
 415   xpElem "Misc_Pitching_Stats" $
 416     xpWrap (from_tuple, to_tuple) $
 417       xpTriple (xpOption $ xpElem "Wild_Pitches" xpInt)
 418                pickle_intentional_walks
 419                pickle_hits_by_pitch
 420   where
 421     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml
 422
 423
 424
 425 pickle_intentional_walks :: PU [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml]
 426 pickle_intentional_walks =
 427   xpElem "Intentional_Walks" $ xpList $ xpElem "IW_Listing" $
 428     xpWrap (from_tuple, to_tuple) $
 429       xpTriple (xpElem "IW_Batter_ID" xpInt)
 430                (xpElem "IW_Pitcher_ID" xpInt)
 431                (xpElem "IW_Number_Of_Times_Walked" xpInt)
 432   where
 433     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
 434
 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
 447
 448
 449 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
 450 pickle_miscellaneous_game_info =
 451   xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple') $ xpUnit
 452   where
 453     from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml
 454     to_tuple'  _ = ()