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

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

diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs
index 88c8634e7484236d9a33e0e5096becb04455c0a7..7f5a89048d93afb202237aa03f746e0d41cfaa82 100644 (file)
--- a/src/TSN/XML/EarlyLine.hs
+++ b/src/TSN/XML/EarlyLine.hs
@@ -37,15 +37,14 @@ where
 import Control.Monad ( join )
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
+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,
@@ -68,11 +67,11 @@ import Text.XML.HXT.Core (
   xpWrap )
 
 -- Local imports.
-import Generics ( Generic(..), to_tuple )
 import TSN.Codegen ( tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers (
   xp_ambiguous_time,
+  xp_attr_option,
   xp_early_line_date,
   xp_time_stamp )
 import TSN.XmlImport ( XmlImport(..) )
@@ -125,9 +124,9 @@ data Message =
     xml_time_stamp :: UTCTime }
   deriving (Eq, GHC.Generic, Show)
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic Message
+instance H.HVector Message
 
 
 instance ToDb Message where
@@ -189,9 +188,9 @@ data EarlyLineGameWithNote =
 date_game :: EarlyLineGameWithNote -> EarlyLineGameXml
 date_game (EarlyLineGameWithNote _ g) = g
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic EarlyLineGameWithNote
+instance H.HVector EarlyLineGameWithNote
 
 
 
@@ -206,9 +205,9 @@ data EarlyLineDate =
     date_games_with_notes :: [EarlyLineGameWithNote] }
   deriving (Eq, GHC.Generic, Show)
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic EarlyLineDate
+instance H.HVector EarlyLineDate
 
 
 
@@ -257,9 +256,9 @@ data EarlyLineGameXml =
   deriving (Eq, GHC.Generic, Show)
 
 
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
 --
-instance Generic EarlyLineGameXml
+instance H.HVector EarlyLineGameXml
 
 
 -- * EarlyLineGameTeam / EarlyLineGameTeamXml
@@ -480,7 +479,7 @@ mkPersist tsn_codegen_config [groundhog|
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
     xp7Tuple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
@@ -498,7 +497,7 @@ pickle_message =
 --
 pickle_game_with_note :: PU EarlyLineGameWithNote
 pickle_game_with_note =
-  xpWrap (from_tuple, to_tuple) $
+  xpWrap (from_tuple, H.convert) $
     xpPair (xpOption $ xpElem "note" xpText)
            pickle_game
   where
@@ -510,7 +509,7 @@ pickle_game_with_note =
 pickle_date :: PU EarlyLineDate
 pickle_date =
   xpElem "date" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
     xpPair (xpAttr "value" xp_early_line_date)
            (xpList pickle_game_with_note)
   where
@@ -523,7 +522,7 @@ pickle_date =
 pickle_game :: PU EarlyLineGameXml
 pickle_game =
   xpElem "game" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
     xp4Tuple (xpElem "time" (xpOption xp_ambiguous_time))
              pickle_away_team
              pickle_home_team
@@ -561,7 +560,7 @@ pickle_home_team = xpElem "teamH" pickle_team
 pickle_team :: PU EarlyLineGameTeamXml
 pickle_team =
   xpWrap (from_tuple, to_tuple') $
-  xp6Tuple (xpAttr "rotation" (xpOption xpInt))
+  xp6Tuple (xpAttr "rotation" xp_attr_option)
            (xpOption $ xpAttr "line" (xpOption xpText))
            (xpOption $ xpAttr "name" xpText)
            (xpOption xpText)
@@ -600,7 +599,7 @@ early_line_tests =
 --   test does not mean that unpickling succeeded.
 --
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
   [ check "pickle composed with unpickle is the identity"
           "test/xml/earlylineXML.xml",
 
@@ -616,7 +615,7 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $
 -- | Make sure we can actually unpickle these things.
 --
 test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds = testGroup "unpickle tests" $
+test_unpickle_succeeds = testGroup "unpickle tests"
   [ check "unpickling succeeds"
           "test/xml/earlylineXML.xml",
 
@@ -634,7 +633,7 @@ test_unpickle_succeeds = testGroup "unpickle tests" $
 --   record.
 --
 test_on_delete_cascade :: TestTree
-test_on_delete_cascade = testGroup "cascading delete tests" $
+test_on_delete_cascade = testGroup "cascading delete tests"
   [ check "deleting early_lines deletes its children"
           "test/xml/earlylineXML.xml",
 
@@ -647,7 +646,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" $
       let b = undefined :: EarlyLineGame
 
       actual <- withSqliteConn ":memory:" $ runDbConn $ do
-                  runMigration silentMigrationLogger $ do
+                  runMigrationSilent $ do
                     migrate a
                     migrate b
                   _ <- dbimport results