X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScores.hs;h=aa847a837ee1d9dc68a47c01c10db2668506da43;hb=f0425854304197ab5ad47293b27b2e0b188cb844;hp=adbd5cd9badb0e1a9bdb035bc91f698cc76f17dc;hpb=14dc52a2e7d7712281aee2332f7342f67abe4306;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs index adbd5cd..aa847a8 100644 --- a/src/TSN/XML/Scores.hs +++ b/src/TSN/XML/Scores.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -26,19 +27,19 @@ import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) +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 ( @@ -60,13 +61,16 @@ import TSN.Codegen ( tsn_codegen_config ) 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.Team ( Team(..), HTeam(..), VTeam(..) ) +import TSN.Picklers ( xp_attr_option, xp_time_stamp ) +import TSN.Team ( + FromXmlFkTeams(..), + HTeam(..), + Team(..), + VTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, @@ -119,7 +123,13 @@ data Message = xml_season_type :: Maybe String, -- ^ We've seen an empty one xml_game :: ScoreGameXml, 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 representation of a 'Message' is a 'Score'. @@ -156,7 +166,7 @@ instance XmlImport Message -- data ScoreGameStatus = ScoreGameStatus { - db_status_numeral :: Int, + db_status_numeral :: Maybe Int, db_status_type :: Maybe String, -- ^ These are probably only one-character, -- long, but they all take the same -- amount of space in Postgres. @@ -191,7 +201,12 @@ data ScoreGameXml = xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. xml_status :: ScoreGameStatus, xml_notes :: Maybe String } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector ScoreGameXml instance ToDb ScoreGameXml where @@ -212,6 +227,10 @@ instance FromXmlFkTeams ScoreGameXml where -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three -- foreign keys: the parent message, and the away/home teams. -- + -- During conversion, we also get the pitchers out of the teams; + -- unfortunately this prevents us from making the conversion + -- generically. + -- from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} = ScoreGame { db_scores_id = fk, @@ -399,7 +418,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp11Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "game_id" (xpOption xpInt)) @@ -413,35 +432,29 @@ 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_game_id m, - xml_schedule_id m, - xml_tsnupdate m, - xml_category m, - xml_sport m, - xml_locations m, - xml_season_type m, - xml_game m, - xml_time_stamp m) - --- | Convert a 'ScoreGameStatus' to/from \. +-- | Convert a 'ScoreGameStatus' to/from \. The \"type\" +-- attribute can be either missing or empty, so we're really parsing +-- a double-Maybe here. We use the monad join to collapse it into +-- one. See also: the hteam/vteam picklers. -- pickle_status :: PU ScoreGameStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpAttr "numeral" xpInt) - (xpOption $ xpAttr "type" xpText) + xpWrap (from_tuple, to_tuple') $ + xpTriple (xpAttr "numeral" $ xp_attr_option) + (xpOption $ xpAttr "type" $ xpOption xpText) xpText where - from_tuple = uncurryN ScoreGameStatus - to_tuple ScoreGameStatus{..} = (db_status_numeral, - db_status_type, - db_status_text) + from_tuple (x,y,z) = ScoreGameStatus x (join y) z + to_tuple' ScoreGameStatus{..} = + (db_status_numeral, s, db_status_text) + where + s = case db_status_type of + Nothing -> Nothing + Just _ -> Just db_status_type -- | Convert a 'ScoreGameXml' to/from \. @@ -449,7 +462,7 @@ pickle_status = pickle_game :: PU ScoreGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp7Tuple pickle_vteam pickle_hteam (xpElem "vscore" xpInt) @@ -459,13 +472,6 @@ pickle_game = (xpOption $ xpElem "notes" xpText) where from_tuple = uncurryN ScoreGameXml - to_tuple ScoreGameXml{..} = (xml_vteam, - xml_hteam, - xml_away_team_score, - xml_home_team_score, - xml_time_r, - xml_status, - xml_notes) -- | Convert a 'VTeamXml' to/from \. The team names @@ -483,15 +489,15 @@ pickle_game = pickle_vteam :: PU VTeamXml pickle_vteam = xpElem "vteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "id" xpText) (xpOption $ xpAttr "pitcher" (xpOption xpText)) (xpOption xpText) -- Team name where 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) + 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 'HTeamXml' to/from \. Identical to 'pickle_vteam' @@ -510,14 +516,14 @@ pickle_vteam = pickle_hteam :: PU HTeamXml pickle_hteam = xpElem "hteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "id" xpText) (xpOption $ xpAttr "pitcher" (xpOption xpText)) (xpOption xpText) -- Team name where 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) + 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) @@ -549,7 +555,13 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/scoresxml-no-locations.xml", check "pickle composed with unpickle is the identity (pitcher, no type)" - "test/xml/scoresxml-pitcher-no-type.xml"] + "test/xml/scoresxml-pitcher-no-type.xml", + + check "pickle composed with unpickle is the identity (empty numeral)" + "test/xml/scoresxml-empty-numeral.xml", + + check "pickle composed with unpickle is the identity (empty type)" + "test/xml/scoresxml-empty-type.xml" ] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -567,7 +579,13 @@ test_unpickle_succeeds = testGroup "unpickle tests" "test/xml/scoresxml-no-locations.xml", check "unpickling succeeds (pitcher, no type)" - "test/xml/scoresxml-pitcher-no-type.xml" ] + "test/xml/scoresxml-pitcher-no-type.xml", + + check "unpickling succeeds (empty numeral)" + "test/xml/scoresxml-empty-numeral.xml", + + check "unpickling succeeds (empty type)" + "test/xml/scoresxml-empty-type.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -590,7 +608,15 @@ test_on_delete_cascade = testGroup "cascading delete tests" check "unpickling succeeds (pitcher, no type)" "test/xml/scoresxml-pitcher-no-type.xml" - 3 -- 2 teams, 1 location + 3, -- 2 teams, 1 location + + check "unpickling succeeds (empty numeral)" + "test/xml/scoresxml-empty-numeral.xml" + 3, -- 2 teams, 1 location + + check "unpickling succeeds (empty type)" + "test/xml/scoresxml-empty-type.xml" + 4 -- 2 teams, 2 locations ] where check desc path expected = testCase desc $ do @@ -601,7 +627,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" let d = undefined :: ScoreGame let e = undefined :: Score_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c