From d0c987bed61caac6bc087bbc054bbf0a4d5da552 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sun, 6 Jul 2014 15:39:40 -0400 Subject: [PATCH] Use the TSN.Team and TSN.Location representations in TSN.XML.Scores. Use a direct relationship between the scores games and their teams. Fix optional fields encountered while importing sample scoresxml. --- src/TSN/XML/Scores.hs | 312 ++++++++++++++++++++++-------------------- 1 file changed, 164 insertions(+), 148 deletions(-) diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs index d289258..8e9f65f 100644 --- a/src/TSN/XML/Scores.hs +++ b/src/TSN/XML/Scores.hs @@ -17,12 +17,11 @@ module TSN.XML.Scores ( -- * WARNING: these are private but exported to silence warnings Score_LocationConstructor(..), ScoreConstructor(..), - ScoreGameConstructor(..), - ScoreGameTeamConstructor(..), - ScoreGame_ScoreGameTeamConstructor(..) ) + ScoreGameConstructor(..) ) where -- System imports. +import Control.Monad ( join ) import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) @@ -30,7 +29,6 @@ import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, deleteAll, - insert, insert_, migrate, runMigration, @@ -39,7 +37,6 @@ import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.Generic ( runDbConn ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( - defaultCodegenConfig, groundhog, mkPersist ) import Test.Tasty ( TestTree, testGroup ) @@ -53,7 +50,6 @@ import Text.XML.HXT.Core ( xpInt, xpList, xpOption, - xpPair, xpPrim, xpText, xpTriple, @@ -65,11 +61,12 @@ import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) import TSN.Picklers ( xp_time_stamp ) -import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) +import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) +import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFk(..), + FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, @@ -82,9 +79,9 @@ dtd :: String dtd = "scoresxml.dtd" ---- ---- DB/XML Data types ---- +-- +-- * DB/XML Data types +-- -- * Score / Message @@ -97,12 +94,12 @@ data Score = Score { db_xml_file_id :: Int, db_heading :: String, - db_game_id :: Int, - db_schedule_id :: Int, + db_game_id :: Maybe Int, -- ^ We've seen an empty one + db_schedule_id :: Maybe Int, -- ^ We've seen an empty one db_tsnupdate :: Maybe Bool, db_category :: String, db_sport :: String, - db_season_type :: String, + db_season_type :: Maybe String, -- ^ We've seen an empty one db_time_stamp :: UTCTime } @@ -113,13 +110,13 @@ data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, - xml_game_id :: Int, - xml_schedule_id :: Int, + xml_game_id :: Maybe Int, -- ^ We've seen an empty one + xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one xml_tsnupdate :: Maybe Bool, xml_category :: String, xml_sport :: String, xml_locations :: [Location], - xml_season_type :: String, + xml_season_type :: Maybe String, -- ^ We've seen an empty one xml_game :: ScoreGameXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) @@ -160,9 +157,9 @@ instance XmlImport Message data ScoreGameStatus = ScoreGameStatus { db_status_numeral :: Int, - db_status_type :: String, -- ^ These are probably only one-character long, - -- but they all take the same amount of space - -- in Postgres. + db_status_type :: Maybe String, -- ^ These are probably only one-character, + -- long, but they all take the same + -- amount of space in Postgres. db_status_text :: String } deriving (Data, Eq, Show, Typeable) @@ -172,8 +169,12 @@ data ScoreGameStatus = data ScoreGame = ScoreGame { db_scores_id :: DefaultKey Score, - db_vscore :: Int, - db_hscore :: Int, + db_away_team_id :: DefaultKey Team, + db_home_team_id :: DefaultKey Team, + db_away_team_score :: Int, + db_home_team_score :: Int, + db_away_team_pitcher :: Maybe String, -- ^ Found in the child \ + db_home_team_pitcher :: Maybe String, -- ^ Found in the child \ db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. db_status :: ScoreGameStatus, db_notes :: Maybe String } @@ -183,22 +184,15 @@ data ScoreGame = -- data ScoreGameXml = ScoreGameXml { - xml_vteam :: ScoreGameVTeam, - xml_hteam :: ScoreGameHTeam, - xml_vscore :: Int, - xml_hscore :: Int, + xml_vteam :: VTeamXml, + xml_hteam :: HTeamXml, + xml_away_team_score :: Int, + xml_home_team_score :: Int, xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. xml_status :: ScoreGameStatus, xml_notes :: Maybe String } deriving (Eq, Show) --- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'. -vteam :: ScoreGameXml -> ScoreGameTeam -vteam g = let (ScoreGameVTeam t) = xml_vteam g in t - --- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'. -hteam :: ScoreGameXml -> ScoreGameTeam -hteam g = let (ScoreGameHTeam t) = xml_hteam g in t instance ToDb ScoreGameXml where -- | The database representation of a 'ScoreGameXml' is a @@ -214,12 +208,19 @@ instance Child ScoreGameXml where type Parent ScoreGameXml = Score -instance FromXmlFk ScoreGameXml where - from_xml_fk fk ScoreGameXml{..} = +instance FromXmlFkTeams ScoreGameXml where + -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three + -- foreign keys: the parent message, and the away/home teams. + -- + from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} = ScoreGame { db_scores_id = fk, - db_vscore = xml_vscore, - db_hscore = xml_hscore, + db_away_team_id = fk_away, + db_home_team_id = fk_home, + db_away_team_score = xml_away_team_score, + db_home_team_score = xml_home_team_score, + db_away_team_pitcher = (xml_vpitcher $ xml_vteam), + db_home_team_pitcher = (xml_hpitcher $ xml_hteam), db_time_r = xml_time_r, db_status = xml_status, db_notes = xml_notes } @@ -227,59 +228,77 @@ instance FromXmlFk ScoreGameXml where -- | This lets us import the database representation 'ScoreGameXml' -- directly. -- -instance XmlImportFk ScoreGameXml +instance XmlImportFkTeams ScoreGameXml + --- * ScoreGameTeam +-- * Score_Location --- | A team that appears in a 'ScoreGame'. This is meant to represent --- both home and away teams. +-- | Join each 'Score' with its 'Location's. Database-only. We use a +-- join table because the locations are kept unique but there are +-- multiple locations per 'Score'. -- -data ScoreGameTeam = - ScoreGameTeam { - team_id :: String, - team_name :: String } - deriving (Eq, Show) +data Score_Location = + Score_Location + (DefaultKey Score) + (DefaultKey Location) + --- | A wrapper around 'ScoreGameTeam' that lets us distinguish between --- home and away teams. See also 'ScoreGameHTeam'. +-- * HTeamXml / VTeamXml + +-- | XML Representation of a home team. This document type is unusual +-- in that the \ elements can have a pitcher attribute +-- attached to them. We still want to maintain the underlying 'Team' +-- representation, so we say that a home team is a 'Team' and +-- (maybe) a pitcher. -- -newtype ScoreGameVTeam = - ScoreGameVTeam ScoreGameTeam +data HTeamXml = + HTeamXml { + xml_ht :: HTeam, + xml_hpitcher :: Maybe String } deriving (Eq, Show) +instance ToDb HTeamXml where + -- | The database analogue of a 'HTeamXml' is its 'Team'. + type Db HTeamXml = Team + +instance FromXml HTeamXml where + -- | The conversion from XML to database is simply the 'Team' accessor. + -- + from_xml = hteam . xml_ht --- | A wrapper around 'ScoreGameTeam' that lets us distinguish between --- home and away teams. See also 'ScoreGameVTeam'. +-- | Allow import of the XML representation directly, without +-- requiring a manual conversion to the database type first. -- -newtype ScoreGameHTeam = - ScoreGameHTeam ScoreGameTeam - deriving (Eq, Show) +instance XmlImport HTeamXml --- * ScoreGame_ScoreGameTeam --- | Join a 'ScoreGame' with its home/away teams. Database-only. We --- use a join table because the teams are kept unique. The first --- argument is the game id, the second argument is the visiting team --- (vteam) id, and the last argument is the home team (hteam) id. +-- | XML Representation of an away team. This document type is unusual +-- in that the \ elements can have a pitcher attribute +-- attached to them. We still want to maintain the underlying 'Team' +-- representation, so we say that an away team is a 'Team' and +-- (maybe) a pitcher. -- -data ScoreGame_ScoreGameTeam = - ScoreGame_ScoreGameTeam - (DefaultKey ScoreGame) -- game id - (DefaultKey ScoreGameTeam) -- vteam id - (DefaultKey ScoreGameTeam) -- hteam id +data VTeamXml = + VTeamXml { + xml_vt :: VTeam, + xml_vpitcher :: Maybe String } + deriving (Eq, Show) +instance ToDb VTeamXml where + -- | The database analogue of a 'VTeamXml' is its 'Team'. + type Db VTeamXml = Team --- * Score_Location +instance FromXml VTeamXml where + -- | The conversion from XML to database is simply the 'Team' accessor. + -- + from_xml = vteam . xml_vt --- | Join each 'Score' with its 'Location's. Database-only. We --- use a join table because the locations are kept unique. +-- | Allow import of the XML representation directly, without +-- requiring a manual conversion to the database type first. -- -data Score_Location = - Score_Location - (DefaultKey Score) - (DefaultKey Location) +instance XmlImport VTeamXml @@ -287,10 +306,9 @@ instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Location) + migrate (undefined :: Team) migrate (undefined :: Score) migrate (undefined :: ScoreGame) - migrate (undefined :: ScoreGameTeam) - migrate (undefined :: ScoreGame_ScoreGameTeam) migrate (undefined :: Score_Location) dbimport m = do @@ -307,34 +325,16 @@ instance DbImport Message where -- and insert them. mapM_ (insert_ . Score_Location msg_id) location_ids - -- Insert the game and its hteam/vteam, noting the IDs. - game_id <- insert_xml_fk msg_id (xml_game m) - vteam_id <- insert (vteam $ xml_game m) - hteam_id <- insert (hteam $ xml_game m) + -- Insert the hteam/vteams, noting the IDs. + vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m) + hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m) - -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the - -- aforementioned game to its hteam/vteam. - insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id + -- Now use those along with the msg_id to construct the game. + insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m) return ImportSucceeded --- These types don't have special XML representations or field name --- collisions so we use the defaultCodegenConfig and give their --- fields nice simple names. -mkPersist defaultCodegenConfig [groundhog| -- entity: ScoreGameTeam - dbName: scores_games_teams - constructors: - - name: ScoreGameTeam - uniques: - - name: unique_scores_games_team - type: constraint - fields: [team_id] - -|] - - -- These types have fields with e.g. db_ and xml_ prefixes, so we -- use our own codegen to peel those off before naming the columns. @@ -358,6 +358,7 @@ mkPersist tsn_codegen_config [groundhog| - name: db_status_text dbName: status_text + - entity: ScoreGame dbName: scores_games constructors: @@ -372,23 +373,6 @@ mkPersist tsn_codegen_config [groundhog| - { name: status_type, dbName: status_type } - { name: status_text, dbName: status_text } -- entity: ScoreGame_ScoreGameTeam - dbName: scores_games__scores_games_teams - constructors: - - name: ScoreGame_ScoreGameTeam - fields: - - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName - dbName: scores_games_id - reference: - onDelete: cascade - - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName - dbName: scores_games_teams_vteam_id - reference: - onDelete: cascade - - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName - dbName: scores_games_teams_hteam_id - reference: - onDelete: cascade - entity: Score_Location dbName: scores__locations @@ -418,13 +402,13 @@ pickle_message = xpWrap (from_tuple, to_tuple) $ xp11Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) - (xpElem "game_id" xpInt) - (xpElem "schedule_id" xpInt) + (xpElem "game_id" (xpOption xpInt)) + (xpElem "schedule_id" (xpOption xpInt)) (xpOption $ xpElem "tsnupdate" xpPrim) (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_location) - (xpElem "seasontype" xpText) + (xpElem "seasontype" (xpOption xpText)) pickle_game (xpElem "time_stamp" xp_time_stamp) where @@ -451,7 +435,7 @@ pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "numeral" xpInt) - (xpAttr "type" xpText) + (xpOption $ xpAttr "type" xpText) xpText where from_tuple = uncurryN ScoreGameStatus @@ -477,44 +461,69 @@ pickle_game = from_tuple = uncurryN ScoreGameXml to_tuple ScoreGameXml{..} = (xml_vteam, xml_hteam, - xml_vscore, - xml_hscore, + xml_away_team_score, + xml_home_team_score, xml_time_r, xml_status, xml_notes) --- | Convert a 'ScoreGameVTeam' to/from \. +-- | Convert a 'VTeamXml' to/from \. The team names +-- always seem to be present here, but in the shared representation, +-- they're optional (because they show up blank elsewhere). So, we +-- pretend they're optional. -- -pickle_vteam :: PU ScoreGameVTeam +-- The \"pitcher\" attribute is a little bit funny. Usually, when +-- there's no pitcher, the attribute itself is missing. But once in +-- a blue moon, it will be present with no text. We want to treat +-- both cases the same, so what we really parse is a Maybe (Maybe +-- String), and then use the monad 'join' to collapse it into a single +-- Maybe. +-- +pickle_vteam :: PU VTeamXml pickle_vteam = xpElem "vteam" $ xpWrap (from_tuple, to_tuple) $ - xpPair (xpAttr "id" xpText) - xpText + xpTriple (xpAttr "id" xpText) + (xpOption $ xpAttr "pitcher" (xpOption xpText)) + (xpOption xpText) -- Team name where - from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam - to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name) + from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y) + + to_tuple (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t) + to_tuple (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t) --- | Convert a 'ScoreGameVTeam' to/from \. Identical to --- 'pickle_vteam' modulo the \"h\" and \"v\". +-- | Convert a 'HTeamXml' to/from \. Identical to 'pickle_vteam' +-- modulo the \"h\" and \"v\". The team names always seem to be +-- present here, but in the shared representation, they're optional +-- (because they show up blank elsewhere). So, we pretend they're +-- optional. +-- +-- The \"pitcher\" attribute is a little bit funny. Usually, when +-- there's no pitcher, the attribute itself is missing. But once in +-- a blue moon, it will be present with no text. We want to treat +-- both cases the same, so what we really parse is a Maybe (Maybe +-- String), and then use the monad 'join' to collapse it into a single +-- Maybe. -- -pickle_hteam :: PU ScoreGameHTeam +pickle_hteam :: PU HTeamXml pickle_hteam = xpElem "hteam" $ xpWrap (from_tuple, to_tuple) $ - xpPair (xpAttr "id" xpText) - xpText + xpTriple (xpAttr "id" xpText) + (xpOption $ xpAttr "pitcher" (xpOption xpText)) + (xpOption xpText) -- Team name where - from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam - to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name) + from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y) + to_tuple (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t) + to_tuple (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t) ---- ---- Tasty tests ---- +-- +-- * Tasty tests +-- -- | A list of all tests for this module. -- @@ -537,7 +546,10 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/scoresxml.xml", check "pickle composed with unpickle is the identity (no locations)" - "test/xml/scoresxml-no-locations.xml" ] + "test/xml/scoresxml-no-locations.xml", + + check "pickle composed with unpickle is the identity (pitcher, no type)" + "test/xml/scoresxml-pitcher-no-type.xml"] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -552,7 +564,10 @@ test_unpickle_succeeds = testGroup "unpickle tests" "test/xml/scoresxml.xml", check "unpickling succeeds (no locations)" - "test/xml/scoresxml-no-locations.xml" ] + "test/xml/scoresxml-no-locations.xml", + + check "unpickling succeeds (pitcher, no type)" + "test/xml/scoresxml-pitcher-no-type.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -571,17 +586,20 @@ test_on_delete_cascade = testGroup "cascading delete tests" check "unpickling succeeds (no locations)" "test/xml/scoresxml-no-locations.xml" - 2 -- 2 teams, 0 locations + 2, -- 2 teams, 0 locations + + check "unpickling succeeds (pitcher, no type)" + "test/xml/scoresxml-pitcher-no-type.xml" + 3 -- 2 teams, 1 location ] where check desc path expected = testCase desc $ do score <- unsafe_unpickle path pickle_message let a = undefined :: Location - let b = undefined :: Score - let c = undefined :: ScoreGame - let d = undefined :: ScoreGameTeam - let e = undefined :: ScoreGame_ScoreGameTeam - let f = undefined :: Score_Location + let b = undefined :: Team + let c = undefined :: Score + let d = undefined :: ScoreGame + let e = undefined :: Score_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigration silentMigrationLogger $ do migrate a @@ -589,16 +607,14 @@ test_on_delete_cascade = testGroup "cascading delete tests" migrate c migrate d migrate e - migrate f _ <- dbimport score -- No idea how 'delete' works, so do this instead. - deleteAll b + deleteAll c count_a <- countAll a count_b <- countAll b count_c <- countAll c count_d <- countAll d count_e <- countAll e - count_f <- countAll f return $ sum [count_a, count_b, count_c, - count_d, count_e, count_f ] + count_d, count_e ] actual @?= expected -- 2.43.2