]> gitweb.michael.orlitzky.com - dead/htsn-import.git/commitdiff
Add stub for TSN.XML.MLBBoxScore.
authorMichael Orlitzky <michael@orlitzky.com>
Fri, 7 Nov 2014 14:52:18 +0000 (09:52 -0500)
committerMichael Orlitzky <michael@orlitzky.com>
Fri, 7 Nov 2014 14:52:18 +0000 (09:52 -0500)
.ghci
htsn-import.cabal
src/Main.hs
src/TSN/XML/MLBBoxScore.hs [new file with mode: 0644]

diff --git a/.ghci b/.ghci
index dfeb6df952c075114e4111f7edd675e29073090e..b3270630eb613fb2814a5c8b4c1962dcd0d69c81 100644 (file)
--- 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
index 203f1cd74f394df589d11a3e9a0fadc97b5e1abc..d293ea86bb6fc0515eff7352fa92e7134bac0cf5 100644 (file)
@@ -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
index e7f9e9c6213ae8df2b65214d4ff46b69e9b294f5..bd5ed5c1cb07e3c17aadd9c0df946bc304040452 100644 (file)
@@ -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 (file)
index 0000000..6de0540
--- /dev/null
@@ -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   _ = ()