X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=7143c459a4d9fbba182d9ef877c259d6ace59e45;hb=44e32bf7b5aa2d0b98b40f25ec650d9b3e0f01ca;hp=1cdba551b42225e84da5b3e1c7ae425c7a02e05e;hpb=a53f1a77e6d24d8a4771be4dd365f2738c50bf6f;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 1cdba55..7143c45 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" $
@@ -216,18 +250,28 @@ pickle_message =
               (xpElem "Title" xpText)
               (xpElem "Line_Time" xpText)
               pickle_notes
-              (xpList $ pickle_game)
+              (xpList pickle_game)
               pickle_notes
-              (xpList $ pickle_game)
+              (xpList pickle_game)
               (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 =
       xpWrap (to_string, from_string) $
-          (xpList $ xpElem "Notes" xpText)
+        xpList (xpElem "Notes" xpText)
       where
         from_string :: String -> [String]
         from_string = split "\n"
@@ -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