1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
11 -- contains a single \<game\> and some \<location\>s.
13 module TSN.XML.Scores (
18 -- * WARNING: these are private but exported to silence warnings
19 Score_LocationConstructor(..),
21 ScoreGameConstructor(..) )
25 import Control.Monad ( join )
26 import Data.Data ( Data )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Data.Typeable ( Typeable )
30 import qualified Data.Vector.HFixed as H ( HVector, convert )
31 import Database.Groundhog (
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import qualified GHC.Generics as GHC ( Generic )
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
60 import TSN.Codegen ( tsn_codegen_config )
61 import TSN.Database ( insert_or_select )
62 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
63 import TSN.Location ( Location(..), pickle_location )
64 import TSN.Picklers ( xp_time_stamp )
70 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
87 -- * DB/XML Data types
93 -- | Database representation of a 'Message'. It lacks the
94 -- 'xml_locations' and 'xml_game' which are related via foreign keys
99 db_xml_file_id :: Int,
100 db_heading :: String,
101 db_game_id :: Maybe Int, -- ^ We've seen an empty one
102 db_schedule_id :: Maybe Int, -- ^ We've seen an empty one
103 db_tsnupdate :: Maybe Bool,
104 db_category :: String,
106 db_season_type :: Maybe String, -- ^ We've seen an empty one
107 db_time_stamp :: UTCTime }
110 -- | XML representation of the top level \<message\> element (i.e. a
115 xml_xml_file_id :: Int,
116 xml_heading :: String,
117 xml_game_id :: Maybe Int, -- ^ We've seen an empty one
118 xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one
119 xml_tsnupdate :: Maybe Bool,
120 xml_category :: String,
122 xml_locations :: [Location],
123 xml_season_type :: Maybe String, -- ^ We've seen an empty one
124 xml_game :: ScoreGameXml,
125 xml_time_stamp :: UTCTime }
126 deriving (Eq, GHC.Generic, Show)
129 -- | For 'H.convert'.
131 instance H.HVector Message
134 instance ToDb Message where
135 -- | The database representation of a 'Message' is a 'Score'.
136 type Db Message = Score
138 instance FromXml Message where
139 -- | When converting from the XML representation to the database
140 -- one, we drop the list of locations which will be foreign-keyed to
142 from_xml Message{..} =
144 db_xml_file_id = xml_xml_file_id,
145 db_heading = xml_heading,
146 db_game_id = xml_game_id,
147 db_schedule_id = xml_schedule_id,
148 db_tsnupdate = xml_tsnupdate,
149 db_category = xml_category,
150 db_sport = xml_sport,
151 db_season_type = xml_season_type,
152 db_time_stamp = xml_time_stamp }
155 -- | This lets us insert the XML representation 'Message' directly.
157 instance XmlImport Message
160 -- * ScoreGame / ScoreGameXml
162 -- | This is an embedded field within 'SportsGame'. Each \<status\>
163 -- element has two attributes, a numeral and a type. It also
164 -- contains some text. Rather than put these in their own table, we
165 -- include them in the parent 'SportsGame'.
167 data ScoreGameStatus =
169 db_status_numeral :: Maybe Int,
170 db_status_type :: Maybe String, -- ^ These are probably only one-character,
171 -- long, but they all take the same
172 -- amount of space in Postgres.
173 db_status_text :: String }
174 deriving (Data, Eq, Show, Typeable)
177 -- | Database representation of a game.
181 db_scores_id :: DefaultKey Score,
182 db_away_team_id :: DefaultKey Team,
183 db_home_team_id :: DefaultKey Team,
184 db_away_team_score :: Int,
185 db_home_team_score :: Int,
186 db_away_team_pitcher :: Maybe String, -- ^ Found in the child \<vteam\>
187 db_home_team_pitcher :: Maybe String, -- ^ Found in the child \<hteam\>
188 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
189 db_status :: ScoreGameStatus,
190 db_notes :: Maybe String }
193 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
197 xml_vteam :: VTeamXml,
198 xml_hteam :: HTeamXml,
199 xml_away_team_score :: Int,
200 xml_home_team_score :: Int,
201 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
202 xml_status :: ScoreGameStatus,
203 xml_notes :: Maybe String }
204 deriving (Eq, GHC.Generic, Show)
207 -- | For 'H.convert'.
209 instance H.HVector ScoreGameXml
212 instance ToDb ScoreGameXml where
213 -- | The database representation of a 'ScoreGameXml' is a
216 type Db ScoreGameXml = ScoreGame
219 instance Child ScoreGameXml where
220 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
223 type Parent ScoreGameXml = Score
226 instance FromXmlFkTeams ScoreGameXml where
227 -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three
228 -- foreign keys: the parent message, and the away/home teams.
230 -- During conversion, we also get the pitchers out of the teams;
231 -- unfortunately this prevents us from making the conversion
234 from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
237 db_away_team_id = fk_away,
238 db_home_team_id = fk_home,
239 db_away_team_score = xml_away_team_score,
240 db_home_team_score = xml_home_team_score,
241 db_away_team_pitcher = xml_vpitcher xml_vteam,
242 db_home_team_pitcher = xml_hpitcher xml_hteam,
243 db_time_r = xml_time_r,
244 db_status = xml_status,
245 db_notes = xml_notes }
247 -- | This lets us import the database representation 'ScoreGameXml'
250 instance XmlImportFkTeams ScoreGameXml
256 -- | Join each 'Score' with its 'Location's. Database-only. We use a
257 -- join table because the locations are kept unique but there are
258 -- multiple locations per 'Score'.
260 data Score_Location =
263 (DefaultKey Location)
266 -- * HTeamXml / VTeamXml
268 -- | XML Representation of a home team. This document type is unusual
269 -- in that the \<hteam\> elements can have a pitcher attribute
270 -- attached to them. We still want to maintain the underlying 'Team'
271 -- representation, so we say that a home team is a 'Team' and
272 -- (maybe) a pitcher.
277 xml_hpitcher :: Maybe String }
280 instance ToDb HTeamXml where
281 -- | The database analogue of a 'HTeamXml' is its 'Team'.
282 type Db HTeamXml = Team
284 instance FromXml HTeamXml where
285 -- | The conversion from XML to database is simply the 'Team' accessor.
287 from_xml = hteam . xml_ht
289 -- | Allow import of the XML representation directly, without
290 -- requiring a manual conversion to the database type first.
292 instance XmlImport HTeamXml
296 -- | XML Representation of an away team. This document type is unusual
297 -- in that the \<hteam\> elements can have a pitcher attribute
298 -- attached to them. We still want to maintain the underlying 'Team'
299 -- representation, so we say that an away team is a 'Team' and
300 -- (maybe) a pitcher.
305 xml_vpitcher :: Maybe String }
308 instance ToDb VTeamXml where
309 -- | The database analogue of a 'VTeamXml' is its 'Team'.
310 type Db VTeamXml = Team
312 instance FromXml VTeamXml where
313 -- | The conversion from XML to database is simply the 'Team' accessor.
315 from_xml = vteam . xml_vt
317 -- | Allow import of the XML representation directly, without
318 -- requiring a manual conversion to the database type first.
320 instance XmlImport VTeamXml
324 instance DbImport Message where
327 migrate (undefined :: Location)
328 migrate (undefined :: Team)
329 migrate (undefined :: Score)
330 migrate (undefined :: ScoreGame)
331 migrate (undefined :: Score_Location)
334 -- Insert the message and get its ID.
335 msg_id <- insert_xml m
337 -- Insert all of the locations contained within this message and
338 -- collect their IDs in a list. We use insert_or_select because
339 -- most of the locations will already exist, and we just want to
340 -- get the ID of the existing location when there's a collision.
341 location_ids <- mapM insert_or_select (xml_locations m)
343 -- Now use that list to construct 'Score_ScoreLocation' objects,
345 mapM_ (insert_ . Score_Location msg_id) location_ids
347 -- Insert the hteam/vteams, noting the IDs.
348 vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
349 hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)
351 -- Now use those along with the msg_id to construct the game.
352 insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)
354 return ImportSucceeded
358 -- These types have fields with e.g. db_ and xml_ prefixes, so we
359 -- use our own codegen to peel those off before naming the columns.
360 mkPersist tsn_codegen_config [groundhog|
366 - name: unique_scores
368 # Prevent multiple imports of the same message.
369 fields: [db_xml_file_id]
371 - embedded: ScoreGameStatus
373 - name: db_status_numeral
374 dbName: status_numeral
375 - name: db_status_type
377 - name: db_status_text
391 - { name: status_numeral, dbName: status_numeral }
392 - { name: status_type, dbName: status_type }
393 - { name: status_text, dbName: status_text }
396 - entity: Score_Location
397 dbName: scores__locations
399 - name: Score_Location
401 - name: score_Location0 # Default created by mkNormalFieldName
405 - name: score_Location1 # Default created by mkNormalFieldName
416 -- | Convert a 'Message' to/from \<message\>.
418 pickle_message :: PU Message
421 xpWrap (from_tuple, H.convert) $
422 xp11Tuple (xpElem "XML_File_ID" xpInt)
423 (xpElem "heading" xpText)
424 (xpElem "game_id" (xpOption xpInt))
425 (xpElem "schedule_id" (xpOption xpInt))
426 (xpOption $ xpElem "tsnupdate" xpPrim)
427 (xpElem "category" xpText)
428 (xpElem "sport" xpText)
429 (xpList pickle_location)
430 (xpElem "seasontype" (xpOption xpText))
432 (xpElem "time_stamp" xp_time_stamp)
434 from_tuple = uncurryN Message
438 -- | Convert a 'ScoreGameStatus' to/from \<status\>. The \"type\"
439 -- attribute can be either missing or empty, so we're really parsing
440 -- a double-Maybe here. We use the monad join to collapse it into
441 -- one. See also: the hteam/vteam picklers.
443 pickle_status :: PU ScoreGameStatus
446 xpWrap (from_tuple, to_tuple') $
447 xpTriple (xpAttr "numeral" $ xpOption xpInt)
448 (xpOption $ xpAttr "type" $ xpOption xpText)
451 from_tuple (x,y,z) = ScoreGameStatus x (join y) z
452 to_tuple' ScoreGameStatus{..} =
453 (db_status_numeral, s, db_status_text)
455 s = case db_status_type of
457 Just _ -> Just db_status_type
460 -- | Convert a 'ScoreGameXml' to/from \<game\>.
462 pickle_game :: PU ScoreGameXml
465 xpWrap (from_tuple, H.convert) $
466 xp7Tuple pickle_vteam
468 (xpElem "vscore" xpInt)
469 (xpElem "hscore" xpInt)
470 (xpOption $ xpElem "time_r" xpText)
472 (xpOption $ xpElem "notes" xpText)
474 from_tuple = uncurryN ScoreGameXml
477 -- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
478 -- always seem to be present here, but in the shared representation,
479 -- they're optional (because they show up blank elsewhere). So, we
480 -- pretend they're optional.
482 -- The \"pitcher\" attribute is a little bit funny. Usually, when
483 -- there's no pitcher, the attribute itself is missing. But once in
484 -- a blue moon, it will be present with no text. We want to treat
485 -- both cases the same, so what we really parse is a Maybe (Maybe
486 -- String), and then use the monad 'join' to collapse it into a single
489 pickle_vteam :: PU VTeamXml
492 xpWrap (from_tuple, to_tuple') $
493 xpTriple (xpAttr "id" xpText)
494 (xpOption $ xpAttr "pitcher" (xpOption xpText))
495 (xpOption xpText) -- Team name
497 from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)
499 to_tuple' (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
500 to_tuple' (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
503 -- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
504 -- modulo the \"h\" and \"v\". The team names always seem to be
505 -- present here, but in the shared representation, they're optional
506 -- (because they show up blank elsewhere). So, we pretend they're
509 -- The \"pitcher\" attribute is a little bit funny. Usually, when
510 -- there's no pitcher, the attribute itself is missing. But once in
511 -- a blue moon, it will be present with no text. We want to treat
512 -- both cases the same, so what we really parse is a Maybe (Maybe
513 -- String), and then use the monad 'join' to collapse it into a single
516 pickle_hteam :: PU HTeamXml
519 xpWrap (from_tuple, to_tuple') $
520 xpTriple (xpAttr "id" xpText)
521 (xpOption $ xpAttr "pitcher" (xpOption xpText))
522 (xpOption xpText) -- Team name
524 from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
525 to_tuple' (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t)
526 to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t)
534 -- | A list of all tests for this module.
536 scores_tests :: TestTree
540 [ test_on_delete_cascade,
541 test_pickle_of_unpickle_is_identity,
542 test_unpickle_succeeds ]
545 -- | If we unpickle something and then pickle it, we should wind up
546 -- with the same thing we started with. WARNING: success of this
547 -- test does not mean that unpickling succeeded.
549 test_pickle_of_unpickle_is_identity :: TestTree
550 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
551 [ check "pickle composed with unpickle is the identity"
552 "test/xml/scoresxml.xml",
554 check "pickle composed with unpickle is the identity (no locations)"
555 "test/xml/scoresxml-no-locations.xml",
557 check "pickle composed with unpickle is the identity (pitcher, no type)"
558 "test/xml/scoresxml-pitcher-no-type.xml",
560 check "pickle composed with unpickle is the identity (empty numeral)"
561 "test/xml/scoresxml-empty-numeral.xml",
563 check "pickle composed with unpickle is the identity (empty type)"
564 "test/xml/scoresxml-empty-type.xml" ]
566 check desc path = testCase desc $ do
567 (expected, actual) <- pickle_unpickle pickle_message path
571 -- | Make sure we can actually unpickle these things.
573 test_unpickle_succeeds :: TestTree
574 test_unpickle_succeeds = testGroup "unpickle tests"
575 [ check "unpickling succeeds"
576 "test/xml/scoresxml.xml",
578 check "unpickling succeeds (no locations)"
579 "test/xml/scoresxml-no-locations.xml",
581 check "unpickling succeeds (pitcher, no type)"
582 "test/xml/scoresxml-pitcher-no-type.xml",
584 check "unpickling succeeds (empty numeral)"
585 "test/xml/scoresxml-empty-numeral.xml",
587 check "unpickling succeeds (empty type)"
588 "test/xml/scoresxml-empty-type.xml" ]
590 check desc path = testCase desc $ do
591 actual <- unpickleable path pickle_message
596 -- | Make sure everything gets deleted when we delete the top-level
599 test_on_delete_cascade :: TestTree
600 test_on_delete_cascade = testGroup "cascading delete tests"
601 [ check "unpickling succeeds"
602 "test/xml/scoresxml.xml"
603 4, -- 2 teams, 2 locations
605 check "unpickling succeeds (no locations)"
606 "test/xml/scoresxml-no-locations.xml"
607 2, -- 2 teams, 0 locations
609 check "unpickling succeeds (pitcher, no type)"
610 "test/xml/scoresxml-pitcher-no-type.xml"
611 3, -- 2 teams, 1 location
613 check "unpickling succeeds (empty numeral)"
614 "test/xml/scoresxml-empty-numeral.xml"
615 3, -- 2 teams, 1 location
617 check "unpickling succeeds (empty type)"
618 "test/xml/scoresxml-empty-type.xml"
619 4 -- 2 teams, 2 locations
622 check desc path expected = testCase desc $ do
623 score <- unsafe_unpickle path pickle_message
624 let a = undefined :: Location
625 let b = undefined :: Team
626 let c = undefined :: Score
627 let d = undefined :: ScoreGame
628 let e = undefined :: Score_Location
629 actual <- withSqliteConn ":memory:" $ runDbConn $ do
630 runMigrationSilent $ do
637 -- No idea how 'delete' works, so do this instead.
639 count_a <- countAll a
640 count_b <- countAll b
641 count_c <- countAll c
642 count_d <- countAll d
643 count_e <- countAll e
644 return $ sum [count_a, count_b, count_c,