X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScheduleChanges.hs;h=4d7730d5d3efb2625bfb4d678aed33e90d5eb747;hb=5460d19a75535d22579ae3708acf5c39998f49d0;hp=b3d134e9ad873ad8ed7816491fa2cca8ce5710ab;hpb=a9a8667246a544705d85698ec967437e4770be2c;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/ScheduleChanges.hs b/src/TSN/XML/ScheduleChanges.hs index b3d134e..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 #-} @@ -18,8 +19,7 @@ module TSN.XML.ScheduleChanges ( schedule_changes_tests, -- * WARNING: these are private but exported to silence warnings ScheduleChangesConstructor(..), - ScheduleChangesListingConstructor(..), - ScheduleChangesListing_TeamConstructor(..) ) + ScheduleChangesListingConstructor(..) ) where -- System imports. @@ -29,7 +29,6 @@ import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( countAll, deleteAll, - insert, insert_, migrate, runMigration, @@ -40,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 ( @@ -56,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_time, xp_time_stamp ) -import TSN.Team ( Team(..) ) +import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) +import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), @@ -71,7 +72,8 @@ import Xml ( --- | The DTD to which this module corresponds. Used to invoke dbimport. +-- | The DTD to which this module corresponds. Used to invoke +-- 'dbimport'. -- dtd :: String dtd = "Schedule_Changes_XML.dtd" @@ -105,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 @@ -119,8 +126,12 @@ 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 @@ -161,17 +172,17 @@ instance XmlImport Message data ScheduleChangesListingStatus = ScheduleChangesListingStatus { db_status_numeral :: Int, - db_status :: Maybe String } + db_status :: Maybe String } -- Yes, they can be empty. deriving (Eq, Show) + -- | Database representation of a \ contained within a -- \, within a \. During the transition -- to the database, we drop the intermediate \ -- leaving the listing keyed to the 'ScheduleChanges' itself. -- --- The home/away teams reuse the 'Team' representation and are --- connected via 'ScheduleChangesListing_Team'. +-- The home/away teams reuse the 'Team' representation. -- -- The sport name (sc_sport) is pulled out of the containing -- \ and embedded into the listings themselves. @@ -179,11 +190,13 @@ data ScheduleChangesListingStatus = data ScheduleChangesListing = ScheduleChangesListing { db_schedule_changes_id :: DefaultKey ScheduleChanges, + db_away_team_id :: DefaultKey Team, + db_home_team_id ::DefaultKey Team, db_type :: String, db_sc_sport :: String, db_schedule_id :: Int, db_game_time :: UTCTime, - db_location :: String, + db_location :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_listing_status :: ScheduleChangesListingStatus, @@ -198,15 +211,20 @@ data ScheduleChangesListingXml = xml_type :: String, xml_schedule_id :: Int, xml_game_date :: UTCTime, - xml_game_time :: UTCTime, - xml_location :: String, - xml_away_team :: ScheduleChangesListingAwayTeamXml, - xml_home_team :: ScheduleChangesListingHomeTeamXml, + xml_game_time :: Maybe UTCTime, + xml_location :: Maybe String, + 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 @@ -218,17 +236,25 @@ instance ToDb ScheduleChangesListingXml where -- | We don't make 'ScheduleChangesListingXml' an instance of --- 'FromXmlFk' or 'XmlImportFk' because it needs some additional --- information, namely the sport name from its containing --- \. +-- 'FromXmlFkTeams' because it needs some additional information, +-- namely the sport name from its containing \. +-- But essentially we'll need to do the same thing as +-- 'from_xml_fk_teams'. This function accomplishes the same thing, +-- with the addition of the sport that's passed in. +-- +-- The parameter order is for convenience later (see dbimport). -- from_xml_fk_sport :: (DefaultKey ScheduleChanges) - -> String + -> String -- ^ The sport from our containing schedule change + -> (DefaultKey Team) -- ^ Away team FK + -> (DefaultKey Team) -- ^ Home team FK -> ScheduleChangesListingXml -> ScheduleChangesListing -from_xml_fk_sport fk sport ScheduleChangesListingXml{..} = +from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} = ScheduleChangesListing { db_schedule_changes_id = fk, + db_away_team_id = fk_away, + db_home_team_id = fk_home, db_type = xml_type, db_sc_sport = sport, db_schedule_id = xml_schedule_id, @@ -238,90 +264,14 @@ from_xml_fk_sport fk sport ScheduleChangesListingXml{..} = db_hscore = xml_hscore, db_listing_status = xml_listing_status, db_notes = xml_notes } - where -- | Make the database \"game time\" from the XML -- date/time. Simply take the day part from one and the time -- from the other. -- - make_game_time d t = UTCTime (utctDay d) (utctDayTime t) - - - --- * ScheduleChangesListing_Team - --- | Database mapping between listings and their home/away teams. --- -data ScheduleChangesListing_Team = - ScheduleChangesListing_Team { - sclt_schedule_changes_listings_id :: DefaultKey ScheduleChangesListing, - sclt_away_team_id :: DefaultKey Team, - sclt_home_team_id :: DefaultKey Team } - - --- * 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 :: 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\" and wrap - -- the always-present name field in \"Just\". - -- - from_xml ScheduleChangesListingAwayTeamXml{..} = - Team { - team_id = away_team_id, - team_abbreviation = Nothing, - team_name = Just 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 :: 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\" and wrap - -- the always-present name field in \"Just\". - -- - from_xml ScheduleChangesListingHomeTeamXml{..} = - Team { - team_id = home_team_id, - team_abbreviation = Nothing, - team_name = Just home_team_name } + make_game_time d Nothing = d + make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t) --- | Allow us to import ScheduleChangesListingHomeTeamXml directly. -instance XmlImport ScheduleChangesListingHomeTeamXml -- @@ -334,7 +284,6 @@ instance DbImport Message where migrate (undefined :: Team) migrate (undefined :: ScheduleChanges) migrate (undefined :: ScheduleChangesListing) - migrate (undefined :: ScheduleChangesListing_Team) dbimport m = do -- Insert the top-level message @@ -343,25 +292,20 @@ instance DbImport Message where -- Now loop through the message's schedule changes forM_ (xml_schedule_changes m) $ \sc -> do -- Construct the function that will turn an XML listing into a DB one. + -- This is only partially applied without the away/home team IDs. let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc) -- Now loop through the listings so that we can handle the teams -- one listing at a time. forM_ (xml_sc_listings sc) $ \listing -> do - let db_listing = listing_xml_to_db listing - listing_id <- insert db_listing + away_team_id <- insert_or_select (vteam $ xml_away_team listing) + home_team_id <- insert_or_select (hteam $ xml_home_team listing) - away_team_id <- insert_xml_or_select (xml_away_team listing) - home_team_id <- insert_xml_or_select (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 + let db_listing = listing_xml_to_db' listing - -- Insert a record into schedule_changes_listings__teams - -- mapping the home/away teams to this game. Use the full - -- record syntax because the types would let us mix up the - -- home/away teams. - insert_ ScheduleChangesListing_Team { - sclt_schedule_changes_listings_id = listing_id, - sclt_away_team_id = away_team_id, - sclt_home_team_id = home_team_id } + insert_ db_listing return ImportSucceeded @@ -377,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. - entity: ScheduleChangesListing dbName: schedule_changes_listings constructors: @@ -386,6 +330,18 @@ mkPersist tsn_codegen_config [groundhog| - name: db_schedule_changes_id reference: onDelete: cascade + - name: db_away_team_id + reference: + onDelete: cascade + - name: db_home_team_id + reference: + onDelete: cascade + - name: db_sc_sport + dbName: sport + - name: db_listing_status + embeddedType: + - {name: status_numeral, dbName: status_numeral} + - {name: status, dbName: status} - embedded: ScheduleChangesListingStatus fields: @@ -394,21 +350,6 @@ mkPersist tsn_codegen_config [groundhog| - name: db_status dbName: status - -- entity: ScheduleChangesListing_Team - dbName: schedule_changes_listings__teams - constructors: - - name: ScheduleChangesListing_Team - fields: - - name: sclt_schedule_changes_listings_id - reference: - onDelete: cascade - - name: sclt_away_team_id - reference: - onDelete: cascade - - name: sclt_home_team_id - reference: - onDelete: cascade |] @@ -417,41 +358,49 @@ mkPersist tsn_codegen_config [groundhog| -- * Pickling -- -pickle_away_team :: PU ScheduleChangesListingAwayTeamXml +-- | An (un)pickler for the \ elements. +-- +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) - 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) -pickle_home_team :: PU ScheduleChangesListingHomeTeamXml + +-- | An (un)pickler for the \ elements. +-- +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) - 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. +-- 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. +-- pickle_listing :: PU ScheduleChangesListingXml pickle_listing = xpElem "SC_Listing" $ @@ -459,8 +408,8 @@ pickle_listing = xp11Tuple (xpAttr "type" xpText) (xpElem "Schedule_ID" xpInt) (xpElem "Game_Date" xp_date_padded) - (xpElem "Game_Time" xp_time) - (xpElem "Location" xpText) + (xpElem "Game_Time" xp_tba_time) + (xpElem "Location" (xpOption xpText)) pickle_away_team pickle_home_team (xpElem "vscore" xpInt) @@ -469,18 +418,10 @@ 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. +-- pickle_schedule_change :: PU ScheduleChangeXml pickle_schedule_change = xpElem "Schedule_Change" $ @@ -489,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'. @@ -507,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) @@ -566,21 +499,18 @@ test_on_delete_cascade = let a = undefined :: Team let b = undefined :: ScheduleChanges let c = undefined :: ScheduleChangesListing - let d = undefined :: ScheduleChangesListing_Team actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigration silentMigrationLogger $ do migrate a migrate b migrate c - migrate d _ <- dbimport results deleteAll b count_a <- countAll a count_b <- countAll b count_c <- countAll c - count_d <- countAll d - return $ sum [count_a, count_b, count_c, count_d] + return $ sum [count_a, count_b, count_c] let expected = 12 -- There are 16 team elements, but 4 are dupes, -- so 12 unique teams should be left over. actual @?= expected