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(..),
21 ScoreGameTeamConstructor(..),
22 ScoreGame_ScoreGameTeamConstructor(..) )
26 import Data.Data ( Data )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Data.Typeable ( Typeable )
30 import Database.Groundhog (
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.XML.HXT.Core (
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.Database ( insert_or_select )
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Location ( Location(..), pickle_location )
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 :: [Location],
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 -- | Join each 'Score' with its 'Location's. Database-only. We
277 -- use a join table because the locations are kept unique.
279 data Score_Location =
282 (DefaultKey Location)
286 instance DbImport Message where
289 migrate (undefined :: Location)
290 migrate (undefined :: Score)
291 migrate (undefined :: ScoreGame)
292 migrate (undefined :: ScoreGameTeam)
293 migrate (undefined :: ScoreGame_ScoreGameTeam)
294 migrate (undefined :: Score_Location)
297 -- Insert the message and get its ID.
298 msg_id <- insert_xml m
300 -- Insert all of the locations contained within this message and
301 -- collect their IDs in a list. We use insert_or_select because
302 -- most of the locations will already exist, and we just want to
303 -- get the ID of the existing location when there's a collision.
304 location_ids <- mapM insert_or_select (xml_locations m)
306 -- Now use that list to construct 'Score_ScoreLocation' objects,
308 mapM_ (insert_ . Score_Location msg_id) location_ids
310 -- Insert the game and its hteam/vteam, noting the IDs.
311 game_id <- insert_xml_fk msg_id (xml_game m)
312 vteam_id <- insert (vteam $ xml_game m)
313 hteam_id <- insert (hteam $ xml_game m)
315 -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
316 -- aforementioned game to its hteam/vteam.
317 insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
319 return ImportSucceeded
322 -- These types don't have special XML representations or field name
323 -- collisions so we use the defaultCodegenConfig and give their
324 -- fields nice simple names.
325 mkPersist defaultCodegenConfig [groundhog|
326 - entity: ScoreGameTeam
327 dbName: scores_games_teams
329 - name: ScoreGameTeam
331 - name: unique_scores_games_team
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
371 - { name: status_numeral, dbName: status_numeral }
372 - { name: status_type, dbName: status_type }
373 - { name: status_text, dbName: status_text }
375 - entity: ScoreGame_ScoreGameTeam
376 dbName: scores_games__scores_games_teams
378 - name: ScoreGame_ScoreGameTeam
380 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
381 dbName: scores_games_id
384 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
385 dbName: scores_games_teams_vteam_id
388 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
389 dbName: scores_games_teams_hteam_id
393 - entity: Score_Location
394 dbName: scores__locations
396 - name: Score_Location
398 - name: score_Location0 # Default created by mkNormalFieldName
402 - name: score_Location1 # Default created by mkNormalFieldName
413 -- | Convert a 'Message' to/from \<message\>.
415 pickle_message :: PU Message
418 xpWrap (from_tuple, to_tuple) $
419 xp11Tuple (xpElem "XML_File_ID" xpInt)
420 (xpElem "heading" xpText)
421 (xpElem "game_id" xpInt)
422 (xpElem "schedule_id" xpInt)
423 (xpOption $ xpElem "tsnupdate" xpPrim)
424 (xpElem "category" xpText)
425 (xpElem "sport" xpText)
426 (xpList pickle_location)
427 (xpElem "seasontype" xpText)
429 (xpElem "time_stamp" xp_time_stamp)
431 from_tuple = uncurryN Message
432 to_tuple m = (xml_xml_file_id m,
447 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
449 pickle_status :: PU ScoreGameStatus
452 xpWrap (from_tuple, to_tuple) $
453 xpTriple (xpAttr "numeral" xpInt)
454 (xpAttr "type" xpText)
457 from_tuple = uncurryN ScoreGameStatus
458 to_tuple ScoreGameStatus{..} = (db_status_numeral,
463 -- | Convert a 'ScoreGameXml' to/from \<game\>.
465 pickle_game :: PU ScoreGameXml
468 xpWrap (from_tuple, to_tuple) $
469 xp7Tuple pickle_vteam
471 (xpElem "vscore" xpInt)
472 (xpElem "hscore" xpInt)
473 (xpOption $ xpElem "time_r" xpText)
475 (xpOption $ xpElem "notes" xpText)
477 from_tuple = uncurryN ScoreGameXml
478 to_tuple ScoreGameXml{..} = (xml_vteam,
487 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
489 pickle_vteam :: PU ScoreGameVTeam
492 xpWrap (from_tuple, to_tuple) $
493 xpPair (xpAttr "id" xpText)
496 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
497 to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
500 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
501 -- 'pickle_vteam' modulo the \"h\" and \"v\".
503 pickle_hteam :: PU ScoreGameHTeam
506 xpWrap (from_tuple, to_tuple) $
507 xpPair (xpAttr "id" xpText)
510 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
511 to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
519 -- | A list of all tests for this module.
521 scores_tests :: TestTree
525 [ test_on_delete_cascade,
526 test_pickle_of_unpickle_is_identity,
527 test_unpickle_succeeds ]
530 -- | If we unpickle something and then pickle it, we should wind up
531 -- with the same thing we started with. WARNING: success of this
532 -- test does not mean that unpickling succeeded.
534 test_pickle_of_unpickle_is_identity :: TestTree
535 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
536 [ check "pickle composed with unpickle is the identity"
537 "test/xml/scoresxml.xml",
539 check "pickle composed with unpickle is the identity (no locations)"
540 "test/xml/scoresxml-no-locations.xml" ]
542 check desc path = testCase desc $ do
543 (expected, actual) <- pickle_unpickle pickle_message path
547 -- | Make sure we can actually unpickle these things.
549 test_unpickle_succeeds :: TestTree
550 test_unpickle_succeeds = testGroup "unpickle tests"
551 [ check "unpickling succeeds"
552 "test/xml/scoresxml.xml",
554 check "unpickling succeeds (no locations)"
555 "test/xml/scoresxml-no-locations.xml" ]
557 check desc path = testCase desc $ do
558 actual <- unpickleable path pickle_message
563 -- | Make sure everything gets deleted when we delete the top-level
566 test_on_delete_cascade :: TestTree
567 test_on_delete_cascade = testGroup "cascading delete tests"
568 [ check "unpickling succeeds"
569 "test/xml/scoresxml.xml"
570 4, -- 2 teams, 2 locations
572 check "unpickling succeeds (no locations)"
573 "test/xml/scoresxml-no-locations.xml"
574 2 -- 2 teams, 0 locations
577 check desc path expected = testCase desc $ do
578 score <- unsafe_unpickle path pickle_message
579 let a = undefined :: Location
580 let b = undefined :: Score
581 let c = undefined :: ScoreGame
582 let d = undefined :: ScoreGameTeam
583 let e = undefined :: ScoreGame_ScoreGameTeam
584 let f = undefined :: Score_Location
585 actual <- withSqliteConn ":memory:" $ runDbConn $ do
586 runMigration silentMigrationLogger $ do
594 -- No idea how 'delete' works, so do this instead.
596 count_a <- countAll a
597 count_b <- countAll b
598 count_c <- countAll c
599 count_d <- countAll d
600 count_e <- countAll e
601 count_f <- countAll f
602 return $ sum [count_a, count_b, count_c,
603 count_d, count_e, count_f ]