X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=661279272e5f1056221fdcb1e06cbfc1ccfe5157;hb=a1edb885c755aac52e805255382dda50f6664b60;hp=aa1a01c278dea76709a6c528beb0d9b41bf48104;hpb=9fff5c185dd7a2c8655815f36b72736d61401e41;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index aa1a01c..6612792 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -30,6 +30,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 (
@@ -39,20 +40,19 @@ import Text.XML.HXT.Core (
   xp12Tuple,
   xpAttr,
   xpElem,
+  xpInt,
   xpList,
   xpOption,
   xpPair,
-  xpPrim,
   xpText,
   xpTriple,
   xpWrap )
 
 import TSN.Codegen (
   tsn_codegen_config,
-  tsn_db_field_namer -- Used in a test.
-  )
+  tsn_db_field_namer ) -- Used in a test
 import TSN.DbImport ( DbImport(..), ImportResult(..) )
-import Xml ( ToFromXml(..), pickle_unpickle )
+import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
 
 
 
@@ -172,23 +172,23 @@ instance ToFromXml Message where
   -- used our named fields.
   to_xml (Message {..}) =
     MessageXml
-      0
-      ""
+      def
+      def
       db_mid
-      ""
+      def
       db_sport
       db_url
-      []
-      []
+      def
+      def
       db_sms
       db_text
       db_continue
-      ""
+      def
 
   -- We don't need the key argument (from_xml_fk) since the XML type
   -- contains more information in this case.
-  from_xml (MessageXml _ _ c _ e f _ _ g h i _) =
-    Message c e f g h i
+  from_xml (MessageXml _ _ c _ e f _ _ i j k _) =
+    Message c e f i j k
 
 
 mkPersist tsn_codegen_config [groundhog|
@@ -233,7 +233,7 @@ pickle_msg_id :: PU MsgId
 pickle_msg_id =
   xpElem "msg_id" $
     xpWrap (from_tuple, to_tuple) $
-    xpPair xpPrim (xpAttr "EventId" (xpOption xpPrim))
+    xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
   where
     from_tuple = uncurryN MsgId
     to_tuple m = (db_msg_id m, db_event_id m)
@@ -261,7 +261,7 @@ pickle_message :: PU MessageXml
 pickle_message =
   xpElem "message" $
     xpWrap (from_tuple, to_tuple) $
-    xp12Tuple (xpElem "XML_File_ID" xpPrim)
+    xp12Tuple (xpElem "XML_File_ID" xpInt)
               (xpElem "heading" xpText)
               pickle_msg_id
               (xpElem "category" xpText)
@@ -334,15 +334,8 @@ news_tests =
   testGroup
     "News tests"
     [ test_news_fields_have_correct_names,
-      test_pickle_of_unpickle_is_identity ]
-
-
-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/newsxml.xml"
-    (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
-    actual @?= expected
+      test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
 
 
 test_news_fields_have_correct_names :: TestTree
@@ -364,3 +357,22 @@ test_news_fields_have_correct_names =
     actual = ["mid", "sport", "url", "sms", "text", "continue"]
 
     check (x,y) = (x @?= y)
+
+
+-- | 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/newsxml.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/newsxml.xml"
+  actual <- unpickleable path pickle_message
+  let expected = True
+  actual @?= expected