X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScheduleChanges.hs;h=4d7730d5d3efb2625bfb4d678aed33e90d5eb747;hb=5460d19a75535d22579ae3708acf5c39998f49d0;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..4d7730d 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 #-} @@ -38,6 +39,7 @@ 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 +56,12 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. -import TSN.Codegen ( - tsn_codegen_config ) +import Generics ( Generic(..), to_tuple ) +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 +107,12 @@ data ScheduleChangeXml = ScheduleChangeXml { xml_sc_sport :: String, xml_sc_listings :: [ScheduleChangesListingXml] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic ScheduleChangeXml -- | XML representation of a 'ScheduleChanges'. It has the same @@ -118,9 +126,13 @@ data Message = xml_sport :: String, xml_schedule_changes :: [ScheduleChangeXml], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) +-- | For 'Generics.to_tuple'. +-- +instance Generic Message + instance ToDb Message where -- | The database analogue of a 'Message' is a 'ScheduleChanges'. @@ -164,6 +176,7 @@ data ScheduleChangesListingStatus = deriving (Eq, Show) + -- | Database representation of a \ contained within a -- \, within a \. During the transition -- to the database, we drop the intermediate \ @@ -200,13 +213,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 'Generics.to_tuple'. +-- +instance Generic ScheduleChangesListingXml instance ToDb ScheduleChangesListingXml where @@ -256,77 +274,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 +298,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 +321,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: @@ -413,30 +360,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,14 +389,15 @@ pickle_home_team = pickle_status :: PU ScheduleChangesListingStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "numeral" xpInt) (xpOption xpText) where from_tuple = uncurry ScheduleChangesListingStatus - to_tuple s = (db_status_numeral s, - db_status s) + -- Avouid unused field warnings. + to_tuple' ScheduleChangesListingStatus{..} = + (db_status_numeral, db_status) -- | An (un)pickler for the \ elements. -- @@ -472,17 +418,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. @@ -495,8 +430,6 @@ pickle_schedule_change = (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'. @@ -513,12 +446,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)