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(..) )
78 -- | The DTD to which this module corresponds. Used to invoke dbimport.
91 -- | Database representation of a 'Message'. It lacks the
92 -- 'xml_locations' and 'xml_game' which are related via foreign keys
97 db_xml_file_id :: Int,
100 db_schedule_id :: Int,
101 db_tsnupdate :: Maybe Bool,
102 db_category :: String,
104 db_season_type :: String,
105 db_time_stamp :: UTCTime }
108 -- | XML representation of the top level \<message\> element (i.e. a
113 xml_xml_file_id :: Int,
114 xml_heading :: String,
116 xml_schedule_id :: Int,
117 xml_tsnupdate :: Maybe Bool,
118 xml_category :: String,
120 xml_locations :: [ScoreLocation],
121 xml_season_type :: String,
122 xml_game :: ScoreGameXml,
123 xml_time_stamp :: UTCTime }
126 instance ToDb Message where
127 -- | The database representation of a 'Message' is a 'Score'.
128 type Db Message = Score
130 instance FromXml Message where
131 from_xml Message{..} =
133 db_xml_file_id = xml_xml_file_id,
134 db_heading = xml_heading,
135 db_game_id = xml_game_id,
136 db_schedule_id = xml_schedule_id,
137 db_tsnupdate = xml_tsnupdate,
138 db_category = xml_category,
139 db_sport = xml_sport,
140 db_season_type = xml_season_type,
141 db_time_stamp = xml_time_stamp }
144 -- | This lets us insert the XML representation 'Message' directly.
146 instance XmlImport Message
149 -- * ScoreGame / ScoreGameXml
151 -- | This is an embedded field within 'SportsGame'. Each \<status\>
152 -- element has two attributes, a numeral and a type. It also
153 -- contains some text. Rather than put these in their own table, we
154 -- include them in the parent 'SportsGame'.
156 data ScoreGameStatus =
158 db_status_numeral :: Int,
159 db_status_type :: String, -- ^ These are probably only one-character long,
160 -- but they all take the same amount of space
162 db_status_text :: String }
163 deriving (Data, Eq, Show, Typeable)
166 -- | Database representation of a game.
170 db_scores_id :: DefaultKey Score,
173 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
174 db_status :: ScoreGameStatus,
175 db_notes :: Maybe String }
178 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
182 xml_vteam :: ScoreGameVTeam,
183 xml_hteam :: ScoreGameHTeam,
186 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
187 xml_status :: ScoreGameStatus,
188 xml_notes :: Maybe String }
191 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
192 vteam :: ScoreGameXml -> ScoreGameTeam
193 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
195 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
196 hteam :: ScoreGameXml -> ScoreGameTeam
197 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
199 instance ToDb ScoreGameXml where
200 -- | The database representation of a 'ScoreGameXml' is a
203 type Db ScoreGameXml = ScoreGame
205 instance FromXmlFk ScoreGameXml where
206 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
209 type Parent ScoreGameXml = Score
211 from_xml_fk fk ScoreGameXml{..} =
214 db_vscore = xml_vscore,
215 db_hscore = xml_hscore,
216 db_time_r = xml_time_r,
217 db_status = xml_status,
218 db_notes = xml_notes }
220 -- | This lets us import the database representation 'ScoreGameXml'
223 instance XmlImportFk ScoreGameXml
228 -- | A team that appears in a 'ScoreGame'. This is meant to represent
229 -- both home and away teams.
234 team_name :: String }
237 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
238 -- home and away teams. See also 'ScoreGameHTeam'.
240 newtype ScoreGameVTeam =
241 ScoreGameVTeam ScoreGameTeam
245 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
246 -- home and away teams. See also 'ScoreGameVTeam'.
248 newtype ScoreGameHTeam =
249 ScoreGameHTeam ScoreGameTeam
253 -- * ScoreGame_ScoreGameTeam
255 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
256 -- use a join table because the teams are kept unique. The first
257 -- argument is the game id, the second argument is the visiting team
258 -- (vteam) id, and the last argument is the home team (hteam) id.
260 data ScoreGame_ScoreGameTeam =
261 ScoreGame_ScoreGameTeam
262 (DefaultKey ScoreGame) -- game id
263 (DefaultKey ScoreGameTeam) -- vteam id
264 (DefaultKey ScoreGameTeam) -- hteam id
269 -- | Database and XML representation of a \<location\>. This is almost
270 -- identical to 'TSN.XML.NewsLocation', but the city/state have not
271 -- appeared optional here so far.
281 -- * Score_ScoreLocation
283 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
284 -- use a join table because the locations are kept unique.
286 data Score_ScoreLocation =
289 (DefaultKey ScoreLocation)
293 instance DbImport Message where
296 migrate (undefined :: Score)
297 migrate (undefined :: ScoreGame)
298 migrate (undefined :: ScoreGameTeam)
299 migrate (undefined :: ScoreGame_ScoreGameTeam)
300 migrate (undefined :: ScoreLocation)
301 migrate (undefined :: Score_ScoreLocation)
304 -- Insert the message and get its ID.
305 msg_id <- insert_xml m
307 -- Insert all of the locations contained within this message and
308 -- collect their IDs in a list.
309 location_ids <- mapM insert (xml_locations m)
311 -- Now use that list to construct 'Score_ScoreLocation' objects,
313 mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
315 -- Insert the game and its hteam/vteam, noting the IDs.
316 game_id <- insert_xml_fk msg_id (xml_game m)
317 vteam_id <- insert (vteam $ xml_game m)
318 hteam_id <- insert (hteam $ xml_game m)
320 -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
321 -- aforementioned game to its hteam/vteam.
322 insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
324 return ImportSucceeded
327 -- These types don't have special XML representations or field name
328 -- collisions so we use the defaultCodegenConfig and give their
329 -- fields nice simple names.
330 mkPersist defaultCodegenConfig [groundhog|
331 - entity: ScoreGameTeam
332 dbName: scores_games_teams
334 - name: ScoreGameTeam
336 - name: unique_scores_games_team
340 - entity: ScoreLocation
341 dbName: scores_locations
343 - name: ScoreLocation
345 - name: unique_scores_location
347 fields: [city, state, country]
353 -- These types have fields with e.g. db_ and xml_ prefixes, so we
354 -- use our own codegen to peel those off before naming the columns.
355 mkPersist tsn_codegen_config [groundhog|
361 - name: unique_scores
363 # Prevent multiple imports of the same message.
364 fields: [db_xml_file_id]
366 - embedded: ScoreGameStatus
368 - name: db_status_numeral
369 dbName: status_numeral
370 - name: db_status_type
372 - name: db_status_text
385 - { name: status_numeral, dbName: status_numeral }
386 - { name: status_type, dbName: status_type }
387 - { name: status_text, dbName: status_text }
389 - entity: ScoreGame_ScoreGameTeam
390 dbName: scores_games__scores_games_teams
392 - name: ScoreGame_ScoreGameTeam
394 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
395 dbName: scores_games_id
398 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
399 dbName: scores_games_teams_vteam_id
402 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
403 dbName: scores_games_teams_hteam_id
407 - entity: Score_ScoreLocation
408 dbName: scores__scores_locations
410 - name: Score_ScoreLocation
412 - name: score_ScoreLocation0 # Default created by mkNormalFieldName
416 - name: score_ScoreLocation1 # Default created by mkNormalFieldName
417 dbName: scores_locations_id
427 -- | Convert a 'Message' to/from \<message\>.
429 pickle_message :: PU Message
432 xpWrap (from_tuple, to_tuple) $
433 xp11Tuple (xpElem "XML_File_ID" xpInt)
434 (xpElem "heading" xpText)
435 (xpElem "game_id" xpInt)
436 (xpElem "schedule_id" xpInt)
437 (xpOption $ xpElem "tsnupdate" xpPrim)
438 (xpElem "category" xpText)
439 (xpElem "sport" xpText)
440 (xpList pickle_location)
441 (xpElem "seasontype" xpText)
443 (xpElem "time_stamp" xp_time_stamp)
445 from_tuple = uncurryN Message
446 to_tuple m = (xml_xml_file_id m,
460 -- | Convert a 'ScoreLocation' to/from \<location\>.
462 pickle_location :: PU ScoreLocation
465 xpWrap (from_tuple, to_tuple) $
466 xpTriple (xpElem "city" xpText)
467 (xpElem "state" xpText)
468 (xpElem "country" xpText)
471 uncurryN ScoreLocation
472 to_tuple l = (city l, state l, country l)
475 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
477 pickle_status :: PU ScoreGameStatus
480 xpWrap (from_tuple, to_tuple) $
481 xpTriple (xpAttr "numeral" xpInt)
482 (xpAttr "type" xpText)
485 from_tuple = uncurryN ScoreGameStatus
486 to_tuple ScoreGameStatus{..} = (db_status_numeral,
491 -- | Convert a 'ScoreGameXml' to/from \<game\>.
493 pickle_game :: PU ScoreGameXml
496 xpWrap (from_tuple, to_tuple) $
497 xp7Tuple pickle_vteam
499 (xpElem "vscore" xpInt)
500 (xpElem "hscore" xpInt)
501 (xpOption $ xpElem "time_r" xpText)
503 (xpOption $ xpElem "notes" xpText)
505 from_tuple = uncurryN ScoreGameXml
506 to_tuple ScoreGameXml{..} = (xml_vteam,
515 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
517 pickle_vteam :: PU ScoreGameVTeam
520 xpWrap (from_tuple, to_tuple) $
521 xpPair (xpAttr "id" xpText)
524 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
525 to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
528 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
529 -- 'pickle_vteam' modulo the \"h\" and \"v\".
531 pickle_hteam :: PU ScoreGameHTeam
534 xpWrap (from_tuple, to_tuple) $
535 xpPair (xpAttr "id" xpText)
538 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
539 to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
547 -- | A list of all tests for this module.
549 scores_tests :: TestTree
553 [ test_on_delete_cascade,
554 test_pickle_of_unpickle_is_identity,
555 test_unpickle_succeeds ]
558 -- | If we unpickle something and then pickle it, we should wind up
559 -- with the same thing we started with. WARNING: success of this
560 -- test does not mean that unpickling succeeded.
562 test_pickle_of_unpickle_is_identity :: TestTree
563 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
564 [ check "pickle composed with unpickle is the identity"
565 "test/xml/scoresxml.xml",
567 check "pickle composed with unpickle is the identity (no locations)"
568 "test/xml/scoresxml-no-locations.xml" ]
570 check desc path = testCase desc $ do
571 (expected, actual) <- pickle_unpickle pickle_message path
575 -- | Make sure we can actually unpickle these things.
577 test_unpickle_succeeds :: TestTree
578 test_unpickle_succeeds = testGroup "unpickle tests"
579 [ check "unpickling succeeds"
580 "test/xml/scoresxml.xml",
582 check "unpickling succeeds (no locations)"
583 "test/xml/scoresxml-no-locations.xml" ]
585 check desc path = testCase desc $ do
586 actual <- unpickleable path pickle_message
591 -- | Make sure everything gets deleted when we delete the top-level
594 test_on_delete_cascade :: TestTree
595 test_on_delete_cascade = testGroup "cascading delete tests"
596 [ check "unpickling succeeds"
597 "test/xml/scoresxml.xml"
598 4, -- 2 teams, 2 locations
600 check "unpickling succeeds (no locations)"
601 "test/xml/scoresxml-no-locations.xml"
602 2 -- 2 teams, 0 locations
605 check desc path expected = testCase desc $ do
606 score <- unsafe_unpickle path pickle_message
607 let a = undefined :: Score
608 let b = undefined :: ScoreGame
609 let c = undefined :: ScoreGameTeam
610 let d = undefined :: ScoreGame_ScoreGameTeam
611 let e = undefined :: ScoreLocation
612 let f = undefined :: Score_ScoreLocation
613 actual <- withSqliteConn ":memory:" $ runDbConn $ do
614 runMigration silentMigrationLogger $ do
622 -- No idea how 'delete' works, so do this instead.
624 count_a <- countAll a
625 count_b <- countAll b
626 count_c <- countAll c
627 count_d <- countAll d
628 count_e <- countAll e
629 count_f <- countAll f
630 return $ sum [count_a, count_b, count_c,
631 count_d, count_e, count_f ]