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 0207593260196b00917cc8e0ac798a0b651cb5eb..54169b982b00d278717d89e2a1042bde14cc6faf 100644 (file)
--- 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 (\<message\>).
@@ -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 \<continue\> 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