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 (
16 -- * WARNING: these are private but exported to silence warnings
17 Score_ScoreLocationConstructor(..),
19 ScoreGameConstructor(..),
20 ScoreGameTeamConstructor(..),
21 ScoreLocationConstructor(..),
22 ScoreGame_ScoreGameTeamConstructor(..) )
26 import Control.Monad ( forM_ )
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 (
36 silentMigrationLogger )
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
44 import Test.Tasty ( TestTree, testGroup )
45 import Test.Tasty.HUnit ( (@?=), testCase )
46 import Text.XML.HXT.Core (
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
67 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
86 db_xml_file_id :: Int,
89 db_schedule_id :: Int,
90 db_tsnupdate :: Maybe Bool,
91 db_category :: String,
93 db_season_type :: String,
94 db_time_stamp :: UTCTime }
98 xml_xml_file_id :: Int,
99 xml_heading :: String,
101 xml_schedule_id :: Int,
102 xml_tsnupdate :: Maybe Bool,
103 xml_category :: String,
105 xml_locations :: [ScoreLocation],
106 xml_season_type :: String,
107 xml_game :: ScoreGameXml,
108 xml_time_stamp :: UTCTime }
112 -- * ScoreGame / ScoreGameXml
114 data ScoreGameStatus =
116 db_status_numeral :: Int,
117 db_status_type :: String, -- ^ These are probably only one-character long,
118 -- but they all take the same amount of space
120 db_status_text :: String }
121 deriving (Data, Eq, Show, Typeable)
125 db_scores_id :: DefaultKey Score,
128 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
129 db_status :: ScoreGameStatus,
130 db_notes :: Maybe String }
135 xml_vteam :: ScoreGameVTeam,
136 xml_hteam :: ScoreGameHTeam,
139 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
140 xml_status :: ScoreGameStatus,
141 xml_notes :: Maybe String }
149 team_name :: String }
152 newtype ScoreGameVTeam =
153 ScoreGameVTeam ScoreGameTeam
156 newtype ScoreGameHTeam =
157 ScoreGameHTeam ScoreGameTeam
160 -- * ScoreGame_ScoreGameTeam
162 -- | Join a ScoreGame with its home/away teams.
164 data ScoreGame_ScoreGameTeam =
165 ScoreGame_ScoreGameTeam
166 (DefaultKey ScoreGame) -- ^ game id
167 (DefaultKey ScoreGameTeam) -- ^ vteam id
168 (DefaultKey ScoreGameTeam) -- ^ hteam id
175 city :: Maybe String,
176 state :: Maybe String,
181 -- * Score_ScoreLocation
183 data Score_ScoreLocation =
186 (DefaultKey ScoreLocation)
192 -- These types don't have special XML representations or field name
193 -- collisions so we use the defaultCodegenConfig and give their
194 -- fields nice simple names.
195 mkPersist defaultCodegenConfig [groundhog|
196 - entity: ScoreGameTeam
197 dbName: scores_games_teams
199 - name: ScoreGameTeam
201 - name: unique_scores_games_team
205 - entity: ScoreLocation
206 dbName: scores_locations
208 - name: ScoreLocation
210 - name: unique_scores_location
212 fields: [city, state, country]
218 -- These types have fields with e.g. db_ and xml_ prefixes, so we
219 -- use our own codegen to peel those off before naming the columns.
220 mkPersist tsn_codegen_config [groundhog|
225 - name: unique_scores
227 # Prevent multiple imports of the same message.
228 fields: [db_xml_file_id]
230 - embedded: ScoreGameStatus
232 - name: db_status_numeral
233 dbName: status_numeral
234 - name: db_status_type
236 - name: db_status_text
249 - { name: status_numeral, dbName: status_numeral }
250 - { name: status_type, dbName: status_type }
251 - { name: status_text, dbName: status_text }
253 - entity: ScoreGame_ScoreGameTeam
254 dbName: scores__scores_games_teams
256 - name: ScoreGame_ScoreGameTeam
258 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
259 dbName: scores_games_id
262 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
263 dbName: scores_games_teams_vteam_id
266 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
267 dbName: scores_games_teams_hteam_id
271 - entity: Score_ScoreLocation
272 dbName: scores__scores_locations
274 - name: Score_ScoreLocation
276 - name: score_ScoreLocation0 # Default created by mkNormalFieldName
280 - name: score_ScoreLocation1 # Default created by mkNormalFieldName
281 dbName: scores_locations_id
291 -- | Convert a 'Message' to/from XML.
293 pickle_message :: PU Message
296 xpWrap (from_tuple, to_tuple) $
297 xp11Tuple (xpElem "XML_File_ID" xpInt)
298 (xpElem "heading" xpText)
299 (xpElem "game_id" xpInt)
300 (xpElem "schedule_id" xpInt)
301 (xpOption $ xpElem "tsnupdate" xpPrim)
302 (xpElem "category" xpText)
303 (xpElem "sport" xpText)
304 (xpList pickle_location)
305 (xpElem "seasontype" xpText)
307 (xpElem "time_stamp" xp_time_stamp)
309 from_tuple = uncurryN Message
310 to_tuple m = (xml_xml_file_id m,
324 -- | Convert a 'ScoreLocation' to/from XML.
326 pickle_location :: PU ScoreLocation
329 xpWrap (from_tuple, to_tuple) $
330 xpTriple (xpOption (xpElem "city" xpText))
331 (xpOption (xpElem "state" xpText))
332 (xpElem "country" xpText)
335 uncurryN ScoreLocation
336 to_tuple l = (city l, state l, country l)
339 pickle_status :: PU ScoreGameStatus
342 xpWrap (from_tuple, to_tuple) $
343 xpTriple (xpAttr "numeral" xpInt)
344 (xpAttr "type" xpText)
347 from_tuple = uncurryN ScoreGameStatus
348 to_tuple (ScoreGameStatus x y z) = (x,y,z)
350 pickle_game :: PU ScoreGameXml
353 xpWrap (from_tuple, to_tuple) $
354 xp7Tuple pickle_vteam
356 (xpElem "vscore" xpInt)
357 (xpElem "hscore" xpInt)
358 (xpOption $ xpElem "time_r" xpText)
360 (xpOption $ xpElem "notes" xpText)
362 from_tuple = uncurryN ScoreGameXml
363 to_tuple ScoreGameXml{..} = (xml_vteam,
372 pickle_vteam :: PU ScoreGameVTeam
375 xpWrap (from_tuple, to_tuple) $
376 xpPair (xpAttr "id" xpText)
379 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
380 to_tuple (ScoreGameVTeam (ScoreGameTeam x y)) = (x,y)
383 pickle_hteam :: PU ScoreGameHTeam
386 xpWrap (from_tuple, to_tuple) $
387 xpPair (xpAttr "id" xpText)
390 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
391 to_tuple (ScoreGameHTeam (ScoreGameTeam x y)) = (x,y)
398 -- | A list of all tests for this module.
400 scores_tests :: TestTree
404 [ test_pickle_of_unpickle_is_identity,
405 test_unpickle_succeeds ]
408 -- | If we unpickle something and then pickle it, we should wind up
409 -- with the same thing we started with. WARNING: success of this
410 -- test does not mean that unpickling succeeded.
412 test_pickle_of_unpickle_is_identity :: TestTree
413 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
414 [ check "pickle composed with unpickle is the identity"
415 "test/xml/scoresxml.xml",
417 check "pickle composed with unpickle is the identity (no locations)"
418 "test/xml/scoresxml-no-locations.xml" ]
420 check desc path = testCase desc $ do
421 (expected, actual) <- pickle_unpickle pickle_message path
425 -- | Make sure we can actually unpickle these things.
427 test_unpickle_succeeds :: TestTree
428 test_unpickle_succeeds = testGroup "unpickle tests"
429 [ check "unpickling succeeds"
430 "test/xml/scoresxml.xml",
432 check "unpickling succeeds (no locations)"
433 "test/xml/scoresxml-no-locations.xml" ]
435 check desc path = testCase desc $ do
436 actual <- unpickleable path pickle_message