1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
10 -- document contains a root element \<message\> that in turn
11 -- contains zero or more \<Listing\>s (note: capitalization). The
12 -- \<Listing\>s contain \<PlayerListing\>s which then contain the
15 module TSN.XML.InjuriesDetail (
19 injuries_detail_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 InjuriesDetailConstructor(..),
22 InjuriesDetailListingConstructor(..),
23 InjuriesDetailListingPlayerListingConstructor(..) )
27 import Control.Monad ( forM_ )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
36 silentMigrationLogger )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import qualified GHC.Generics as GHC ( Generic )
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
59 import Generics ( Generic(..), to_tuple )
60 import TSN.Codegen ( tsn_codegen_config )
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Picklers( xp_date, xp_time_stamp )
63 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
75 -- | The DTD to which this module corresponds. Used to invoke dbimport.
78 dtd = "Injuries_Detail_XML.dtd"
86 -- * InjuriesDetail/Message
89 -- | XML representation of the top-level \<message\> element. These
90 -- are not stored; the data type is used only for parsing.
94 xml_xml_file_id :: Int,
95 xml_heading :: String,
96 xml_category :: String,
98 xml_listings :: [InjuriesDetailListingXml],
99 xml_time_stamp :: UTCTime }
100 deriving (Eq, GHC.Generic, Show)
103 -- | For 'Generics.to_tuple'.
105 instance Generic Message
108 -- | Database representation of a 'Message'.
110 data InjuriesDetail =
112 db_xml_file_id :: Int,
114 db_time_stamp :: UTCTime }
117 instance ToDb Message where
118 -- | The database representation of a 'Message' is an
121 type Db Message = InjuriesDetail
123 instance FromXml Message where
124 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
127 from_xml Message{..} =
129 db_xml_file_id = xml_xml_file_id,
130 db_sport = xml_sport,
131 db_time_stamp = xml_time_stamp }
134 -- | This allows us to insert the XML representation 'Message'
137 instance XmlImport Message
141 -- * InjuriesDetailListing/InjuriesDetailListingXml
143 -- | Database representation of a \<Listing\> element. It has a
144 -- foreign key pointing to its parent 'InjuriesDetail', and does not
145 -- contain the list of 'xml_player_listings' (which get their own
148 data InjuriesDetailListing =
149 InjuriesDetailListing {
150 db_injuries_detail_id :: DefaultKey InjuriesDetail,
151 db_team_id :: String,
152 db_full_name :: String }
155 -- | XML incarnation of a \<Listing\> element. We don't store these;
156 -- the data type is used only for parsing.
158 data InjuriesDetailListingXml =
159 InjuriesDetailListingXml {
160 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
161 -- characters long and not necessarily
164 xml_full_name :: String, -- ^ Team full name
165 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
166 deriving (Eq, GHC.Generic, Show)
169 -- | For 'Generics.to_tuple'.
171 instance Generic InjuriesDetailListingXml
174 instance ToDb InjuriesDetailListingXml where
175 -- | The database analogue of an 'InjuriesDetailListingXml' is a
176 -- 'InjuriesDetailListing'.
177 type Db InjuriesDetailListingXml = InjuriesDetailListing
180 instance Child InjuriesDetailListingXml where
181 -- | Each 'InjuriesDetailListingXml' is contained in an
183 type Parent InjuriesDetailListingXml = InjuriesDetail
186 instance FromXmlFk InjuriesDetailListingXml where
187 -- | Construct a 'InjuriesDetailListing' from a
188 -- 'InjuriesDetailListingXml' and a foreign key to a
191 from_xml_fk fk InjuriesDetailListingXml{..} =
192 InjuriesDetailListing {
193 db_injuries_detail_id = fk,
194 db_team_id = xml_team_id,
195 db_full_name = xml_full_name }
197 -- | This allows us to insert the XML representation
198 -- 'InjuriesDetailListingXml' directly.
200 instance XmlImportFk InjuriesDetailListingXml
203 -- * InjuriesDetailListingPlayerListing
205 -- | XML representation of a \<PlayerListing\>, the main type of
206 -- element contains in Injuries_Detail_XML messages.
208 data InjuriesDetailListingPlayerListingXml =
209 InjuriesDetailListingPlayerListingXml {
210 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
211 -- characters long and not
212 -- necessarily numeric. Postgres
213 -- imposes no performance penalty
214 -- on a lengthless text field, so
215 -- we ignore the likely upper
216 -- bound of three characters.
217 -- We add the \"player\" to avoid conflict
218 -- with 'InjuriesDetailListingXml'.
219 xml_player_id :: Int,
223 xml_injury :: String,
224 xml_status :: String,
225 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
228 deriving (Eq, GHC.Generic, Show)
231 -- | For 'Generics.to_tuple'.
233 instance Generic InjuriesDetailListingPlayerListingXml
236 -- | Database representation of a
237 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
238 -- because it's redundant.
240 data InjuriesDetailListingPlayerListing =
241 InjuriesDetailListingPlayerListing {
242 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
249 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
254 instance ToDb InjuriesDetailListingPlayerListingXml where
255 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
256 -- 'InjuriesDetailListingPlayerListing'.
257 type Db InjuriesDetailListingPlayerListingXml =
258 InjuriesDetailListingPlayerListing
261 instance Child InjuriesDetailListingPlayerListingXml where
262 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
263 -- 'InjuriesDetailListing'.
265 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
268 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
269 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
270 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
271 -- foreign key to an 'InjuriesDetailListing'.
273 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
274 InjuriesDetailListingPlayerListing {
275 db_injuries_detail_listings_id = fk,
276 db_player_id = xml_player_id,
280 db_injury = xml_injury,
281 db_status = xml_status,
282 db_fantasy = xml_fantasy,
283 db_injured = xml_injured,
286 -- | This lets us insert the XML representation
287 -- 'InjuriesDetailListingPlayerListingXml' directly.
289 instance XmlImportFk InjuriesDetailListingPlayerListingXml
296 instance DbImport Message where
299 migrate (undefined :: InjuriesDetail)
300 migrate (undefined :: InjuriesDetailListing)
301 migrate (undefined :: InjuriesDetailListingPlayerListing)
303 -- | To import a 'Message', we import all of its
304 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
305 -- out of its 'Listing's.
308 msg_id <- insert_xml msg
310 forM_ (xml_listings msg) $ \listing -> do
311 l_id <- insert_xml_fk msg_id listing
312 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
314 return ImportSucceeded
317 mkPersist tsn_codegen_config [groundhog|
318 - entity: InjuriesDetail
319 dbName: injuries_detail
321 - name: InjuriesDetail
323 - name: unique_injuries_detail
325 # Prevent multiple imports of the same message.
326 fields: [db_xml_file_id]
328 - entity: InjuriesDetailListing
329 dbName: injuries_detail_listings
331 - name: InjuriesDetailListing
333 - name: db_injuries_detail_id
337 - entity: InjuriesDetailListingPlayerListing
338 dbName: injuries_detail_listings_player_listings
340 - name: InjuriesDetailListingPlayerListing
342 - name: db_injuries_detail_listings_id
353 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
355 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
356 pickle_player_listing =
357 xpElem "PlayerListing" $
358 xpWrap (from_tuple, to_tuple) $
359 xp10Tuple (xpElem "TeamID" xpText)
360 (xpElem "PlayerID" xpInt)
361 (xpElem "Date" xp_date)
362 (xpElem "Pos" xpText)
363 (xpElem "Name" xpText)
364 (xpElem "Injury" xpText)
365 (xpElem "Status" xpText)
366 (xpElem "Fantasy" $ xpOption xpText)
367 (xpElem "Injured" xpPrim)
368 (xpElem "Type" xpText)
370 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
373 -- | Convert 'Listing's to/from XML.
375 pickle_listing :: PU InjuriesDetailListingXml
378 xpWrap (from_tuple, to_tuple) $
379 xpTriple (xpElem "TeamID" xpText)
380 (xpElem "FullName" xpText)
381 (xpList pickle_player_listing)
383 from_tuple = uncurryN InjuriesDetailListingXml
386 -- | Convert 'Message's to/from XML.
388 pickle_message :: PU Message
391 xpWrap (from_tuple, to_tuple) $
392 xp6Tuple (xpElem "XML_File_ID" xpInt)
393 (xpElem "heading" xpText)
394 (xpElem "category" xpText)
395 (xpElem "sport" xpText)
396 (xpList pickle_listing)
397 (xpElem "time_stamp" xp_time_stamp)
399 from_tuple = uncurryN Message
406 -- | A list of all tests for this module.
408 injuries_detail_tests :: TestTree
409 injuries_detail_tests =
411 "InjuriesDetail tests"
412 [ test_on_delete_cascade,
413 test_pickle_of_unpickle_is_identity,
414 test_unpickle_succeeds ]
417 -- | If we unpickle something and then pickle it, we should wind up
418 -- with the same thing we started with. WARNING: success of this
419 -- test does not mean that unpickling succeeded.
421 test_pickle_of_unpickle_is_identity :: TestTree
422 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
423 [ check "pickle composed with unpickle is the identity"
424 "test/xml/Injuries_Detail_XML.xml",
426 check "pickle composed with unpickle is the identity (non-int team_id)"
427 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
429 check desc path = testCase desc $ do
430 (expected, actual) <- pickle_unpickle pickle_message path
434 -- | Make sure we can actually unpickle these things.
436 test_unpickle_succeeds :: TestTree
437 test_unpickle_succeeds = testGroup "unpickle tests"
438 [ check "unpickling succeeds"
439 "test/xml/Injuries_Detail_XML.xml",
441 check "unpickling succeeds (non-int team_id)"
442 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
444 check desc path = testCase desc $ do
445 actual <- unpickleable path pickle_message
450 -- | Make sure everything gets deleted when we delete the top-level
453 test_on_delete_cascade :: TestTree
454 test_on_delete_cascade = testGroup "cascading delete tests"
455 [ check "delete of injuries_detail deletes its children"
456 "test/xml/Injuries_Detail_XML.xml",
458 check "delete of injuries_detail deletes its children (non-int team_id)"
459 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
461 check desc path = testCase desc $ do
462 inj <- unsafe_unpickle path pickle_message
463 let a = undefined :: InjuriesDetail
464 let b = undefined :: InjuriesDetailListing
465 let c = undefined :: InjuriesDetailListingPlayerListing
466 actual <- withSqliteConn ":memory:" $ runDbConn $ do
467 runMigration silentMigrationLogger $ do
473 count_a <- countAll a
474 count_b <- countAll b
475 count_c <- countAll c
476 return $ count_a + count_b + count_c