From: Michael Orlitzky Date: Tue, 31 Dec 2013 22:11:35 +0000 (-0500) Subject: Add a test for the correct field names in TSN.Xml.News. X-Git-Tag: 0.0.1~132 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=44e4325046b133ccda1f8548515641602d223ddb;p=dead%2Fhtsn-import.git 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 d5d9bbd..cd5853c 100644 --- 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 61da812..5782d24 100644 --- 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)