1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
10 -- contains a single \<game\> and some \<location\>s.
12 module TSN.XML.Scores (
17 -- * WARNING: these are private but exported to silence warnings
18 Score_LocationConstructor(..),
20 ScoreGameConstructor(..) )
24 import Control.Monad ( join )
25 import Data.Data ( Data )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Data.Typeable ( Typeable )
29 import Database.Groundhog (
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
59 import TSN.Codegen ( tsn_codegen_config )
60 import TSN.Database ( insert_or_select )
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Location ( Location(..), pickle_location )
63 import TSN.Picklers ( xp_time_stamp )
64 import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
65 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
83 -- * DB/XML Data types
89 -- | Database representation of a 'Message'. It lacks the
90 -- 'xml_locations' and 'xml_game' which are related via foreign keys
95 db_xml_file_id :: Int,
97 db_game_id :: Maybe Int, -- ^ We've seen an empty one
98 db_schedule_id :: Maybe Int, -- ^ We've seen an empty one
99 db_tsnupdate :: Maybe Bool,
100 db_category :: String,
102 db_season_type :: Maybe String, -- ^ We've seen an empty one
103 db_time_stamp :: UTCTime }
106 -- | XML representation of the top level \<message\> element (i.e. a
111 xml_xml_file_id :: Int,
112 xml_heading :: String,
113 xml_game_id :: Maybe Int, -- ^ We've seen an empty one
114 xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one
115 xml_tsnupdate :: Maybe Bool,
116 xml_category :: String,
118 xml_locations :: [Location],
119 xml_season_type :: Maybe String, -- ^ We've seen an empty one
120 xml_game :: ScoreGameXml,
121 xml_time_stamp :: UTCTime }
124 instance ToDb Message where
125 -- | The database representation of a 'Message' is a 'Score'.
126 type Db Message = Score
128 instance FromXml Message where
129 -- | When converting from the XML representation to the database
130 -- one, we drop the list of locations which will be foreign-keyed to
132 from_xml Message{..} =
134 db_xml_file_id = xml_xml_file_id,
135 db_heading = xml_heading,
136 db_game_id = xml_game_id,
137 db_schedule_id = xml_schedule_id,
138 db_tsnupdate = xml_tsnupdate,
139 db_category = xml_category,
140 db_sport = xml_sport,
141 db_season_type = xml_season_type,
142 db_time_stamp = xml_time_stamp }
145 -- | This lets us insert the XML representation 'Message' directly.
147 instance XmlImport Message
150 -- * ScoreGame / ScoreGameXml
152 -- | This is an embedded field within 'SportsGame'. Each \<status\>
153 -- element has two attributes, a numeral and a type. It also
154 -- contains some text. Rather than put these in their own table, we
155 -- include them in the parent 'SportsGame'.
157 data ScoreGameStatus =
159 db_status_numeral :: Int,
160 db_status_type :: Maybe String, -- ^ These are probably only one-character,
161 -- long, but they all take the same
162 -- amount of space in Postgres.
163 db_status_text :: String }
164 deriving (Data, Eq, Show, Typeable)
167 -- | Database representation of a game.
171 db_scores_id :: DefaultKey Score,
172 db_away_team_id :: DefaultKey Team,
173 db_home_team_id :: DefaultKey Team,
174 db_away_team_score :: Int,
175 db_home_team_score :: Int,
176 db_away_team_pitcher :: Maybe String, -- ^ Found in the child \<vteam\>
177 db_home_team_pitcher :: Maybe String, -- ^ Found in the child \<hteam\>
178 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
179 db_status :: ScoreGameStatus,
180 db_notes :: Maybe String }
183 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
187 xml_vteam :: VTeamXml,
188 xml_hteam :: HTeamXml,
189 xml_away_team_score :: Int,
190 xml_home_team_score :: Int,
191 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
192 xml_status :: ScoreGameStatus,
193 xml_notes :: Maybe String }
197 instance ToDb ScoreGameXml where
198 -- | The database representation of a 'ScoreGameXml' is a
201 type Db ScoreGameXml = ScoreGame
204 instance Child ScoreGameXml where
205 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
208 type Parent ScoreGameXml = Score
211 instance FromXmlFkTeams ScoreGameXml where
212 -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three
213 -- foreign keys: the parent message, and the away/home teams.
215 from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
218 db_away_team_id = fk_away,
219 db_home_team_id = fk_home,
220 db_away_team_score = xml_away_team_score,
221 db_home_team_score = xml_home_team_score,
222 db_away_team_pitcher = xml_vpitcher xml_vteam,
223 db_home_team_pitcher = xml_hpitcher xml_hteam,
224 db_time_r = xml_time_r,
225 db_status = xml_status,
226 db_notes = xml_notes }
228 -- | This lets us import the database representation 'ScoreGameXml'
231 instance XmlImportFkTeams ScoreGameXml
237 -- | Join each 'Score' with its 'Location's. Database-only. We use a
238 -- join table because the locations are kept unique but there are
239 -- multiple locations per 'Score'.
241 data Score_Location =
244 (DefaultKey Location)
247 -- * HTeamXml / VTeamXml
249 -- | XML Representation of a home team. This document type is unusual
250 -- in that the \<hteam\> elements can have a pitcher attribute
251 -- attached to them. We still want to maintain the underlying 'Team'
252 -- representation, so we say that a home team is a 'Team' and
253 -- (maybe) a pitcher.
258 xml_hpitcher :: Maybe String }
261 instance ToDb HTeamXml where
262 -- | The database analogue of a 'HTeamXml' is its 'Team'.
263 type Db HTeamXml = Team
265 instance FromXml HTeamXml where
266 -- | The conversion from XML to database is simply the 'Team' accessor.
268 from_xml = hteam . xml_ht
270 -- | Allow import of the XML representation directly, without
271 -- requiring a manual conversion to the database type first.
273 instance XmlImport HTeamXml
277 -- | XML Representation of an away team. This document type is unusual
278 -- in that the \<hteam\> elements can have a pitcher attribute
279 -- attached to them. We still want to maintain the underlying 'Team'
280 -- representation, so we say that an away team is a 'Team' and
281 -- (maybe) a pitcher.
286 xml_vpitcher :: Maybe String }
289 instance ToDb VTeamXml where
290 -- | The database analogue of a 'VTeamXml' is its 'Team'.
291 type Db VTeamXml = Team
293 instance FromXml VTeamXml where
294 -- | The conversion from XML to database is simply the 'Team' accessor.
296 from_xml = vteam . xml_vt
298 -- | Allow import of the XML representation directly, without
299 -- requiring a manual conversion to the database type first.
301 instance XmlImport VTeamXml
305 instance DbImport Message where
308 migrate (undefined :: Location)
309 migrate (undefined :: Team)
310 migrate (undefined :: Score)
311 migrate (undefined :: ScoreGame)
312 migrate (undefined :: Score_Location)
315 -- Insert the message and get its ID.
316 msg_id <- insert_xml m
318 -- Insert all of the locations contained within this message and
319 -- collect their IDs in a list. We use insert_or_select because
320 -- most of the locations will already exist, and we just want to
321 -- get the ID of the existing location when there's a collision.
322 location_ids <- mapM insert_or_select (xml_locations m)
324 -- Now use that list to construct 'Score_ScoreLocation' objects,
326 mapM_ (insert_ . Score_Location msg_id) location_ids
328 -- Insert the hteam/vteams, noting the IDs.
329 vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
330 hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)
332 -- Now use those along with the msg_id to construct the game.
333 insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)
335 return ImportSucceeded
339 -- These types have fields with e.g. db_ and xml_ prefixes, so we
340 -- use our own codegen to peel those off before naming the columns.
341 mkPersist tsn_codegen_config [groundhog|
347 - name: unique_scores
349 # Prevent multiple imports of the same message.
350 fields: [db_xml_file_id]
352 - embedded: ScoreGameStatus
354 - name: db_status_numeral
355 dbName: status_numeral
356 - name: db_status_type
358 - name: db_status_text
372 - { name: status_numeral, dbName: status_numeral }
373 - { name: status_type, dbName: status_type }
374 - { name: status_text, dbName: status_text }
377 - entity: Score_Location
378 dbName: scores__locations
380 - name: Score_Location
382 - name: score_Location0 # Default created by mkNormalFieldName
386 - name: score_Location1 # Default created by mkNormalFieldName
397 -- | Convert a 'Message' to/from \<message\>.
399 pickle_message :: PU Message
402 xpWrap (from_tuple, to_tuple) $
403 xp11Tuple (xpElem "XML_File_ID" xpInt)
404 (xpElem "heading" xpText)
405 (xpElem "game_id" (xpOption xpInt))
406 (xpElem "schedule_id" (xpOption xpInt))
407 (xpOption $ xpElem "tsnupdate" xpPrim)
408 (xpElem "category" xpText)
409 (xpElem "sport" xpText)
410 (xpList pickle_location)
411 (xpElem "seasontype" (xpOption xpText))
413 (xpElem "time_stamp" xp_time_stamp)
415 from_tuple = uncurryN Message
416 to_tuple m = (xml_xml_file_id m,
431 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
433 pickle_status :: PU ScoreGameStatus
436 xpWrap (from_tuple, to_tuple) $
437 xpTriple (xpAttr "numeral" xpInt)
438 (xpOption $ xpAttr "type" xpText)
441 from_tuple = uncurryN ScoreGameStatus
442 to_tuple ScoreGameStatus{..} = (db_status_numeral,
447 -- | Convert a 'ScoreGameXml' to/from \<game\>.
449 pickle_game :: PU ScoreGameXml
452 xpWrap (from_tuple, to_tuple) $
453 xp7Tuple pickle_vteam
455 (xpElem "vscore" xpInt)
456 (xpElem "hscore" xpInt)
457 (xpOption $ xpElem "time_r" xpText)
459 (xpOption $ xpElem "notes" xpText)
461 from_tuple = uncurryN ScoreGameXml
462 to_tuple ScoreGameXml{..} = (xml_vteam,
471 -- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
472 -- always seem to be present here, but in the shared representation,
473 -- they're optional (because they show up blank elsewhere). So, we
474 -- pretend they're optional.
476 -- The \"pitcher\" attribute is a little bit funny. Usually, when
477 -- there's no pitcher, the attribute itself is missing. But once in
478 -- a blue moon, it will be present with no text. We want to treat
479 -- both cases the same, so what we really parse is a Maybe (Maybe
480 -- String), and then use the monad 'join' to collapse it into a single
483 pickle_vteam :: PU VTeamXml
486 xpWrap (from_tuple, to_tuple) $
487 xpTriple (xpAttr "id" xpText)
488 (xpOption $ xpAttr "pitcher" (xpOption xpText))
489 (xpOption xpText) -- Team name
491 from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)
493 to_tuple (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
494 to_tuple (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
497 -- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
498 -- modulo the \"h\" and \"v\". The team names always seem to be
499 -- present here, but in the shared representation, they're optional
500 -- (because they show up blank elsewhere). So, we pretend they're
503 -- The \"pitcher\" attribute is a little bit funny. Usually, when
504 -- there's no pitcher, the attribute itself is missing. But once in
505 -- a blue moon, it will be present with no text. We want to treat
506 -- both cases the same, so what we really parse is a Maybe (Maybe
507 -- String), and then use the monad 'join' to collapse it into a single
510 pickle_hteam :: PU HTeamXml
513 xpWrap (from_tuple, to_tuple) $
514 xpTriple (xpAttr "id" xpText)
515 (xpOption $ xpAttr "pitcher" (xpOption xpText))
516 (xpOption xpText) -- Team name
518 from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
519 to_tuple (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t)
520 to_tuple (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t)
528 -- | A list of all tests for this module.
530 scores_tests :: TestTree
534 [ test_on_delete_cascade,
535 test_pickle_of_unpickle_is_identity,
536 test_unpickle_succeeds ]
539 -- | If we unpickle something and then pickle it, we should wind up
540 -- with the same thing we started with. WARNING: success of this
541 -- test does not mean that unpickling succeeded.
543 test_pickle_of_unpickle_is_identity :: TestTree
544 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
545 [ check "pickle composed with unpickle is the identity"
546 "test/xml/scoresxml.xml",
548 check "pickle composed with unpickle is the identity (no locations)"
549 "test/xml/scoresxml-no-locations.xml",
551 check "pickle composed with unpickle is the identity (pitcher, no type)"
552 "test/xml/scoresxml-pitcher-no-type.xml"]
554 check desc path = testCase desc $ do
555 (expected, actual) <- pickle_unpickle pickle_message path
559 -- | Make sure we can actually unpickle these things.
561 test_unpickle_succeeds :: TestTree
562 test_unpickle_succeeds = testGroup "unpickle tests"
563 [ check "unpickling succeeds"
564 "test/xml/scoresxml.xml",
566 check "unpickling succeeds (no locations)"
567 "test/xml/scoresxml-no-locations.xml",
569 check "unpickling succeeds (pitcher, no type)"
570 "test/xml/scoresxml-pitcher-no-type.xml" ]
572 check desc path = testCase desc $ do
573 actual <- unpickleable path pickle_message
578 -- | Make sure everything gets deleted when we delete the top-level
581 test_on_delete_cascade :: TestTree
582 test_on_delete_cascade = testGroup "cascading delete tests"
583 [ check "unpickling succeeds"
584 "test/xml/scoresxml.xml"
585 4, -- 2 teams, 2 locations
587 check "unpickling succeeds (no locations)"
588 "test/xml/scoresxml-no-locations.xml"
589 2, -- 2 teams, 0 locations
591 check "unpickling succeeds (pitcher, no type)"
592 "test/xml/scoresxml-pitcher-no-type.xml"
593 3 -- 2 teams, 1 location
596 check desc path expected = testCase desc $ do
597 score <- unsafe_unpickle path pickle_message
598 let a = undefined :: Location
599 let b = undefined :: Team
600 let c = undefined :: Score
601 let d = undefined :: ScoreGame
602 let e = undefined :: Score_Location
603 actual <- withSqliteConn ":memory:" $ runDbConn $ do
604 runMigration silentMigrationLogger $ do
611 -- No idea how 'delete' works, so do this instead.
613 count_a <- countAll a
614 count_b <- countAll b
615 count_c <- countAll c
616 count_d <- countAll d
617 count_e <- countAll e
618 return $ sum [count_a, count_b, count_c,