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_ScoreLocationConstructor(..),
20 ScoreGameConstructor(..),
21 ScoreGameTeamConstructor(..),
22 ScoreLocationConstructor(..),
23 ScoreGame_ScoreGameTeamConstructor(..) )
27 import Data.Data ( Data )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Data.Typeable ( Typeable )
31 import Database.Groundhog (
38 silentMigrationLogger )
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.Sqlite ( withSqliteConn )
42 import Database.Groundhog.TH (
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 import TSN.Picklers ( xp_time_stamp )
68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
79 -- | The DTD to which this module corresponds. Used to invoke dbimport.
92 -- | Database representation of a 'Message'. It lacks the
93 -- 'xml_locations' and 'xml_game' which are related via foreign keys
98 db_xml_file_id :: Int,
101 db_schedule_id :: Int,
102 db_tsnupdate :: Maybe Bool,
103 db_category :: String,
105 db_season_type :: String,
106 db_time_stamp :: UTCTime }
109 -- | XML representation of the top level \<message\> element (i.e. a
114 xml_xml_file_id :: Int,
115 xml_heading :: String,
117 xml_schedule_id :: Int,
118 xml_tsnupdate :: Maybe Bool,
119 xml_category :: String,
121 xml_locations :: [ScoreLocation],
122 xml_season_type :: String,
123 xml_game :: ScoreGameXml,
124 xml_time_stamp :: UTCTime }
127 instance ToDb Message where
128 -- | The database representation of a 'Message' is a 'Score'.
129 type Db Message = Score
131 instance FromXml Message where
132 -- | When converting from the XML representation to the database
133 -- one, we drop the list of locations which will be foreign-keyed to
135 from_xml Message{..} =
137 db_xml_file_id = xml_xml_file_id,
138 db_heading = xml_heading,
139 db_game_id = xml_game_id,
140 db_schedule_id = xml_schedule_id,
141 db_tsnupdate = xml_tsnupdate,
142 db_category = xml_category,
143 db_sport = xml_sport,
144 db_season_type = xml_season_type,
145 db_time_stamp = xml_time_stamp }
148 -- | This lets us insert the XML representation 'Message' directly.
150 instance XmlImport Message
153 -- * ScoreGame / ScoreGameXml
155 -- | This is an embedded field within 'SportsGame'. Each \<status\>
156 -- element has two attributes, a numeral and a type. It also
157 -- contains some text. Rather than put these in their own table, we
158 -- include them in the parent 'SportsGame'.
160 data ScoreGameStatus =
162 db_status_numeral :: Int,
163 db_status_type :: String, -- ^ These are probably only one-character long,
164 -- but they all take the same amount of space
166 db_status_text :: String }
167 deriving (Data, Eq, Show, Typeable)
170 -- | Database representation of a game.
174 db_scores_id :: DefaultKey Score,
177 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
178 db_status :: ScoreGameStatus,
179 db_notes :: Maybe String }
182 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
186 xml_vteam :: ScoreGameVTeam,
187 xml_hteam :: ScoreGameHTeam,
190 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
191 xml_status :: ScoreGameStatus,
192 xml_notes :: Maybe String }
195 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
196 vteam :: ScoreGameXml -> ScoreGameTeam
197 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
199 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
200 hteam :: ScoreGameXml -> ScoreGameTeam
201 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
203 instance ToDb ScoreGameXml where
204 -- | The database representation of a 'ScoreGameXml' is a
207 type Db ScoreGameXml = ScoreGame
210 instance Child ScoreGameXml where
211 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
214 type Parent ScoreGameXml = Score
217 instance FromXmlFk ScoreGameXml where
218 from_xml_fk fk ScoreGameXml{..} =
221 db_vscore = xml_vscore,
222 db_hscore = xml_hscore,
223 db_time_r = xml_time_r,
224 db_status = xml_status,
225 db_notes = xml_notes }
227 -- | This lets us import the database representation 'ScoreGameXml'
230 instance XmlImportFk ScoreGameXml
235 -- | A team that appears in a 'ScoreGame'. This is meant to represent
236 -- both home and away teams.
241 team_name :: String }
244 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
245 -- home and away teams. See also 'ScoreGameHTeam'.
247 newtype ScoreGameVTeam =
248 ScoreGameVTeam ScoreGameTeam
252 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
253 -- home and away teams. See also 'ScoreGameVTeam'.
255 newtype ScoreGameHTeam =
256 ScoreGameHTeam ScoreGameTeam
260 -- * ScoreGame_ScoreGameTeam
262 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
263 -- use a join table because the teams are kept unique. The first
264 -- argument is the game id, the second argument is the visiting team
265 -- (vteam) id, and the last argument is the home team (hteam) id.
267 data ScoreGame_ScoreGameTeam =
268 ScoreGame_ScoreGameTeam
269 (DefaultKey ScoreGame) -- game id
270 (DefaultKey ScoreGameTeam) -- vteam id
271 (DefaultKey ScoreGameTeam) -- hteam id
276 -- | Database and XML representation of a \<location\>. This is almost
277 -- identical to 'TSN.XML.NewsLocation', but the city/state have not
278 -- appeared optional here so far.
288 -- * Score_ScoreLocation
290 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
291 -- use a join table because the locations are kept unique.
293 data Score_ScoreLocation =
296 (DefaultKey ScoreLocation)
300 instance DbImport Message where
303 migrate (undefined :: Score)
304 migrate (undefined :: ScoreGame)
305 migrate (undefined :: ScoreGameTeam)
306 migrate (undefined :: ScoreGame_ScoreGameTeam)
307 migrate (undefined :: ScoreLocation)
308 migrate (undefined :: Score_ScoreLocation)
311 -- Insert the message and get its ID.
312 msg_id <- insert_xml m
314 -- Insert all of the locations contained within this message and
315 -- collect their IDs in a list.
316 location_ids <- mapM insert (xml_locations m)
318 -- Now use that list to construct 'Score_ScoreLocation' objects,
320 mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
322 -- Insert the game and its hteam/vteam, noting the IDs.
323 game_id <- insert_xml_fk msg_id (xml_game m)
324 vteam_id <- insert (vteam $ xml_game m)
325 hteam_id <- insert (hteam $ xml_game m)
327 -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
328 -- aforementioned game to its hteam/vteam.
329 insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
331 return ImportSucceeded
334 -- These types don't have special XML representations or field name
335 -- collisions so we use the defaultCodegenConfig and give their
336 -- fields nice simple names.
337 mkPersist defaultCodegenConfig [groundhog|
338 - entity: ScoreGameTeam
339 dbName: scores_games_teams
341 - name: ScoreGameTeam
343 - name: unique_scores_games_team
347 - entity: ScoreLocation
348 dbName: scores_locations
350 - name: ScoreLocation
352 - name: unique_scores_location
354 fields: [city, state, country]
360 -- These types have fields with e.g. db_ and xml_ prefixes, so we
361 -- use our own codegen to peel those off before naming the columns.
362 mkPersist tsn_codegen_config [groundhog|
368 - name: unique_scores
370 # Prevent multiple imports of the same message.
371 fields: [db_xml_file_id]
373 - embedded: ScoreGameStatus
375 - name: db_status_numeral
376 dbName: status_numeral
377 - name: db_status_type
379 - name: db_status_text
392 - { name: status_numeral, dbName: status_numeral }
393 - { name: status_type, dbName: status_type }
394 - { name: status_text, dbName: status_text }
396 - entity: ScoreGame_ScoreGameTeam
397 dbName: scores_games__scores_games_teams
399 - name: ScoreGame_ScoreGameTeam
401 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
402 dbName: scores_games_id
405 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
406 dbName: scores_games_teams_vteam_id
409 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
410 dbName: scores_games_teams_hteam_id
414 - entity: Score_ScoreLocation
415 dbName: scores__scores_locations
417 - name: Score_ScoreLocation
419 - name: score_ScoreLocation0 # Default created by mkNormalFieldName
423 - name: score_ScoreLocation1 # Default created by mkNormalFieldName
424 dbName: scores_locations_id
434 -- | Convert a 'Message' to/from \<message\>.
436 pickle_message :: PU Message
439 xpWrap (from_tuple, to_tuple) $
440 xp11Tuple (xpElem "XML_File_ID" xpInt)
441 (xpElem "heading" xpText)
442 (xpElem "game_id" xpInt)
443 (xpElem "schedule_id" xpInt)
444 (xpOption $ xpElem "tsnupdate" xpPrim)
445 (xpElem "category" xpText)
446 (xpElem "sport" xpText)
447 (xpList pickle_location)
448 (xpElem "seasontype" xpText)
450 (xpElem "time_stamp" xp_time_stamp)
452 from_tuple = uncurryN Message
453 to_tuple m = (xml_xml_file_id m,
467 -- | Convert a 'ScoreLocation' to/from \<location\>.
469 pickle_location :: PU ScoreLocation
472 xpWrap (from_tuple, to_tuple) $
473 xpTriple (xpElem "city" xpText)
474 (xpElem "state" xpText)
475 (xpElem "country" xpText)
478 uncurryN ScoreLocation
479 to_tuple l = (city l, state l, country l)
482 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
484 pickle_status :: PU ScoreGameStatus
487 xpWrap (from_tuple, to_tuple) $
488 xpTriple (xpAttr "numeral" xpInt)
489 (xpAttr "type" xpText)
492 from_tuple = uncurryN ScoreGameStatus
493 to_tuple ScoreGameStatus{..} = (db_status_numeral,
498 -- | Convert a 'ScoreGameXml' to/from \<game\>.
500 pickle_game :: PU ScoreGameXml
503 xpWrap (from_tuple, to_tuple) $
504 xp7Tuple pickle_vteam
506 (xpElem "vscore" xpInt)
507 (xpElem "hscore" xpInt)
508 (xpOption $ xpElem "time_r" xpText)
510 (xpOption $ xpElem "notes" xpText)
512 from_tuple = uncurryN ScoreGameXml
513 to_tuple ScoreGameXml{..} = (xml_vteam,
522 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
524 pickle_vteam :: PU ScoreGameVTeam
527 xpWrap (from_tuple, to_tuple) $
528 xpPair (xpAttr "id" xpText)
531 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
532 to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
535 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
536 -- 'pickle_vteam' modulo the \"h\" and \"v\".
538 pickle_hteam :: PU ScoreGameHTeam
541 xpWrap (from_tuple, to_tuple) $
542 xpPair (xpAttr "id" xpText)
545 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
546 to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
554 -- | A list of all tests for this module.
556 scores_tests :: TestTree
560 [ test_on_delete_cascade,
561 test_pickle_of_unpickle_is_identity,
562 test_unpickle_succeeds ]
565 -- | If we unpickle something and then pickle it, we should wind up
566 -- with the same thing we started with. WARNING: success of this
567 -- test does not mean that unpickling succeeded.
569 test_pickle_of_unpickle_is_identity :: TestTree
570 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
571 [ check "pickle composed with unpickle is the identity"
572 "test/xml/scoresxml.xml",
574 check "pickle composed with unpickle is the identity (no locations)"
575 "test/xml/scoresxml-no-locations.xml" ]
577 check desc path = testCase desc $ do
578 (expected, actual) <- pickle_unpickle pickle_message path
582 -- | Make sure we can actually unpickle these things.
584 test_unpickle_succeeds :: TestTree
585 test_unpickle_succeeds = testGroup "unpickle tests"
586 [ check "unpickling succeeds"
587 "test/xml/scoresxml.xml",
589 check "unpickling succeeds (no locations)"
590 "test/xml/scoresxml-no-locations.xml" ]
592 check desc path = testCase desc $ do
593 actual <- unpickleable path pickle_message
598 -- | Make sure everything gets deleted when we delete the top-level
601 test_on_delete_cascade :: TestTree
602 test_on_delete_cascade = testGroup "cascading delete tests"
603 [ check "unpickling succeeds"
604 "test/xml/scoresxml.xml"
605 4, -- 2 teams, 2 locations
607 check "unpickling succeeds (no locations)"
608 "test/xml/scoresxml-no-locations.xml"
609 2 -- 2 teams, 0 locations
612 check desc path expected = testCase desc $ do
613 score <- unsafe_unpickle path pickle_message
614 let a = undefined :: Score
615 let b = undefined :: ScoreGame
616 let c = undefined :: ScoreGameTeam
617 let d = undefined :: ScoreGame_ScoreGameTeam
618 let e = undefined :: ScoreLocation
619 let f = undefined :: Score_ScoreLocation
620 actual <- withSqliteConn ":memory:" $ runDbConn $ do
621 runMigration silentMigrationLogger $ do
629 -- No idea how 'delete' works, so do this instead.
631 count_a <- countAll a
632 count_b <- countAll b
633 count_c <- countAll c
634 count_d <- countAll d
635 count_e <- countAll e
636 count_f <- countAll f
637 return $ sum [count_a, count_b, count_c,
638 count_d, count_e, count_f ]