1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE StandaloneDeriving #-}
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 (
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 (
32 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
51 import TSN.Codegen ( tsn_codegen_config )
52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
53 import TSN.Picklers( xp_date, xp_time_stamp )
54 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
68 -- * InjuriesDetail/Message
71 -- | XML representation of the top-level \<message\> element. These
72 -- are not stored; the data type is used only for parsing.
76 xml_xml_file_id :: Int,
77 xml_heading :: String,
78 xml_category :: String,
80 xml_listings :: [InjuriesDetailListingXml],
81 xml_time_stamp :: UTCTime }
84 -- | Database representation of a 'Message'.
88 db_xml_file_id :: Int,
90 db_time_stamp :: UTCTime }
93 instance ToDb Message where
94 -- | The database representation of a 'Message' is an
97 type Db Message = InjuriesDetail
99 instance FromXml Message where
100 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
103 from_xml Message{..} =
105 db_xml_file_id = xml_xml_file_id,
106 db_sport = xml_sport,
107 db_time_stamp = xml_time_stamp }
110 -- | This allows us to insert the XML representation 'Message'
113 instance XmlImport Message
117 -- * InjuriesDetailListing/InjuriesDetailListingXml
119 -- | Database representation of a \<Listing\> element. It has a
120 -- foreign key pointing to its parent 'InjuriesDetail', and does not
121 -- contain the list of 'xml_player_listings' (which get their own
124 data InjuriesDetailListing =
125 InjuriesDetailListing {
126 db_injuries_detail_id :: DefaultKey InjuriesDetail,
127 db_team_id :: String,
128 db_full_name :: String }
131 -- | XML incarnation of a \<Listing\> element. We don't store these;
132 -- the data type is used only for parsing.
134 data InjuriesDetailListingXml =
135 InjuriesDetailListingXml {
136 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
137 -- characters long and not necessarily
140 xml_full_name :: String, -- ^ Team full name
141 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
144 instance ToDb InjuriesDetailListingXml where
145 -- | The database analogue of an 'InjuriesDetailListingXml' is a
146 -- 'InjuriesDetailListing'.
147 type Db InjuriesDetailListingXml = InjuriesDetailListing
149 instance FromXmlFk InjuriesDetailListingXml where
150 -- | Each 'InjuriesDetailListingXml' is contained in an
152 type Parent InjuriesDetailListingXml = InjuriesDetail
154 -- | Construct a 'InjuriesDetailListing' from a
155 -- 'InjuriesDetailListingXml' and a foreign key to a
158 from_xml_fk fk InjuriesDetailListingXml{..} =
159 InjuriesDetailListing {
160 db_injuries_detail_id = fk,
161 db_team_id = xml_team_id,
162 db_full_name = xml_full_name }
164 -- | This allows us to insert the XML representation
165 -- 'InjuriesDetailListingXml' directly.
167 instance XmlImportFk InjuriesDetailListingXml
170 -- * InjuriesDetailListingPlayerListing
172 -- | XML representation of a \<PlayerListing\>, the main type of
173 -- element contains in Injuries_Detail_XML messages.
175 data InjuriesDetailListingPlayerListingXml =
176 InjuriesDetailListingPlayerListingXml {
177 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
178 -- characters long and not
179 -- necessarily numeric. Postgres
180 -- imposes no performance penalty
181 -- on a lengthless text field, so
182 -- we ignore the likely upper
183 -- bound of three characters.
184 -- We add the \"player\" to avoid conflict
185 -- with 'InjuriesDetailListingXml'.
186 xml_player_id :: Int,
190 xml_injury :: String,
191 xml_status :: String,
192 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
199 -- | Database representation of a
200 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
201 -- because it's redundant.
203 data InjuriesDetailListingPlayerListing =
204 InjuriesDetailListingPlayerListing {
205 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
212 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
217 instance ToDb InjuriesDetailListingPlayerListingXml where
218 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
219 -- 'InjuriesDetailListingPlayerListing'.
220 type Db InjuriesDetailListingPlayerListingXml =
221 InjuriesDetailListingPlayerListing
223 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
224 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
225 -- 'InjuriesDetailListing'.
227 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
229 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
230 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
231 -- foreign key to an 'InjuriesDetailListing'.
233 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
234 InjuriesDetailListingPlayerListing {
235 db_injuries_detail_listings_id = fk,
236 db_player_id = xml_player_id,
240 db_injury = xml_injury,
241 db_status = xml_status,
242 db_fantasy = xml_fantasy,
243 db_injured = xml_injured,
246 -- | This lets us insert the XML representation
247 -- 'InjuriesDetailListingPlayerListingXml' directly.
249 instance XmlImportFk InjuriesDetailListingPlayerListingXml
256 instance DbImport Message where
259 migrate (undefined :: InjuriesDetail)
260 migrate (undefined :: InjuriesDetailListing)
261 migrate (undefined :: InjuriesDetailListingPlayerListing)
263 -- | To import a 'Message', we import all of its
264 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
265 -- out of its 'Listing's.
268 msg_id <- insert_xml msg
270 forM_ (xml_listings msg) $ \listing -> do
271 l_id <- insert_xml_fk msg_id listing
272 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
274 return ImportSucceeded
277 mkPersist tsn_codegen_config [groundhog|
278 - entity: InjuriesDetail
279 dbName: injuries_detail
281 - name: InjuriesDetail
283 - name: unique_injuries_detail
285 # Prevent multiple imports of the same message.
286 fields: [db_xml_file_id]
288 - entity: InjuriesDetailListing
289 dbName: injuries_detail_listings
291 - name: InjuriesDetailListing
293 - name: db_injuries_detail_id
297 - entity: InjuriesDetailListingPlayerListing
298 dbName: injuries_detail_listings_player_listings
300 - name: InjuriesDetailListingPlayerListing
302 - name: db_injuries_detail_listings_id
313 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
315 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
316 pickle_player_listing =
317 xpElem "PlayerListing" $
318 xpWrap (from_tuple, to_tuple) $
319 xp10Tuple (xpElem "TeamID" xpText)
320 (xpElem "PlayerID" xpInt)
321 (xpElem "Date" xp_date)
322 (xpElem "Pos" xpText)
323 (xpElem "Name" xpText)
324 (xpElem "Injury" xpText)
325 (xpElem "Status" xpText)
326 (xpElem "Fantasy" $ xpOption xpText)
327 (xpElem "Injured" xpPrim)
328 (xpElem "Type" xpText)
330 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
331 to_tuple pl = (xml_player_team_id pl,
343 -- | Convert 'Listing's to/from XML.
345 pickle_listing :: PU InjuriesDetailListingXml
348 xpWrap (from_tuple, to_tuple) $
349 xpTriple (xpElem "TeamID" xpText)
350 (xpElem "FullName" xpText)
351 (xpList pickle_player_listing)
353 from_tuple = uncurryN InjuriesDetailListingXml
354 to_tuple l = (xml_team_id l,
356 xml_player_listings l)
359 -- | Convert 'Message's to/from XML.
361 pickle_message :: PU Message
364 xpWrap (from_tuple, to_tuple) $
365 xp6Tuple (xpElem "XML_File_ID" xpInt)
366 (xpElem "heading" xpText)
367 (xpElem "category" xpText)
368 (xpElem "sport" xpText)
369 (xpList pickle_listing)
370 (xpElem "time_stamp" xp_time_stamp)
372 from_tuple = uncurryN Message
373 to_tuple m = (xml_xml_file_id m,
385 -- | A list of all tests for this module.
387 injuries_detail_tests :: TestTree
388 injuries_detail_tests =
390 "InjuriesDetail tests"
391 [ test_pickle_of_unpickle_is_identity,
392 test_unpickle_succeeds ]
395 -- | If we unpickle something and then pickle it, we should wind up
396 -- with the same thing we started with. WARNING: success of this
397 -- test does not mean that unpickling succeeded.
399 test_pickle_of_unpickle_is_identity :: TestTree
400 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
401 [ check "pickle composed with unpickle is the identity"
402 "test/xml/Injuries_Detail_XML.xml",
404 check "pickle composed with unpickle is the identity (non-int team_id)"
405 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
407 check desc path = testCase desc $ do
408 (expected, actual) <- pickle_unpickle pickle_message path
412 -- | Make sure we can actually unpickle these things.
414 test_unpickle_succeeds :: TestTree
415 test_unpickle_succeeds = testGroup "unpickle tests"
416 [ check "unpickling succeeds"
417 "test/xml/Injuries_Detail_XML.xml",
419 check "unpickling succeeds (non-int team_id)"
420 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
422 check desc path = testCase desc $ do
423 actual <- unpickleable path pickle_message