1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
9 -- document contains a root element \<message\> that in turn
10 -- contains zero or more \<Listing\>s (note: capitalization). The
11 -- \<Listing\>s contain \<PlayerListing\>s which then contain the
14 module TSN.XML.InjuriesDetail (
18 injuries_detail_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 InjuriesDetailConstructor(..),
21 InjuriesDetailListingConstructor(..),
22 InjuriesDetailListingPlayerListingConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
35 silentMigrationLogger )
36 import Database.Groundhog.Generic ( runDbConn )
37 import Database.Groundhog.Sqlite ( withSqliteConn )
38 import Database.Groundhog.TH (
41 import Test.Tasty ( TestTree, testGroup )
42 import Test.Tasty.HUnit ( (@?=), testCase )
43 import Text.XML.HXT.Core (
57 import TSN.Codegen ( tsn_codegen_config )
58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
59 import TSN.Picklers( xp_date, xp_time_stamp )
60 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
74 dtd = "Injuries_Detail_XML.dtd"
82 -- * InjuriesDetail/Message
85 -- | XML representation of the top-level \<message\> element. These
86 -- are not stored; the data type is used only for parsing.
90 xml_xml_file_id :: Int,
91 xml_heading :: String,
92 xml_category :: String,
94 xml_listings :: [InjuriesDetailListingXml],
95 xml_time_stamp :: UTCTime }
98 -- | Database representation of a 'Message'.
100 data InjuriesDetail =
102 db_xml_file_id :: Int,
104 db_time_stamp :: UTCTime }
107 instance ToDb Message where
108 -- | The database representation of a 'Message' is an
111 type Db Message = InjuriesDetail
113 instance FromXml Message where
114 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
117 from_xml Message{..} =
119 db_xml_file_id = xml_xml_file_id,
120 db_sport = xml_sport,
121 db_time_stamp = xml_time_stamp }
124 -- | This allows us to insert the XML representation 'Message'
127 instance XmlImport Message
131 -- * InjuriesDetailListing/InjuriesDetailListingXml
133 -- | Database representation of a \<Listing\> element. It has a
134 -- foreign key pointing to its parent 'InjuriesDetail', and does not
135 -- contain the list of 'xml_player_listings' (which get their own
138 data InjuriesDetailListing =
139 InjuriesDetailListing {
140 db_injuries_detail_id :: DefaultKey InjuriesDetail,
141 db_team_id :: String,
142 db_full_name :: String }
145 -- | XML incarnation of a \<Listing\> element. We don't store these;
146 -- the data type is used only for parsing.
148 data InjuriesDetailListingXml =
149 InjuriesDetailListingXml {
150 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
151 -- characters long and not necessarily
154 xml_full_name :: String, -- ^ Team full name
155 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
158 instance ToDb InjuriesDetailListingXml where
159 -- | The database analogue of an 'InjuriesDetailListingXml' is a
160 -- 'InjuriesDetailListing'.
161 type Db InjuriesDetailListingXml = InjuriesDetailListing
163 instance FromXmlFk InjuriesDetailListingXml where
164 -- | Each 'InjuriesDetailListingXml' is contained in an
166 type Parent InjuriesDetailListingXml = InjuriesDetail
168 -- | Construct a 'InjuriesDetailListing' from a
169 -- 'InjuriesDetailListingXml' and a foreign key to a
172 from_xml_fk fk InjuriesDetailListingXml{..} =
173 InjuriesDetailListing {
174 db_injuries_detail_id = fk,
175 db_team_id = xml_team_id,
176 db_full_name = xml_full_name }
178 -- | This allows us to insert the XML representation
179 -- 'InjuriesDetailListingXml' directly.
181 instance XmlImportFk InjuriesDetailListingXml
184 -- * InjuriesDetailListingPlayerListing
186 -- | XML representation of a \<PlayerListing\>, the main type of
187 -- element contains in Injuries_Detail_XML messages.
189 data InjuriesDetailListingPlayerListingXml =
190 InjuriesDetailListingPlayerListingXml {
191 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
192 -- characters long and not
193 -- necessarily numeric. Postgres
194 -- imposes no performance penalty
195 -- on a lengthless text field, so
196 -- we ignore the likely upper
197 -- bound of three characters.
198 -- We add the \"player\" to avoid conflict
199 -- with 'InjuriesDetailListingXml'.
200 xml_player_id :: Int,
204 xml_injury :: String,
205 xml_status :: String,
206 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
213 -- | Database representation of a
214 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
215 -- because it's redundant.
217 data InjuriesDetailListingPlayerListing =
218 InjuriesDetailListingPlayerListing {
219 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
226 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
231 instance ToDb InjuriesDetailListingPlayerListingXml where
232 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
233 -- 'InjuriesDetailListingPlayerListing'.
234 type Db InjuriesDetailListingPlayerListingXml =
235 InjuriesDetailListingPlayerListing
237 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
238 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
239 -- 'InjuriesDetailListing'.
241 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
243 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
244 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
245 -- foreign key to an 'InjuriesDetailListing'.
247 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
248 InjuriesDetailListingPlayerListing {
249 db_injuries_detail_listings_id = fk,
250 db_player_id = xml_player_id,
254 db_injury = xml_injury,
255 db_status = xml_status,
256 db_fantasy = xml_fantasy,
257 db_injured = xml_injured,
260 -- | This lets us insert the XML representation
261 -- 'InjuriesDetailListingPlayerListingXml' directly.
263 instance XmlImportFk InjuriesDetailListingPlayerListingXml
270 instance DbImport Message where
273 migrate (undefined :: InjuriesDetail)
274 migrate (undefined :: InjuriesDetailListing)
275 migrate (undefined :: InjuriesDetailListingPlayerListing)
277 -- | To import a 'Message', we import all of its
278 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
279 -- out of its 'Listing's.
282 msg_id <- insert_xml msg
284 forM_ (xml_listings msg) $ \listing -> do
285 l_id <- insert_xml_fk msg_id listing
286 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
288 return ImportSucceeded
291 mkPersist tsn_codegen_config [groundhog|
292 - entity: InjuriesDetail
293 dbName: injuries_detail
295 - name: InjuriesDetail
297 - name: unique_injuries_detail
299 # Prevent multiple imports of the same message.
300 fields: [db_xml_file_id]
302 - entity: InjuriesDetailListing
303 dbName: injuries_detail_listings
305 - name: InjuriesDetailListing
307 - name: db_injuries_detail_id
311 - entity: InjuriesDetailListingPlayerListing
312 dbName: injuries_detail_listings_player_listings
314 - name: InjuriesDetailListingPlayerListing
316 - name: db_injuries_detail_listings_id
327 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
329 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
330 pickle_player_listing =
331 xpElem "PlayerListing" $
332 xpWrap (from_tuple, to_tuple) $
333 xp10Tuple (xpElem "TeamID" xpText)
334 (xpElem "PlayerID" xpInt)
335 (xpElem "Date" xp_date)
336 (xpElem "Pos" xpText)
337 (xpElem "Name" xpText)
338 (xpElem "Injury" xpText)
339 (xpElem "Status" xpText)
340 (xpElem "Fantasy" $ xpOption xpText)
341 (xpElem "Injured" xpPrim)
342 (xpElem "Type" xpText)
344 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
345 to_tuple pl = (xml_player_team_id pl,
357 -- | Convert 'Listing's to/from XML.
359 pickle_listing :: PU InjuriesDetailListingXml
362 xpWrap (from_tuple, to_tuple) $
363 xpTriple (xpElem "TeamID" xpText)
364 (xpElem "FullName" xpText)
365 (xpList pickle_player_listing)
367 from_tuple = uncurryN InjuriesDetailListingXml
368 to_tuple l = (xml_team_id l,
370 xml_player_listings l)
373 -- | Convert 'Message's to/from XML.
375 pickle_message :: PU Message
378 xpWrap (from_tuple, to_tuple) $
379 xp6Tuple (xpElem "XML_File_ID" xpInt)
380 (xpElem "heading" xpText)
381 (xpElem "category" xpText)
382 (xpElem "sport" xpText)
383 (xpList pickle_listing)
384 (xpElem "time_stamp" xp_time_stamp)
386 from_tuple = uncurryN Message
387 to_tuple m = (xml_xml_file_id m,
399 -- | A list of all tests for this module.
401 injuries_detail_tests :: TestTree
402 injuries_detail_tests =
404 "InjuriesDetail tests"
405 [ test_on_delete_cascade,
406 test_pickle_of_unpickle_is_identity,
407 test_unpickle_succeeds ]
410 -- | If we unpickle something and then pickle it, we should wind up
411 -- with the same thing we started with. WARNING: success of this
412 -- test does not mean that unpickling succeeded.
414 test_pickle_of_unpickle_is_identity :: TestTree
415 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
416 [ check "pickle composed with unpickle is the identity"
417 "test/xml/Injuries_Detail_XML.xml",
419 check "pickle composed with unpickle is the identity (non-int team_id)"
420 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
422 check desc path = testCase desc $ do
423 (expected, actual) <- pickle_unpickle pickle_message path
427 -- | Make sure we can actually unpickle these things.
429 test_unpickle_succeeds :: TestTree
430 test_unpickle_succeeds = testGroup "unpickle tests"
431 [ check "unpickling succeeds"
432 "test/xml/Injuries_Detail_XML.xml",
434 check "unpickling succeeds (non-int team_id)"
435 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
437 check desc path = testCase desc $ do
438 actual <- unpickleable path pickle_message
443 -- | Make sure everything gets deleted when we delete the top-level
446 test_on_delete_cascade :: TestTree
447 test_on_delete_cascade = testGroup "cascading delete tests"
448 [ check "delete of injuries_detail deletes its children"
449 "test/xml/Injuries_Detail_XML.xml",
451 check "delete of injuries_detail deletes its children (non-int team_id)"
452 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
454 check desc path = testCase desc $ do
455 inj <- unsafe_unpickle path pickle_message
456 let a = undefined :: InjuriesDetail
457 let b = undefined :: InjuriesDetailListing
458 let c = undefined :: InjuriesDetailListingPlayerListing
459 actual <- withSqliteConn ":memory:" $ runDbConn $ do
460 runMigration silentMigrationLogger $ do
466 count_a <- countAll a
467 count_b <- countAll b
468 count_c <- countAll c
469 return $ count_a + count_b + count_c