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 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 :: String, -- ^ These are probably only one-character long,
161 -- but they all take the same amount of space
163 db_status_text :: String }
164 deriving (Data, Eq, Show, Typeable)
167 -- | Database representation of a game.
171 db_scores_id :: DefaultKey Score,
174 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
175 db_status :: ScoreGameStatus,
176 db_notes :: Maybe String }
179 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
183 xml_vteam :: ScoreGameVTeam,
184 xml_hteam :: ScoreGameHTeam,
187 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
188 xml_status :: ScoreGameStatus,
189 xml_notes :: Maybe String }
192 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
193 vteam :: ScoreGameXml -> ScoreGameTeam
194 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
196 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
197 hteam :: ScoreGameXml -> ScoreGameTeam
198 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
200 instance ToDb ScoreGameXml where
201 -- | The database representation of a 'ScoreGameXml' is a
204 type Db ScoreGameXml = ScoreGame
207 instance Child ScoreGameXml where
208 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
211 type Parent ScoreGameXml = Score
214 instance FromXmlFk ScoreGameXml where
215 from_xml_fk fk ScoreGameXml{..} =
218 db_vscore = xml_vscore,
219 db_hscore = xml_hscore,
220 db_time_r = xml_time_r,
221 db_status = xml_status,
222 db_notes = xml_notes }
224 -- | This lets us import the database representation 'ScoreGameXml'
227 instance XmlImportFk ScoreGameXml
232 -- | A team that appears in a 'ScoreGame'. This is meant to represent
233 -- both home and away teams.
238 team_name :: String }
241 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
242 -- home and away teams. See also 'ScoreGameHTeam'.
244 newtype ScoreGameVTeam =
245 ScoreGameVTeam ScoreGameTeam
249 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
250 -- home and away teams. See also 'ScoreGameVTeam'.
252 newtype ScoreGameHTeam =
253 ScoreGameHTeam ScoreGameTeam
257 -- * ScoreGame_ScoreGameTeam
259 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
260 -- use a join table because the teams are kept unique. The first
261 -- argument is the game id, the second argument is the visiting team
262 -- (vteam) id, and the last argument is the home team (hteam) id.
264 data ScoreGame_ScoreGameTeam =
265 ScoreGame_ScoreGameTeam
266 (DefaultKey ScoreGame) -- game id
267 (DefaultKey ScoreGameTeam) -- vteam id
268 (DefaultKey ScoreGameTeam) -- hteam id
273 -- | Database and XML representation of a \<location\>. This is almost
274 -- identical to 'TSN.XML.NewsLocation', but the city/state have not
275 -- appeared optional here so far.
285 -- * Score_ScoreLocation
287 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
288 -- use a join table because the locations are kept unique.
290 data Score_ScoreLocation =
293 (DefaultKey ScoreLocation)
297 instance DbImport Message where
300 migrate (undefined :: Score)
301 migrate (undefined :: ScoreGame)
302 migrate (undefined :: ScoreGameTeam)
303 migrate (undefined :: ScoreGame_ScoreGameTeam)
304 migrate (undefined :: ScoreLocation)
305 migrate (undefined :: Score_ScoreLocation)
308 -- Insert the message and get its ID.
309 msg_id <- insert_xml m
311 -- Insert all of the locations contained within this message and
312 -- collect their IDs in a list.
313 location_ids <- mapM insert (xml_locations m)
315 -- Now use that list to construct 'Score_ScoreLocation' objects,
317 mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
319 -- Insert the game and its hteam/vteam, noting the IDs.
320 game_id <- insert_xml_fk msg_id (xml_game m)
321 vteam_id <- insert (vteam $ xml_game m)
322 hteam_id <- insert (hteam $ xml_game m)
324 -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
325 -- aforementioned game to its hteam/vteam.
326 insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
328 return ImportSucceeded
331 -- These types don't have special XML representations or field name
332 -- collisions so we use the defaultCodegenConfig and give their
333 -- fields nice simple names.
334 mkPersist defaultCodegenConfig [groundhog|
335 - entity: ScoreGameTeam
336 dbName: scores_games_teams
338 - name: ScoreGameTeam
340 - name: unique_scores_games_team
344 - entity: ScoreLocation
345 dbName: scores_locations
347 - name: ScoreLocation
349 - name: unique_scores_location
351 fields: [city, state, country]
357 -- These types have fields with e.g. db_ and xml_ prefixes, so we
358 -- use our own codegen to peel those off before naming the columns.
359 mkPersist tsn_codegen_config [groundhog|
365 - name: unique_scores
367 # Prevent multiple imports of the same message.
368 fields: [db_xml_file_id]
370 - embedded: ScoreGameStatus
372 - name: db_status_numeral
373 dbName: status_numeral
374 - name: db_status_type
376 - name: db_status_text
389 - { name: status_numeral, dbName: status_numeral }
390 - { name: status_type, dbName: status_type }
391 - { name: status_text, dbName: status_text }
393 - entity: ScoreGame_ScoreGameTeam
394 dbName: scores_games__scores_games_teams
396 - name: ScoreGame_ScoreGameTeam
398 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
399 dbName: scores_games_id
402 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
403 dbName: scores_games_teams_vteam_id
406 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
407 dbName: scores_games_teams_hteam_id
411 - entity: Score_ScoreLocation
412 dbName: scores__scores_locations
414 - name: Score_ScoreLocation
416 - name: score_ScoreLocation0 # Default created by mkNormalFieldName
420 - name: score_ScoreLocation1 # Default created by mkNormalFieldName
421 dbName: scores_locations_id
431 -- | Convert a 'Message' to/from \<message\>.
433 pickle_message :: PU Message
436 xpWrap (from_tuple, to_tuple) $
437 xp11Tuple (xpElem "XML_File_ID" xpInt)
438 (xpElem "heading" xpText)
439 (xpElem "game_id" xpInt)
440 (xpElem "schedule_id" xpInt)
441 (xpOption $ xpElem "tsnupdate" xpPrim)
442 (xpElem "category" xpText)
443 (xpElem "sport" xpText)
444 (xpList pickle_location)
445 (xpElem "seasontype" xpText)
447 (xpElem "time_stamp" xp_time_stamp)
449 from_tuple = uncurryN Message
450 to_tuple m = (xml_xml_file_id m,
464 -- | Convert a 'ScoreLocation' to/from \<location\>.
466 pickle_location :: PU ScoreLocation
469 xpWrap (from_tuple, to_tuple) $
470 xpTriple (xpElem "city" xpText)
471 (xpElem "state" xpText)
472 (xpElem "country" xpText)
475 uncurryN ScoreLocation
476 to_tuple l = (city l, state l, country l)
479 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
481 pickle_status :: PU ScoreGameStatus
484 xpWrap (from_tuple, to_tuple) $
485 xpTriple (xpAttr "numeral" xpInt)
486 (xpAttr "type" xpText)
489 from_tuple = uncurryN ScoreGameStatus
490 to_tuple ScoreGameStatus{..} = (db_status_numeral,
495 -- | Convert a 'ScoreGameXml' to/from \<game\>.
497 pickle_game :: PU ScoreGameXml
500 xpWrap (from_tuple, to_tuple) $
501 xp7Tuple pickle_vteam
503 (xpElem "vscore" xpInt)
504 (xpElem "hscore" xpInt)
505 (xpOption $ xpElem "time_r" xpText)
507 (xpOption $ xpElem "notes" xpText)
509 from_tuple = uncurryN ScoreGameXml
510 to_tuple ScoreGameXml{..} = (xml_vteam,
519 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
521 pickle_vteam :: PU ScoreGameVTeam
524 xpWrap (from_tuple, to_tuple) $
525 xpPair (xpAttr "id" xpText)
528 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
529 to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
532 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
533 -- 'pickle_vteam' modulo the \"h\" and \"v\".
535 pickle_hteam :: PU ScoreGameHTeam
538 xpWrap (from_tuple, to_tuple) $
539 xpPair (xpAttr "id" xpText)
542 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
543 to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
551 -- | A list of all tests for this module.
553 scores_tests :: TestTree
557 [ test_on_delete_cascade,
558 test_pickle_of_unpickle_is_identity,
559 test_unpickle_succeeds ]
562 -- | If we unpickle something and then pickle it, we should wind up
563 -- with the same thing we started with. WARNING: success of this
564 -- test does not mean that unpickling succeeded.
566 test_pickle_of_unpickle_is_identity :: TestTree
567 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
568 [ check "pickle composed with unpickle is the identity"
569 "test/xml/scoresxml.xml",
571 check "pickle composed with unpickle is the identity (no locations)"
572 "test/xml/scoresxml-no-locations.xml" ]
574 check desc path = testCase desc $ do
575 (expected, actual) <- pickle_unpickle pickle_message path
579 -- | Make sure we can actually unpickle these things.
581 test_unpickle_succeeds :: TestTree
582 test_unpickle_succeeds = testGroup "unpickle tests"
583 [ check "unpickling succeeds"
584 "test/xml/scoresxml.xml",
586 check "unpickling succeeds (no locations)"
587 "test/xml/scoresxml-no-locations.xml" ]
589 check desc path = testCase desc $ do
590 actual <- unpickleable path pickle_message
595 -- | Make sure everything gets deleted when we delete the top-level
598 test_on_delete_cascade :: TestTree
599 test_on_delete_cascade = testGroup "cascading delete tests"
600 [ check "unpickling succeeds"
601 "test/xml/scoresxml.xml"
602 4, -- 2 teams, 2 locations
604 check "unpickling succeeds (no locations)"
605 "test/xml/scoresxml-no-locations.xml"
606 2 -- 2 teams, 0 locations
609 check desc path expected = testCase desc $ do
610 score <- unsafe_unpickle path pickle_message
611 let a = undefined :: Score
612 let b = undefined :: ScoreGame
613 let c = undefined :: ScoreGameTeam
614 let d = undefined :: ScoreGame_ScoreGameTeam
615 let e = undefined :: ScoreLocation
616 let f = undefined :: Score_ScoreLocation
617 actual <- withSqliteConn ":memory:" $ runDbConn $ do
618 runMigration silentMigrationLogger $ do
626 -- No idea how 'delete' works, so do this instead.
628 count_a <- countAll a
629 count_b <- countAll b
630 count_c <- countAll c
631 count_d <- countAll d
632 count_e <- countAll e
633 count_f <- countAll f
634 return $ sum [count_a, count_b, count_c,
635 count_d, count_e, count_f ]