Fix unpickling of texttual over/under lines.

diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 7eb759b79239721c4055cf933a58dc4dc612dbab..eb017d8131678e2bebd29621bdf4d83a9ebd6c6d 100644 (file)
--- a/src/TSN/XML/Odds.hs
+++ b/src/TSN/XML/Odds.hs
@@ -16,7 +16,7 @@ module TSN.XML.Odds (
   pickle_message )
 where
 
-import Control.Monad ( forM_ )
+import Control.Monad ( forM_, join )
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog (
   (=.),
@@ -31,6 +31,7 @@ import Database.Groundhog.TH (
   mkPersist )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.Read ( readMaybe )
 import Text.XML.HXT.Core (
   PU,
   xp5Tuple,
@@ -55,14 +56,25 @@ import Xml ( FromXml(..), pickle_unpickle, unpickleable )
 
 
 
+-- | The home/away lines are 'Double's, but the over/under lines are
+--   textual. If we want to use one data type for both, we have to go
+--   with a String and then attempt to 'read' a 'Double' later when we
+--   go to insert the thing.
+--
 data OddsGameCasinoXml =
   OddsGameCasinoXml {
     xml_casino_client_id :: Int,
     xml_casino_name      :: String,
-    xml_casino_line      :: Maybe Double }
+    xml_casino_line      :: Maybe String }
   deriving (Eq, Show)
 
 
+-- | Try to get a 'Double' out of the 'xml_casino_line' which is a
+--   priori textual (because it might be an over/under line).
+--
+home_away_line :: OddsGameCasinoXml -> Maybe Double
+home_away_line = join . (fmap readMaybe) . xml_casino_line
+
 -- | The casinos should have their own table, but the lines don't
 --   belong in that table. (There should be another table joining the
 --   casinos and the thing the lines are for together.)
@@ -147,14 +159,20 @@ newtype OddsGameOverUnderXml =
 
 -- | This database representation of the casino lines can't be
 --   constructed from the one in the XML. The casinos within
---   Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all the
---   same. We don't need a bajillion different tables to store that --
---   just one tying the casino/game pair to the three lines.
+--   Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
+--   less the same. We don't need a bajillion different tables to
+--   store that, just one tying the casino/game pair to the three
+--   lines.
+--
+--   The one small difference between the over/under casinos and the
+--   home/away ones is that the home/away lines are all 'Double's, but
+--   the over/under lines appear to be textual.
+--
 data OddsGameLine =
   OddsGameLine {
     ogl_odds_games_id   :: DefaultKey OddsGame,
     ogl_odds_casinos_id :: DefaultKey OddsCasino,
-    ogl_over_under      :: Maybe Double,
+    ogl_over_under      :: Maybe String,
     ogl_away_line       :: Maybe Double,
     ogl_home_line       :: Maybe Double }
 
@@ -361,14 +379,18 @@ instance DbImport Message where
         -- insert, or more likely retrieve the existing, casino
         a_casino_id <- insert_xml_or_select c
 
+        -- Get a Maybe Double instead of the Maybe String that's in there.
+        let away_line = home_away_line c
+
         -- Unconditionally update that casino's away team line with ours.
-        update [Ogl_Away_Line =. (xml_casino_line c)] $ -- WHERE
+        update [Ogl_Away_Line =. away_line] $ -- WHERE
           Ogl_Odds_Casinos_Id ==. a_casino_id
 
       -- Repeat all that for the home team.
       forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
         h_casino_id <- insert_xml_or_select c
-        update [Ogl_Home_Line =. (xml_casino_line c)] $ -- WHERE
+        let home_line = home_away_line c
+        update [Ogl_Home_Line =. home_line] $ -- WHERE
           Ogl_Odds_Casinos_Id ==. h_casino_id
 
       return game_id
@@ -394,7 +416,7 @@ pickle_casino =
   xpTriple
     (xpAttr "ClientID" xpInt)
     (xpAttr "Name" xpText)
-    (xpOption xpPrim) -- Double
+    (xpOption xpText)
   where
     from_tuple = uncurryN OddsGameCasinoXml
     -- Use record wildcards to avoid unused field warnings.
@@ -515,17 +537,27 @@ odds_tests =
 -- | Warning, succeess of this test does not mean that unpickling
 --   succeeded.
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
-  testCase "pickle composed with unpickle is the identity" $ do
-    let path = "test/xml/Odds_XML.xml"
-    (expected, actual) <- pickle_unpickle pickle_message path
-    actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+  [ check "pickle composed with unpickle is the identity"
+         "test/xml/Odds_XML.xml",
+
+    check "pickle composed with unpickle is the identity (positive(+) line)"
+          "test/xml/Odds_XML-positive-line.xml" ]
+  where
+    check desc path = testCase desc $ do
+      (expected, actual) <- pickle_unpickle pickle_message path
+      actual @?= expected
 
 
 test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds =
-  testCase "unpickling succeeds" $ do
-  let path = "test/xml/Odds_XML.xml"
-  actual <- unpickleable path pickle_message
-  let expected = True
-  actual @?= expected
+test_unpickle_succeeds = testGroup "unpickle tests"
+  [ check "unpickling succeeds"
+          "test/xml/Odds_XML.xml",
+
+    check "unpickling succeeds (positive(+) line)"
+          "test/xml/Odds_XML-positive-line.xml" ]
+  where
+    check desc path = testCase desc $ do
+      actual <- unpickleable path pickle_message
+      let expected = True
+      actual @?= expected