From: Michael Orlitzky Date: Thu, 2 Jan 2014 05:13:39 +0000 (-0500) Subject: Add tests for Odds pickle/unpickle. X-Git-Tag: 0.0.1~121 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=45f12af91c337280dbdface5b84a8fa6637f1d2b;p=dead%2Fhtsn-import.git Add tests for Odds pickle/unpickle. --- 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