Add support for the missing [AH]Starter elements in Odds.

[dead/htsn-import.git] / src / TSN / XML / Odds.hs

diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 5174ddb927462266e80af42eb45171bb49975f41..e2ef142b45b272d81ad3dec7b3beda312abb9554 100644 (file)
--- a/src/TSN/XML/Odds.hs
+++ b/src/TSN/XML/Odds.hs
@@ -147,16 +147,25 @@ instance FromXml OddsGameCasinoXml where
 instance XmlImport OddsGameCasinoXml
 
 
--- * OddsGameTeamXml
+-- * OddsGameTeamXml / OddsGameTeamStarterXml
+
+-- | The XML representation of a \"starter\". It contains both an ID
+--   and a name. The ID does not appear to be optional, but the name
+--   can be absent. When the name is absent, the ID has always been
+--   set to \"0\". This occurs even though the entire starter element
+--   is optional (see 'OddsGameTeamXml' below).
+--
+data OddsGameTeamStarterXml =
+  OddsGameTeamStarterXml {
+    xml_starter_id :: Int,
+    xml_starter_name :: Maybe String }
+  deriving (Eq, Show)
+
 
 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
 --   found in \<Game\>s. We can't use the 'Team' representation
 --   directly because there are some other fields we need to parse.
 --
---   The starter id/name could perhaps be combined into an embedded
---   type, but can you make an entire embedded type optional with
---   Maybe? I doubt it works.
---
 data OddsGameTeamXml =
   OddsGameTeamXml {
     xml_team_id         :: String, -- ^ The home/away team IDs
@@ -170,7 +179,7 @@ data OddsGameTeamXml =
     xml_team_rotation_number :: Maybe Int,
     xml_team_abbr            :: String,
     xml_team_name            :: String,
-    xml_team_starter         :: Maybe (Int, String), -- ^ (id, name)
+    xml_team_starter         :: Maybe OddsGameTeamStarterXml,
     xml_team_casinos         :: [OddsGameCasinoXml] }
   deriving (Eq, Show)
 
@@ -309,16 +318,20 @@ instance FromXmlFkTeams OddsGameXml where
         (xml_team_rotation_number xml_home_team),
 
       db_away_team_starter_id =
-        (fst <$> xml_team_starter xml_away_team),
+        (xml_starter_id <$> xml_team_starter xml_away_team),
 
-      db_away_team_starter_name =
-        (snd <$> xml_team_starter xml_away_team),
+      -- Sometimes the starter element is present but the name isn't,
+      -- so we combine the two maybes with join.
+      db_away_team_starter_name = join
+        (xml_starter_name <$> xml_team_starter xml_away_team),
 
       db_home_team_starter_id =
-        (fst <$> xml_team_starter xml_home_team),
+        (xml_starter_id <$> xml_team_starter xml_home_team),
 
-      db_home_team_starter_name =
-        (snd <$> xml_team_starter xml_home_team) }
+      -- Sometimes the starter element is present but the name isn't,
+      -- so we combine the two maybes with join.
+      db_home_team_starter_name = join
+        (xml_starter_name <$> xml_team_starter xml_home_team) }
 
 
 -- | This lets us insert the XML representation 'OddsGameXml' directly.
@@ -582,9 +595,7 @@ pickle_home_team =
         (xpElem "HomeRotationNumber" (xpOption xpInt))
         (xpElem "HomeAbbr" xpText)
         (xpElem "HomeTeamName" xpText)
-        (-- This is an ugly way to get both the HStarter ID attribute
-         -- and contents.
-         xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
+        (xpOption pickle_home_starter)
         (xpList pickle_casino)
   where
     from_tuple = uncurryN OddsGameTeamXml
@@ -597,6 +608,32 @@ pickle_home_team =
                                     xml_team_starter,
                                     xml_team_casinos)
 
+
+-- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
+--   specific to the home/away teams.
+--
+pickle_starter :: PU OddsGameTeamStarterXml
+pickle_starter =
+  xpWrap (from_tuple, to_tuple) $
+    xpPair (xpAttr "ID" xpInt) (xpOption xpText)
+  where
+    from_tuple = uncurry OddsGameTeamStarterXml
+    to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
+                                           xml_starter_name)
+
+-- | Pickler for an home team 'OddsGameTeamStarterXml'
+--
+pickle_home_starter :: PU OddsGameTeamStarterXml
+pickle_home_starter = xpElem "HStarter" $ pickle_starter
+
+
+-- | Pickler for an away team 'OddsGameTeamStarterXml'
+--
+pickle_away_starter :: PU OddsGameTeamStarterXml
+pickle_away_starter = xpElem "AStarter" $ pickle_starter
+
+
+
 -- | Pickler for an 'OddsGameTeamXml'.
 --
 pickle_away_team :: PU OddsGameTeamXml
@@ -608,9 +645,7 @@ pickle_away_team =
         (xpElem "AwayRotationNumber" (xpOption xpInt))
         (xpElem "AwayAbbr" xpText)
         (xpElem "AwayTeamName" xpText)
-        (-- This is an ugly way to get both the AStarter ID attribute
-         -- and contents.
-         xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
+        (xpOption pickle_away_starter)
         (xpList pickle_casino)
   where
     from_tuple = uncurryN OddsGameTeamXml
@@ -721,7 +756,10 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
           "test/xml/Odds_XML-largefile.xml",
 
     check "pickle composed with unpickle is the identity (league name)"
-          "test/xml/Odds_XML-league-name.xml" ]
+          "test/xml/Odds_XML-league-name.xml",
+
+    check "pickle composed with unpickle is the identity (missing starters)"
+          "test/xml/Odds_XML-missing-starters.xml" ]
   where
     check desc path = testCase desc $ do
       (expected, actual) <- pickle_unpickle pickle_message path
@@ -745,7 +783,10 @@ test_unpickle_succeeds = testGroup "unpickle tests"
           "test/xml/Odds_XML-largefile.xml",
 
     check "unpickling succeeds (league name)"
-          "test/xml/Odds_XML-league-name.xml" ]
+          "test/xml/Odds_XML-league-name.xml",
+
+    check "unpickling succeeds (missing starters)"
+          "test/xml/Odds_XML-missing-starters.xml" ]
   where
     check desc path = testCase desc $ do
       actual <- unpickleable path pickle_message
@@ -780,6 +821,10 @@ test_on_delete_cascade = testGroup "cascading delete tests"
     check "deleting odds deleted its children (league name)"
           "test/xml/Odds_XML-league-name.xml"
           35 -- 5 casinos, 30 teams
+    ,
+    check "deleting odds deleted its children (missing starters)"
+          "test/xml/Odds_XML-missing-starters.xml"
+          7 -- 5 casinos, 2 teams
     ]
   where
     check desc path expected = testCase desc $ do