From 45f12af91c337280dbdface5b84a8fa6637f1d2b Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Thu, 2 Jan 2014 00:13:39 -0500
Subject: [PATCH] Add tests for Odds pickle/unpickle.

---
 src/TSN/XML/Odds.hs | 83 ++++++++++++++++++++++++++++++++++++++++++---
 test/TestSuite.hs   |  4 ++-
 2 files changed, 82 insertions(+), 5 deletions(-)

diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 1cdba55..9b35736 100644
--- a/src/TSN/XML/Odds.hs
+++ b/src/TSN/XML/Odds.hs
@@ -10,7 +10,8 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module TSN.XML.Odds (
-  Message )
+  Message,
+  odds_tests )
 where
 
 
@@ -32,6 +33,7 @@ import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
+import System.Console.CmdArgs.Default ( Default(..) )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
@@ -57,7 +59,7 @@ import TSN.Codegen (
   tsn_codegen_config,
   tsn_db_field_namer )
 import TSN.DbImport ( DbImport(..), ImportResult(..) )
-import Xml ( ToFromXml(..), pickle_unpickle )
+import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
 
 
 
@@ -101,7 +103,13 @@ data OddsGame =
     xml_game_over_under :: OddsOverUnder }
   deriving (Eq, Show)
 
-data Message = Message
+data Message =
+  Message {
+    db_sport :: String,
+    db_title :: String,
+    db_line_time :: String,
+    db_notes1 :: String,
+    db_notes2 :: String }
 
 data MessageXml =
   MessageXml {
@@ -119,6 +127,32 @@ data MessageXml =
   deriving (Eq, Show)
 
 
+instance ToFromXml Message where
+  type Xml Message = MessageXml
+  type Container Message = ()
+
+  -- Use a record wildcard here so GHC doesn't complain that we never
+  -- used our named fields.
+  to_xml (Message {..}) =
+    MessageXml
+      def
+      def
+      def
+      db_sport
+      db_title
+      db_line_time
+      db_notes1
+      def
+      db_notes2
+      def
+      def
+
+  -- We don't need the key argument (from_xml_fk) since the XML type
+  -- contains more information in this case.
+  from_xml (MessageXml _ _ _ d e f g _ i _ _) =
+    Message d e f g i
+
+
 pickle_casino :: PU OddsCasino
 pickle_casino =
   xpElem "Casino" $
@@ -222,7 +256,17 @@ pickle_message =
               (xpElem "time_stamp" xpText)
   where
     from_tuple = uncurryN MessageXml
-    to_tuple m = undefined
+    to_tuple m = (xml_xml_file_id m,
+                  xml_heading m,
+                  xml_category m,
+                  xml_sport m,
+                  xml_title m,
+                  xml_line_time m,
+                  xml_notes1 m,
+                  xml_games1 m,
+                  xml_notes2 m,
+                  xml_games2 m,
+                  xml_time_stamp m)
 
     pickle_notes :: PU String
     pickle_notes =
@@ -238,3 +282,34 @@ pickle_message =
 instance XmlPickler MessageXml where
   xpickle = pickle_message
 
+
+
+
+
+
+-- * Tasty Tests
+odds_tests :: TestTree
+odds_tests =
+  testGroup
+    "Odds tests"
+    [ test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+
+-- | 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 :: [MessageXml], actual) <- pickle_unpickle "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
diff --git a/test/TestSuite.hs b/test/TestSuite.hs
index 9e2e09c..9298bac 100644
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -4,6 +4,7 @@ import TSN.XML.Heartbeat ( heartbeat_tests )
 import TSN.XML.Injuries ( injuries_tests )
 import TSN.XML.InjuriesDetail ( injuries_detail_tests )
 import TSN.XML.News ( news_tests )
+import TSN.XML.Odds ( odds_tests )
 
 tests :: TestTree
 tests = testGroup
@@ -11,7 +12,8 @@ tests = testGroup
           [ heartbeat_tests,
             injuries_tests,
             injuries_detail_tests,
-            news_tests ]
+            news_tests,
+            odds_tests ]
 
 main :: IO ()
 main = defaultMain tests
-- 
2.44.2