From: Michael Orlitzky Date: Fri, 7 Nov 2014 14:52:18 +0000 (-0500) Subject: Add stub for TSN.XML.MLBBoxScore. X-Git-Tag: 0.2.1~63 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=0fb33e421979003bec08430d550314bf95504eee;p=dead%2Fhtsn-import.git Add stub for TSN.XML.MLBBoxScore. --- diff --git a/.ghci b/.ghci index dfeb6df..b327063 100644 --- a/.ghci +++ b/.ghci @@ -26,6 +26,7 @@ src/TSN/XML/Injuries.hs src/TSN/XML/InjuriesDetail.hs src/TSN/XML/JFile.hs + src/TSN/XML/MLBBoxScore.hs src/TSN/XML/MLBEarlyLine.hs src/TSN/XML/News.hs src/TSN/XML/Odds.hs @@ -59,6 +60,7 @@ import TSN.XML.Heartbeat import TSN.XML.Injuries import TSN.XML.InjuriesDetail import TSN.XML.JFile +import TSN.XML.MLBBoxScore import TSN.XML.MLBEarlyLine import TSN.XML.News import TSN.XML.Odds diff --git a/htsn-import.cabal b/htsn-import.cabal index 203f1cd..d293ea8 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -293,6 +293,7 @@ executable htsn-import TSN.XML.Injuries TSN.XML.InjuriesDetail TSN.XML.JFile + TSN.XML.MLBBoxScore TSN.XML.MLBEarlyLine TSN.XML.News TSN.XML.Odds diff --git a/src/Main.hs b/src/Main.hs index e7f9e9c..bd5ed5c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -64,6 +64,9 @@ import qualified TSN.XML.Injuries as Injuries ( dtd, pickle_message ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( dtd, pickle_message ) +import qualified TSN.XML.MLBBoxScore as MLBBoxScore ( + dtd, + pickle_message ) import qualified TSN.XML.MLBEarlyLine as MLBEarlyLine ( dtd, pickle_message ) @@ -217,8 +220,9 @@ import_file cfg path = do | dtd == JFile.dtd = go JFile.pickle_message - | dtd == MLBEarlyLine.dtd = - go MLBEarlyLine.pickle_message + | dtd == MLBBoxScore.dtd = go MLBBoxScore.pickle_message + + | dtd == MLBEarlyLine.dtd = go MLBEarlyLine.pickle_message | dtd == News.dtd = -- Some of the newsxml docs are busted in predictable ways. diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs new file mode 100644 index 0000000..6de0540 --- /dev/null +++ b/src/TSN/XML/MLBBoxScore.hs @@ -0,0 +1,351 @@ +{-# 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 _ = ()