Add the 'xp_attr_option' pickler and use it to fix tests broken by HXT.

[dead/htsn-import.git] / src / TSN / XML / News.hs

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 021d49a01a0277a80602372b4bdf2274e42f71de..54169b982b00d278717d89e2a1042bde14cc6faf 100644 (file)
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -28,15 +28,14 @@ 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,
@@ -67,14 +66,13 @@ import Text.XML.HXT.Core (
   xpWrap )
 
 -- Local imports.
-import Generics ( Generic(..), to_tuple )
 import TSN.Codegen (
   tsn_codegen_config,
   tsn_db_field_namer ) -- Used in a test
 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 (
@@ -82,7 +80,7 @@ import Xml (
   ToDb(..),
   pickle_unpickle,
   unpickleable,
-  unsafe_read_document,
+  unsafe_read_invalid_document,
   unsafe_unpickle )
 
 
@@ -103,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 (\<message\>).
@@ -130,9 +134,9 @@ data Message =
   deriving (Eq, GHC.Generic, Show)
 
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic Message
+instance H.HVector Message
 
 
 -- | The database representation of a news item. We drop several
@@ -165,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,
@@ -192,9 +198,9 @@ data NewsTeamXml =
   deriving (Eq, GHC.Generic, Show)
 
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic NewsTeamXml
+instance H.HVector NewsTeamXml
 
 
 instance ToDb NewsTeamXml where
@@ -326,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
@@ -370,7 +376,7 @@ mkPersist tsn_codegen_config [groundhog|
 pickle_news_team :: PU NewsTeamXml
 pickle_news_team =
   xpElem "team" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
       xpPair (xpAttr "id" xpText)
              xpText -- team name
   where
@@ -382,14 +388,11 @@ 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
 
-    -- Avoid unused field warnings.
-    to_tuple' m = (db_msg_id m, db_event_id m)
-
 
 
 -- | Convert a 'Message' to/from XML.
@@ -397,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
@@ -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