X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScores.hs;h=8bfb19669f501d99925548522b8247c4bdfb1be6;hb=351f565decb5870ecf0ec923d4a8d2146b2598bd;hp=adbd5cd9badb0e1a9bdb035bc91f698cc76f17dc;hpb=14dc52a2e7d7712281aee2332f7342f67abe4306;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs
index adbd5cd..8bfb196 100644
--- a/src/TSN/XML/Scores.hs
+++ b/src/TSN/XML/Scores.hs
@@ -61,12 +61,15 @@ import TSN.Database ( insert_or_select )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Location ( Location(..), pickle_location )
 import TSN.Picklers ( xp_time_stamp )
-import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
+import TSN.Team (
+  FromXmlFkTeams(..),
+  HTeam(..),
+  Team(..),
+  VTeam(..) )
 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
 import Xml (
   Child(..),
   FromXml(..),
-  FromXmlFkTeams(..),
   ToDb(..),
   pickle_unpickle,
   unpickleable,
@@ -156,7 +159,7 @@ instance XmlImport Message
 --
 data ScoreGameStatus =
   ScoreGameStatus {
-    db_status_numeral :: Int,
+    db_status_numeral :: Maybe Int,
     db_status_type :: Maybe String, -- ^ These are probably only one-character,
                                     --   long, but they all take the same
                                     --    amount of space in Postgres.
@@ -428,20 +431,26 @@ pickle_message =
 
 
 
--- | Convert a 'ScoreGameStatus' to/from \<status\>.
+-- | Convert a 'ScoreGameStatus' to/from \<status\>. The \"type\"
+--   attribute can be either missing or empty, so we're really parsing
+--   a double-Maybe here. We use the monad join to collapse it into
+--   one. See also: the hteam/vteam picklers.
 --
 pickle_status :: PU ScoreGameStatus
 pickle_status =
   xpElem "status" $
     xpWrap (from_tuple, to_tuple) $
-      xpTriple (xpAttr "numeral" xpInt)
-               (xpOption $ xpAttr "type" xpText)
+      xpTriple (xpAttr "numeral" $ xpOption xpInt)
+               (xpOption $ xpAttr "type" $ xpOption xpText)
                xpText
   where
-    from_tuple = uncurryN ScoreGameStatus
-    to_tuple ScoreGameStatus{..} = (db_status_numeral,
-                                    db_status_type,
-                                    db_status_text)
+    from_tuple (x,y,z) = ScoreGameStatus x (join y) z
+    to_tuple ScoreGameStatus{..} =
+      (db_status_numeral, s, db_status_text)
+      where
+      s = case db_status_type of
+            Nothing -> Nothing
+            Just _  -> Just db_status_type
 
 
 -- | Convert a 'ScoreGameXml' to/from \<game\>.
@@ -549,7 +558,13 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
           "test/xml/scoresxml-no-locations.xml",
 
     check "pickle composed with unpickle is the identity (pitcher, no type)"
-          "test/xml/scoresxml-pitcher-no-type.xml"]
+          "test/xml/scoresxml-pitcher-no-type.xml",
+
+    check "pickle composed with unpickle is the identity (empty numeral)"
+          "test/xml/scoresxml-empty-numeral.xml",
+
+    check "pickle composed with unpickle is the identity (empty type)"
+          "test/xml/scoresxml-empty-type.xml" ]
   where
     check desc path = testCase desc $ do
       (expected, actual) <- pickle_unpickle pickle_message path
@@ -567,7 +582,13 @@ test_unpickle_succeeds = testGroup "unpickle tests"
           "test/xml/scoresxml-no-locations.xml",
 
     check "unpickling succeeds (pitcher, no type)"
-          "test/xml/scoresxml-pitcher-no-type.xml" ]
+          "test/xml/scoresxml-pitcher-no-type.xml",
+
+    check "unpickling succeeds (empty numeral)"
+          "test/xml/scoresxml-empty-numeral.xml",
+
+    check "unpickling succeeds (empty type)"
+          "test/xml/scoresxml-empty-type.xml" ]
   where
     check desc path = testCase desc $ do
       actual <- unpickleable path pickle_message
@@ -590,7 +611,15 @@ test_on_delete_cascade = testGroup "cascading delete tests"
 
     check "unpickling succeeds (pitcher, no type)"
           "test/xml/scoresxml-pitcher-no-type.xml"
-          3 -- 2 teams, 1 location
+          3, -- 2 teams, 1 location
+
+    check "unpickling succeeds (empty numeral)"
+          "test/xml/scoresxml-empty-numeral.xml"
+          3, -- 2 teams, 1 location
+
+    check "unpickling succeeds (empty type)"
+          "test/xml/scoresxml-empty-type.xml"
+          4 -- 2 teams, 2 locations
   ]
   where
     check desc path expected = testCase desc $ do