X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScheduleChanges.hs;h=fd5641cdbc15660f6235c6a17dbcb369be68ec06;hb=32147474ba5c91452eeb532381f63e88c257a982;hp=5f0eff25144b8c1c3b3ba8e7d0f2b522d3f6fb7e;hpb=2dd1ab7a375b55632f6c8165dce97a2df3cc1907;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/ScheduleChanges.hs b/src/TSN/XML/ScheduleChanges.hs index 5f0eff2..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 ( @@ -54,11 +55,11 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. -import TSN.Codegen ( - tsn_codegen_config ) +import TSN.Codegen ( tsn_codegen_config ) +import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) -import TSN.Team ( Team(..) ) +import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), @@ -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,9 +124,13 @@ 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 -- | The database analogue of a 'Message' is a 'ScheduleChanges'. @@ -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 @@ -200,13 +217,18 @@ data ScheduleChangesListingXml = xml_game_date :: UTCTime, xml_game_time :: Maybe UTCTime, xml_location :: Maybe String, - xml_away_team :: ScheduleChangesListingAwayTeamXml, - xml_home_team :: ScheduleChangesListingHomeTeamXml, + xml_away_team :: VTeam, + xml_home_team :: HTeam, xml_vscore :: Int, 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 @@ -256,77 +278,6 @@ from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} = --- * ScheduleChangesListingAwayTeamXml / ScheduleChangesListingHomeTeamXml - --- | The XML representation of a 'ScheduleChangesListing' away --- team. Its corresponding database representation (along with that --- of the home team) is a "TSN.Team", but their XML representations --- are different. --- -data ScheduleChangesListingAwayTeamXml = - ScheduleChangesListingAwayTeamXml { - away_team_id :: String, - away_team_name :: Maybe String } - deriving (Eq, Show) - - -instance ToDb ScheduleChangesListingAwayTeamXml where - -- | The database analogue of an 'ScheduleChangesListingAwayTeamXml' is - -- a 'Team'. - -- - type Db ScheduleChangesListingAwayTeamXml = Team - - -instance FromXml ScheduleChangesListingAwayTeamXml where - -- | To convert a 'ScheduleChangesListingAwayTeamXml' to a 'Team', - -- we set the non-existent abbreviation to \"Nothing\". - -- - from_xml ScheduleChangesListingAwayTeamXml{..} = - Team { - team_id = away_team_id, - abbreviation = Nothing, - name = away_team_name } - --- | Allow us to import ScheduleChangesListingAwayTeamXml directly. --- -instance XmlImport ScheduleChangesListingAwayTeamXml - - --- | The XML representation of a 'ScheduleChangesListing' home --- team. Its corresponding database representation (along with that --- of the away team) is a "TSN.Team", but their XML representations --- are different. --- -data ScheduleChangesListingHomeTeamXml = - ScheduleChangesListingHomeTeamXml { - home_team_id :: String, - home_team_name :: Maybe String } - deriving (Eq, Show) - - -instance ToDb ScheduleChangesListingHomeTeamXml where - -- | The database analogue of an 'ScheduleChangesListingHomeTeamXml' - -- is a 'Team'. - -- - type Db ScheduleChangesListingHomeTeamXml = Team - - -instance FromXml ScheduleChangesListingHomeTeamXml where - -- | To convert a 'ScheduleChangesListingHomeTeamXml' to a 'Team', - -- we set the non-existent abbreviation to \"Nothing\". - -- - from_xml ScheduleChangesListingHomeTeamXml{..} = - Team { - team_id = home_team_id, - abbreviation = Nothing, - name = home_team_name } - - --- | Allow us to import ScheduleChangesListingHomeTeamXml directly. --- -instance XmlImport ScheduleChangesListingHomeTeamXml - - -- -- * Database stuff. -- @@ -351,8 +302,8 @@ instance DbImport Message where -- Now loop through the listings so that we can handle the teams -- one listing at a time. forM_ (xml_sc_listings sc) $ \listing -> do - away_team_id <- insert_xml_or_select (xml_away_team listing) - home_team_id <- insert_xml_or_select (xml_home_team listing) + away_team_id <- insert_or_select (vteam $ xml_away_team listing) + home_team_id <- insert_or_select (hteam $ xml_home_team listing) -- Finish constructing the xml -> db function. let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id @@ -374,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: @@ -398,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 |] @@ -413,30 +364,28 @@ mkPersist tsn_codegen_config [groundhog| -- | An (un)pickler for the \ elements. -- -pickle_away_team :: PU ScheduleChangesListingAwayTeamXml +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 = uncurry ScheduleChangesListingAwayTeamXml - to_tuple t = (away_team_id t, - away_team_name t) + from_tuple (x,y) = VTeam (Team x Nothing y) + to_tuple' (VTeam t) = (team_id t, name t) --- | An (un)pickler for the \ elements. +-- | An (un)pickler for the \ elements. -- -pickle_home_team :: PU ScheduleChangesListingHomeTeamXml +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 = uncurry ScheduleChangesListingHomeTeamXml - to_tuple t = (home_team_id t, - home_team_name t) + from_tuple (x,y) = HTeam (Team x Nothing y) + to_tuple' (HTeam t) = (team_id t, name t) -- | An (un)pickler for the \ elements. @@ -444,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. @@ -458,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) @@ -472,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. @@ -490,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'. @@ -504,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) @@ -513,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) @@ -574,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