Add a test for the correct field names in TSN.Xml.News.

diff --git a/src/TSN/Codegen.hs b/src/TSN/Codegen.hs
index d5d9bbd31472a316f92f001cf7b415dce47e33f0..cd5853c9dfccbfa4a0f873e3dd662ab60b8aca65 100644 (file)
--- a/src/TSN/Codegen.hs
+++ b/src/TSN/Codegen.hs
@@ -1,5 +1,7 @@
 module TSN.Codegen (
-  tsn_codegen_config )
+  tsn_codegen_config,
+  tsn_db_field_namer -- Used in a TSN.XML.News test.
+  )
 where
 
 import Data.List.Utils ( join, split )

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 61da812807e7920a50f089a3767f13beff9200f6..5782d2412e2f38820724de05195bf60986572cc7 100644 (file)
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -17,8 +18,10 @@ module TSN.XML.News (
 where
 
 import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
 import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
+import Data.Typeable ( Typeable )
 import Database.Groundhog (
   defaultMigrationLogger,
   insert,
@@ -46,7 +49,10 @@ import Text.XML.HXT.Core (
   xpWrap )
 
 import Network.Services.TSN.Report ( report_error )
-import TSN.Codegen ( tsn_codegen_config )
+import TSN.Codegen (
+  tsn_codegen_config,
+  tsn_db_field_namer -- Used in a test.
+  )
 import TSN.DbImport ( DbImport(..) )
 import Xml ( ToFromXml(..), pickle_unpickle )
 
@@ -131,7 +137,7 @@ data MsgId =
   MsgId {
     db_msg_id       :: Int,
     db_event_id     :: Maybe Int }
-  deriving (Eq, Show)
+  deriving (Data, Eq, Show, Typeable)
 
 
 data MessageXml =
@@ -158,7 +164,7 @@ data Message =
     db_sms :: String,
     db_text :: String,
     db_continue :: String }
-  deriving (Eq, Show)
+  deriving (Data, Eq, Show, Typeable)
 
 instance ToFromXml Message where
   type Xml Message = MessageXml
@@ -330,7 +336,8 @@ news_tests :: TestTree
 news_tests =
   testGroup
     "News tests"
-    [ test_pickle_of_unpickle_is_identity ]
+    [ test_news_fields_have_correct_names,
+      test_pickle_of_unpickle_is_identity ]
 
 
 test_pickle_of_unpickle_is_identity :: TestTree
@@ -339,3 +346,24 @@ test_pickle_of_unpickle_is_identity =
     let path = "test/xml/newsxml.xml"
     (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
     actual @?= expected
+
+
+test_news_fields_have_correct_names :: TestTree
+test_news_fields_have_correct_names =
+  testCase "news fields get correct database names" $ do
+    mapM_ check (zip actual expected)
+  where
+    -- This is cool, it uses the (derived) Data instance of
+    -- News.Message to get its constructor names.
+    field_names :: [String]
+    field_names =
+      constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: Message)
+
+    expected :: [String]
+    expected =
+      map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
+
+    actual :: [String]
+    actual = ["mid", "sport", "url", "sms", "text", "continue"]
+
+    check (x,y) = (x @?= y)