X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;ds=inline;f=src%2FTSN%2FXML%2FScheduleChanges.hs;h=fd5641cdbc15660f6235c6a17dbcb369be68ec06;hb=073bbfba4165d4c01d29daaa7523c35c6cc7d114;hp=c447f35158a467be32f64c52b46e67f92662a3a9;hpb=36079b940ebe9a85ac2086fe640e39a0d51e756e;p=dead%2Fhtsn-import.git
diff --git a/src/TSN/XML/ScheduleChanges.hs b/src/TSN/XML/ScheduleChanges.hs
index c447f35..fd5641c 100644
--- a/src/TSN/XML/ScheduleChanges.hs
+++ b/src/TSN/XML/ScheduleChanges.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -25,19 +26,19 @@ where
import Control.Monad ( forM_ )
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,
mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
@@ -104,7 +105,12 @@ data ScheduleChangeXml =
ScheduleChangeXml {
xml_sc_sport :: String,
xml_sc_listings :: [ScheduleChangesListingXml] }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector ScheduleChangeXml
-- | XML representation of a 'ScheduleChanges'. It has the same
@@ -118,8 +124,12 @@ data Message =
xml_sport :: String,
xml_schedule_changes :: [ScheduleChangeXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
instance ToDb Message where
@@ -157,11 +167,18 @@ instance XmlImport Message
-- like, \FINAL\ within the XML,
-- but they're in one-to-one correspondence with the listings.
--
+-- The leading underscores prevent unused field warnings.
+--
data ScheduleChangesListingStatus =
ScheduleChangesListingStatus {
- db_status_numeral :: Int,
- db_status :: Maybe String } -- Yes, they can be empty.
- deriving (Eq, Show)
+ _db_status_numeral :: Int,
+ _db_status :: Maybe String } -- Yes, they can be empty.
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector ScheduleChangesListingStatus
-- | Database representation of a \ contained within a
@@ -206,7 +223,12 @@ data ScheduleChangesListingXml =
xml_hscore :: Int,
xml_listing_status :: ScheduleChangesListingStatus,
xml_notes :: Maybe String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector ScheduleChangesListingXml
instance ToDb ScheduleChangesListingXml where
@@ -303,7 +325,7 @@ mkPersist tsn_codegen_config [groundhog|
# Prevent multiple imports of the same message.
fields: [db_xml_file_id]
-# Note: we drop the "sc" prefix from the db_sc_sport field.
+ # Note: we drop the "sc" prefix from the db_sc_sport field.
- entity: ScheduleChangesListing
dbName: schedule_changes_listings
constructors:
@@ -327,9 +349,9 @@ mkPersist tsn_codegen_config [groundhog|
- embedded: ScheduleChangesListingStatus
fields:
- - name: db_status_numeral
+ - name: _db_status_numeral
dbName: status_numeral
- - name: db_status
+ - name: _db_status
dbName: status
|]
@@ -345,12 +367,12 @@ mkPersist tsn_codegen_config [groundhog|
pickle_away_team :: PU VTeam
pickle_away_team =
xpElem "Away_Team" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpPair (xpAttr "AT_ID" xpText)
(xpOption xpText)
where
from_tuple (x,y) = VTeam (Team x Nothing y)
- to_tuple (VTeam t) = (team_id t, name t)
+ to_tuple' (VTeam t) = (team_id t, name t)
-- | An (un)pickler for the \ elements.
@@ -358,12 +380,12 @@ pickle_away_team =
pickle_home_team :: PU HTeam
pickle_home_team =
xpElem "Home_Team" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpPair (xpAttr "HT_ID" xpText)
(xpOption xpText)
where
from_tuple (x,y) = HTeam (Team x Nothing y)
- to_tuple (HTeam t) = (team_id t, name t)
+ to_tuple' (HTeam t) = (team_id t, name t)
-- | An (un)pickler for the \ elements.
@@ -371,13 +393,11 @@ pickle_home_team =
pickle_status :: PU ScheduleChangesListingStatus
pickle_status =
xpElem "status" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpAttr "numeral" xpInt)
(xpOption xpText)
where
from_tuple = uncurry ScheduleChangesListingStatus
- to_tuple s = (db_status_numeral s,
- db_status s)
-- | An (un)pickler for the \ elements.
@@ -385,7 +405,7 @@ pickle_status =
pickle_listing :: PU ScheduleChangesListingXml
pickle_listing =
xpElem "SC_Listing" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp11Tuple (xpAttr "type" xpText)
(xpElem "Schedule_ID" xpInt)
(xpElem "Game_Date" xp_date_padded)
@@ -399,17 +419,6 @@ pickle_listing =
(xpElem "notes" (xpOption xpText))
where
from_tuple = uncurryN ScheduleChangesListingXml
- to_tuple l = (xml_type l,
- xml_schedule_id l,
- xml_game_date l,
- xml_game_time l,
- xml_location l,
- xml_away_team l,
- xml_home_team l,
- xml_vscore l,
- xml_hscore l,
- xml_listing_status l,
- xml_notes l)
-- | An (un)pickler for the \ elements.
@@ -417,13 +426,11 @@ pickle_listing =
pickle_schedule_change :: PU ScheduleChangeXml
pickle_schedule_change =
xpElem "Schedule_Change" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpAttr "Sport" xpText)
(xpList pickle_listing)
where
from_tuple = uncurry ScheduleChangeXml
- to_tuple sc = (xml_sc_sport sc,
- xml_sc_listings sc)
-- | Pickler for the top-level 'Message'.
@@ -431,7 +438,7 @@ pickle_schedule_change =
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp6Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
(xpElem "category" xpText)
@@ -440,12 +447,6 @@ pickle_message =
(xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
- to_tuple m = (xml_xml_file_id m,
- xml_heading m,
- xml_category m,
- xml_sport m,
- xml_schedule_changes m,
- xml_time_stamp m)
@@ -501,7 +502,7 @@ test_on_delete_cascade =
let c = undefined :: ScheduleChangesListing
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c