X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FScores.hs;h=aa847a837ee1d9dc68a47c01c10db2668506da43;hb=f0425854304197ab5ad47293b27b2e0b188cb844;hp=8bfb19669f501d99925548522b8247c4bdfb1be6;hpb=129932131b221dae28a4200e5c62e60c9a3f8145;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs index 8bfb196..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,7 +61,7 @@ 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.Picklers ( xp_attr_option, xp_time_stamp ) import TSN.Team ( FromXmlFkTeams(..), HTeam(..), @@ -122,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'. @@ -194,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 @@ -215,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, @@ -402,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)) @@ -416,18 +432,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_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) - @@ -439,18 +443,18 @@ pickle_message = pickle_status :: PU ScoreGameStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpAttr "numeral" $ xpOption xpInt) + xpWrap (from_tuple, to_tuple') $ + xpTriple (xpAttr "numeral" $ xp_attr_option) (xpOption $ xpAttr "type" $ xpOption xpText) xpText where from_tuple (x,y,z) = ScoreGameStatus x (join y) z - to_tuple ScoreGameStatus{..} = + to_tuple' ScoreGameStatus{..} = (db_status_numeral, s, db_status_text) where - s = case db_status_type of - Nothing -> Nothing - Just _ -> Just db_status_type + s = case db_status_type of + Nothing -> Nothing + Just _ -> Just db_status_type -- | Convert a 'ScoreGameXml' to/from \. @@ -458,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) @@ -468,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 @@ -492,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' @@ -519,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) @@ -630,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