--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Parse TSN XML for the DTD \"MLB_Boxscore_XML.dtd\".
+--
+module TSN.XML.MLBBoxScore (
+ dtd,
+ pickle_message,
+ -- * Tests
+-- auto_racing_results_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ MLBBoxScoreConstructor(..) )
+-- AutoRacingResultsListingConstructor(..),
+-- AutoRacingResultsRaceInformationConstructor(..) )
+where
+
+-- System imports.
+import Control.Monad ( forM_ )
+import Data.Time ( UTCTime(..) )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ insert,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Database.Groundhog.TH (
+ groundhog,
+ mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+ PU,
+ xp11Tuple,
+ xp23Tuple,
+ xpAttr,
+ xpDefault,
+ xpElem,
+ xpInt,
+ xpList,
+ xpOption,
+ xpPair,
+ xpPrim,
+ xpText,
+ xpTriple,
+ xpUnit,
+ xpWrap )
+
+-- Local imports.
+import TSN.Codegen ( tsn_codegen_config )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers (
+ xp_date,
+ xp_time,
+ xp_time_stamp )
+import TSN.Team ( Team(..), FromXmlFkTeams(..) )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ Child(..),
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "MLB_Boxscore_XML.dtd"
+
+--
+-- * DB/XML data types
+--
+
+-- MLBBoxScore/Message
+
+-- | Database representation of a 'Message'. The vteam/hteam have been
+-- removed since they use the TSN.Team representation. The
+-- 'xml_game_date' and 'xml_game_time' fields have also been
+-- combined into 'db_game_time'. Finally, the summaries are missing
+-- since they'll be keyed to us.
+--
+data MLBBoxScore =
+ MLBBoxScore {
+ db_xml_file_id :: Int,
+ db_heading :: String,
+ db_category :: String,
+ db_sport :: String,
+ db_game_id :: Int,
+ db_schedule_id :: Int,
+ db_vteam_id :: DefaultKey Team,
+ db_hteam_id :: DefaultKey Team,
+ db_season :: String,
+ db_season_type :: String,
+ db_game_time :: UTCTime,
+ db_game_number :: Int,
+ db_capacity :: Int,
+ db_title :: String,
+ db_time_stamp :: UTCTime }
+
+
+
+
+-- | XML Representation of an 'MBLBoxScore'. It has the same fields,
+-- but in addition contains the hteam/vteams and a game_date that
+-- will eventually be combined with the time. It also has a list of
+-- summaries.
+--
+data Message =
+ Message {
+ xml_xml_file_id :: Int,
+ xml_heading :: String,
+ xml_category :: String,
+ xml_sport :: String,
+ xml_game_id :: Int,
+ xml_schedule_id :: Int,
+ xml_vteam :: String,
+ xml_hteam :: String,
+ xml_vteam_id :: String,
+ xml_hteam_id :: String,
+ xml_season :: String,
+ xml_season_type :: String,
+ xml_title :: String,
+ xml_game_date :: UTCTime,
+ xml_game_time :: UTCTime,
+ xml_game_number :: Int,
+ xml_capacity :: Int,
+ xml_game_breakdown :: MLBBoxScoreGameBreakdownXml,
+ xml_team_summaries :: [MLBBoxScoreTeamSummaryXml],
+ xml_misc_pitching_stats :: MLBBoxScoreMiscPitchingStatsXml,
+ xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
+ xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
+ xml_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+
+instance ToDb Message where
+ -- | The database analogue of a 'Message' is a 'MLBBoxScore'.
+ --
+ type Db Message = MLBBoxScore
+
+
+
+-- | This ugly hack allows us to make 'Message' an instance of
+-- 'FromXmlFkTeams'. That class usually requires that its instances
+-- have a parent, but 'Message' does not. So we declare it the
+-- parent of itself, and then ignore it.
+instance Child Message where
+ type Parent Message = MLBBoxScore
+
+
+-- | The 'FromXml' instance for 'Message' is required for the
+-- 'XmlImport' instance.
+--
+instance FromXmlFkTeams Message where
+ -- | To convert a 'Message' to an 'MLBBoxScore', we drop the
+ -- teams/summaries and combine the date/time. Also missing are the
+ -- embedded elements game_breakdown, homerun_stats, and
+ -- miscellaneous_game_info.
+ --
+ -- The first \"missing\" argument is the foreign key to its
+ -- parent, which it doesn't have. (See the 'Child' instance.)
+ --
+ from_xml_fk_teams _ vteam_id hteam_id Message{..} =
+ MLBBoxScore {
+ db_xml_file_id = xml_xml_file_id,
+ db_heading = xml_heading,
+ db_category = xml_category,
+ db_sport = xml_sport,
+ db_game_id = xml_game_id,
+ db_schedule_id = xml_schedule_id,
+ db_vteam_id = vteam_id,
+ db_hteam_id = hteam_id,
+ db_season = xml_season,
+ db_season_type = xml_season_type,
+ db_game_time = make_game_time,
+ db_game_number = xml_game_number,
+ db_capacity = xml_capacity,
+ db_title = xml_title,
+ db_time_stamp = xml_time_stamp }
+ where
+ make_game_time =
+ UTCTime (utctDay xml_game_date) (utctDayTime xml_game_time)
+
+
+
+data MLBBoxScoreTeamSummary = MLBBoxScoreTeamSummary
+data MLBBoxScoreTeamSummaryXml = MLBBoxScoreTeamSummaryXml deriving (Eq, Show)
+
+data MLBBoxScoreGameBreakdown = MLBBoxScoreGameBreakdown
+data MLBBoxScoreGameBreakdownXml = MLBBoxScoreGameBreakdownXml
+ deriving (Eq, Show)
+
+data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
+data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
+ deriving (Eq, Show)
+
+data MLBBoxScoreMiscellaneousGameInfo = MLBBoxScoreMiscellaneousGameInfo
+data MLBBoxScoreMiscellaneousGameInfoXml = MLBBoxScoreMiscellaneousGameInfoXml
+ deriving (Eq, Show)
+
+data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
+data MLBBoxScoreMiscPitchingStatsXml = MLBBoxScoreMiscPitchingStatsXml
+ deriving (Eq, Show)
+
+--
+-- * Database
+--
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: MLBBoxScore)
+
+ -- | We insert the message.
+ dbimport m = do
+ -- First, get the vteam/hteam out of the XML message.
+ let vteam = Team (xml_vteam_id m) Nothing (Just $ xml_vteam m)
+ let hteam = Team (xml_hteam_id m) Nothing (Just $ xml_hteam m)
+
+ -- Insert them...
+ vteam_fk <- insert vteam
+ hteam_fk <- insert hteam
+
+ -- Now we can key the message to the teams we just inserted.
+ -- The message has no parent, so we pass in undefined.
+ let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m
+ msg_id <- insert db_msg
+
+ -- Now get the hteam
+ return ImportSucceeded
+
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: MLBBoxScore
+ dbName: mlb_box_scores
+ constructors:
+ - name: MLBBoxScore
+ uniques:
+ - name: unique_mlb_box_scores
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
+
+|]
+
+
+
+--
+-- * Pickling
+--
+
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp23Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpElem "game_id" xpInt)
+ (xpElem "schedule_id" xpInt)
+ (xpElem "vteam" xpText)
+ (xpElem "hteam" xpText)
+ (xpElem "vteam_id" xpText)
+ (xpElem "hteam_id" xpText)
+ (xpElem "Season" xpText)
+ (xpElem "SeasonType" xpText)
+ (xpElem "title" xpText)
+ (xpElem "Game_Date" xp_date)
+ (xpElem "Game_Time" xp_time)
+ (xpElem "GameNumber" xpInt)
+ (xpElem "Capacity" xpInt)
+ pickle_game_breakdown
+ (xpList pickle_team_summary)
+ pickle_misc_pitching_stats
+ pickle_homerun_stats
+ pickle_miscellaneous_game_info
+ (xpElem "time_stamp" xp_time_stamp)
+ where
+ from_tuple = uncurryN Message
+ to_tuple m = (xml_xml_file_id m,
+ xml_heading m,
+ xml_category m,
+ xml_sport m,
+ xml_game_id m,
+ xml_schedule_id m,
+ xml_vteam m,
+ xml_hteam m,
+ xml_vteam_id m,
+ xml_hteam_id m,
+ xml_season m,
+ xml_season_type m,
+ xml_title m,
+ xml_game_date m,
+ xml_game_time m,
+ xml_game_number m,
+ xml_capacity m,
+ xml_game_breakdown m,
+ xml_team_summaries m,
+ xml_misc_pitching_stats m,
+ xml_homerun_stats m,
+ xml_miscellaneous_game_info m,
+ xml_time_stamp m)
+
+
+pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
+pickle_team_summary =
+ xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+ where
+ from_tuple _ = MLBBoxScoreTeamSummaryXml
+ to_tuple _ = ()
+
+pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
+pickle_game_breakdown =
+ xpElem "Game_Breakdown" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+ where
+ from_tuple _ = MLBBoxScoreGameBreakdownXml
+ to_tuple _ = ()
+
+pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
+pickle_homerun_stats =
+ xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+ where
+ from_tuple _ = MLBBoxScoreHomerunStatsXml
+ to_tuple _ = ()
+
+pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
+pickle_misc_pitching_stats =
+ xpElem "Misc_Pitching_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+ where
+ from_tuple _ = MLBBoxScoreMiscPitchingStatsXml
+ to_tuple _ = ()
+
+pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
+pickle_miscellaneous_game_info =
+ xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+ where
+ from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml
+ to_tuple _ = ()
projects / dead / htsn-import.git / commitdiff