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   xp11Tuple,
  43   xp23Tuple,
  44   xpAttr,
  45   xpDefault,
  46   xpElem,
  47   xpInt,
  48   xpList,
  49   xpOption,
  50   xpPair,
  51   xpPrim,
  52   xpText,
  53   xpTriple,
  54   xpUnit,
  55   xpWrap )
  56
  57 -- Local imports.
  58 import TSN.Codegen ( tsn_codegen_config )
  59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  60 import TSN.Picklers (
  61   xp_date,
  62   xp_time,
  63   xp_time_stamp )
  64 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
  65 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  66 import Xml (
  67   Child(..),
  68   FromXml(..),
  69   FromXmlFk(..),
  70   ToDb(..),
  71   pickle_unpickle,
  72   unpickleable,
  73   unsafe_unpickle )
  74
  75
  76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  77 --
  78 dtd :: String
  79 dtd = "MLB_Boxscore_XML.dtd"
  80
  81 --
  82 -- * DB/XML data types
  83 --
  84
  85 -- MLBBoxScore/Message
  86
  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.
  92 --
  93 data MLBBoxScore =
  94   MLBBoxScore {
  95     db_xml_file_id :: Int,
  96     db_heading :: String,
  97     db_category :: String,
  98     db_sport :: String,
  99     db_game_id :: Int,
 100     db_schedule_id :: Int,
 101     db_vteam_id :: DefaultKey Team,
 102     db_hteam_id :: DefaultKey Team,
 103     db_season :: String,
 104     db_season_type :: String,
 105     db_game_time :: UTCTime,
 106     db_game_number :: Int,
 107     db_capacity :: Int,
 108     db_title :: String,
 109     db_time_stamp :: UTCTime }
 110
 111
 112
 113
 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
 117 --   summaries.
 118 --
 119 data Message =
 120   Message {
 121     xml_xml_file_id :: Int,
 122     xml_heading :: String,
 123     xml_category :: String,
 124     xml_sport :: String,
 125     xml_game_id :: Int,
 126     xml_schedule_id :: Int,
 127     xml_vteam :: String,
 128     xml_hteam :: String,
 129     xml_vteam_id :: String,
 130     xml_hteam_id :: String,
 131     xml_season :: String,
 132     xml_season_type :: String,
 133     xml_title :: String,
 134     xml_game_date :: UTCTime,
 135     xml_game_time :: UTCTime,
 136     xml_game_number :: Int,
 137     xml_capacity :: 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 }
 144   deriving (Eq, Show)
 145
 146
 147 instance ToDb Message where
 148   -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
 149   --
 150   type Db Message = MLBBoxScore
 151
 152
 153
 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
 160
 161
 162 -- | The 'FromXml' instance for 'Message' is required for the
 163 --   'XmlImport' instance.
 164 --
 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.
 170   --
 171   --   The first \"missing\" argument is the foreign key to its
 172   --   parent, which it doesn't have. (See the 'Child' instance.)
 173   --
 174   from_xml_fk_teams _ vteam_id hteam_id Message{..} =
 175     MLBBoxScore {
 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 }
 191     where
 192       make_game_time =
 193         UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
 194
 195
 196
 197 data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
 198 data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
 199
 200 data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
 201 data MLBBoxScoreGameBreakdownXml = MLBBoxScoreGameBreakdownXml
 202   deriving (Eq, Show)
 203
 204 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
 205 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
 206   deriving (Eq, Show)
 207
 208 data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
 209 data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
 210   deriving (Eq, Show)
 211
 212 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
 213 data MLBBoxScoreMiscPitchingStatsXml = MLBBoxScoreMiscPitchingStatsXml
 214   deriving (Eq, Show)
 215
 216 --
 217 -- * Database
 218 --
 219
 220 instance DbImport Message where
 221   dbmigrate _ =
 222     run_dbmigrate $ do
 223       migrate (undefined :: MLBBoxScore)
 224
 225   -- | We insert the message.
 226   dbimport m = do
 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)
 230
 231     -- Insert them...
 232     vteam_fk <- insert vteam
 233     hteam_fk <- insert hteam
 234
 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
 239
 240     -- Now get the hteam
 241     return ImportSucceeded
 242
 243
 244
 245 mkPersist tsn_codegen_config [groundhog|
 246 - entity: MLBBoxScore
 247   dbName: mlb_box_scores
 248   constructors:
 249     - name: MLBBoxScore
 250       uniques:
 251         - name: unique_mlb_box_scores
 252           type: constraint
 253           # Prevent multiple imports of the same message.
 254           fields: [db_xml_file_id]
 255
 256 |]
 257
 258
 259
 260 --
 261 -- * Pickling
 262 --
 263
 264 pickle_message :: PU Message
 265 pickle_message =
 266   xpElem "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
 288                 pickle_homerun_stats
 289                 pickle_miscellaneous_game_info
 290                 (xpElem "time_stamp" xp_time_stamp)
 291   where
 292     from_tuple = uncurryN Message
 293     to_tuple m = (xml_xml_file_id m,
 294                   xml_heading m,
 295                   xml_category m,
 296                   xml_sport m,
 297                   xml_game_id m,
 298                   xml_schedule_id m,
 299                   xml_vteam m,
 300                   xml_hteam m,
 301                   xml_vteam_id m,
 302                   xml_hteam_id m,
 303                   xml_season m,
 304                   xml_season_type m,
 305                   xml_title m,
 306                   xml_game_date m,
 307                   xml_game_time m,
 308                   xml_game_number m,
 309                   xml_capacity m,
 310                   xml_game_breakdown m,
 311                   xml_team_summaries m,
 312                   xml_misc_pitching_stats m,
 313                   xml_homerun_stats m,
 314                   xml_miscellaneous_game_info m,
 315                   xml_time_stamp m)
 316
 317
 318 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
 319 pickle_team_summary =
 320   xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 321   where
 322     from_tuple _ = MLBBoxScoreTeamSummaryXml
 323     to_tuple   _ = ()
 324
 325 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
 326 pickle_game_breakdown =
 327   xpElem "Game_Breakdown" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 328   where
 329     from_tuple _ = MLBBoxScoreGameBreakdownXml
 330     to_tuple   _ = ()
 331
 332 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
 333 pickle_homerun_stats =
 334   xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 335   where
 336     from_tuple _ = MLBBoxScoreHomerunStatsXml
 337     to_tuple   _ = ()
 338
 339 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
 340 pickle_misc_pitching_stats =
 341   xpElem "Misc_Pitching_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 342   where
 343     from_tuple _ = MLBBoxScoreMiscPitchingStatsXml
 344     to_tuple   _ = ()
 345
 346 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
 347 pickle_miscellaneous_game_info =
 348   xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
 349   where
 350     from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml
 351     to_tuple   _ = ()