X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=54169b982b00d278717d89e2a1042bde14cc6faf;hb=f0425854304197ab5ad47293b27b2e0b188cb844;hp=0207593260196b00917cc8e0ac798a0b651cb5eb;hpb=a7e41a48ee8a9c72f66f2cde0a86b3e49abc423c;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 0207593..54169b9 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -27,19 +28,19 @@ import Data.Time.Clock ( UTCTime ) import Data.List.Utils ( join, split ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, insert_, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -71,7 +72,7 @@ import TSN.Codegen ( import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) -import TSN.Picklers ( xp_time_stamp ) +import TSN.Picklers ( xp_attr_option, xp_time_stamp ) import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( @@ -79,7 +80,7 @@ import Xml ( ToDb(..), pickle_unpickle, unpickleable, - unsafe_read_document, + unsafe_read_invalid_document, unsafe_unpickle ) @@ -100,11 +101,17 @@ dtd = "newsxml.dtd" -- prefix here so that the two names don't collide on \"id\" when -- Groundhog is creating its fields using our field namer. -- +-- The leading underscores prevent unused field warnings. +-- data MsgId = MsgId { - db_msg_id :: Int, - db_event_id :: Maybe Int } - deriving (Data, Eq, Show, Typeable) + _db_msg_id :: Int, + _db_event_id :: Maybe Int } + deriving (Data, Eq, GHC.Generic, Show, Typeable) + +-- | For 'H.convert'. +-- +instance H.HVector MsgId -- | The XML representation of a news item (\). @@ -124,7 +131,12 @@ data Message = xml_text :: Maybe String, -- Text and continue seem to show up in pairs, xml_continue :: Maybe String, -- either both present or both missing. xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message -- | The database representation of a news item. We drop several @@ -157,6 +169,8 @@ instance FromXml Message where -- | We use a record wildcard so GHC doesn't complain that we never -- used the field names. -- + -- To convert, we drop some fields. + -- from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id, db_mid = xml_mid, db_sport = xml_sport, @@ -181,7 +195,13 @@ instance XmlImport Message data NewsTeamXml = NewsTeamXml { xml_team_id :: String, xml_team_name :: String } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector NewsTeamXml + instance ToDb NewsTeamXml where -- | The database representation of 'NewsTeamXml' is 'Team'. @@ -312,9 +332,9 @@ mkPersist tsn_codegen_config [groundhog| - embedded: MsgId fields: - - name: db_msg_id + - name: _db_msg_id dbName: msg_id - - name: db_event_id + - name: _db_event_id dbName: event_id - entity: News_Team @@ -356,15 +376,11 @@ mkPersist tsn_codegen_config [groundhog| pickle_news_team :: PU NewsTeamXml pickle_news_team = xpElem "team" $ - xpWrap (from_pair, to_pair) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "id" xpText) xpText -- team name where - from_pair :: (String, String) -> NewsTeamXml - from_pair = uncurry NewsTeamXml - - to_pair :: NewsTeamXml -> (String, String) - to_pair (NewsTeamXml x y) = (x,y) + from_tuple = uncurry NewsTeamXml -- | Convert a 'MsgId' to/from XML. @@ -372,11 +388,10 @@ pickle_news_team = pickle_msg_id :: PU MsgId pickle_msg_id = xpElem "msg_id" $ - xpWrap (from_tuple, to_tuple) $ - xpPair xpInt (xpAttr "EventId" (xpOption xpInt)) + xpWrap (from_tuple, H.convert) $ + xpPair xpInt (xpAttr "EventId" xp_attr_option) where from_tuple = uncurryN MsgId - to_tuple m = (db_msg_id m, db_event_id m) @@ -385,7 +400,7 @@ pickle_msg_id = pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp13Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) pickle_msg_id @@ -401,19 +416,7 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, -- Verbose, - xml_heading m, -- but - xml_mid m, -- eliminates - xml_category m, -- GHC - xml_sport m, -- warnings - xml_url m, -- . - xml_teams m, -- . - xml_locations m, -- . - xml_sms m, - xml_editor m, - xml_text m, - xml_continue m, - xml_time_stamp m) + -- | We combine all of the \ elements into one 'String' -- while unpickling and do the reverse while pickling. @@ -540,7 +543,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" let d = undefined :: News_Team let e = undefined :: News_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c @@ -571,6 +574,6 @@ test_sms_detected_correctly = False ] where check path desc expected = testCase desc $ do - xmltree <- unsafe_read_document path + xmltree <- unsafe_read_invalid_document path let actual = has_only_single_sms xmltree actual @?= expected