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
96 type Db Message = InjuriesDetail
98 instance FromXml Message where
99 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
102 from_xml Message{..} =
104 db_xml_file_id = xml_xml_file_id,
105 db_sport = xml_sport,
106 db_time_stamp = xml_time_stamp }
109 -- | This allows us to call 'insert_xml' directly on the XML
111 instance XmlImport Message
115 -- * InjuriesDetailListing/InjuriesDetailListingXml
117 -- | Database representation of an InjuriesDetailListing. It has a
118 -- foreign key pointing to its parent 'InjuriesDetail', and does not
119 -- contain the list of 'xml_player_listings' (which get their own
122 data InjuriesDetailListing =
123 InjuriesDetailListing {
124 db_injuries_detail_id :: DefaultKey InjuriesDetail,
125 db_team_id :: String,
126 db_full_name :: String }
129 -- | XML incarnation of a \<Listing\> element. We don't store these;
130 -- the data type is used only for parsing.
132 data InjuriesDetailListingXml =
133 InjuriesDetailListingXml {
134 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
135 -- characters long and not necessarily
138 xml_full_name :: String, -- ^ Team full name
139 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
142 instance ToDb InjuriesDetailListingXml where
143 -- | The database analogue of an 'InjuriesDetailListingXml' is a
144 -- 'InjuriesDetailListing'.
145 type Db InjuriesDetailListingXml = InjuriesDetailListing
147 instance FromXmlFk InjuriesDetailListingXml where
148 type Parent InjuriesDetailListingXml = InjuriesDetail
150 -- | Construct a 'InjuriesDetailListing' from a
151 -- 'InjuriesDetailListingXml' and a foreign key to a
154 from_xml_fk fk InjuriesDetailListingXml{..} =
155 InjuriesDetailListing {
156 db_injuries_detail_id = fk,
157 db_team_id = xml_team_id,
158 db_full_name = xml_full_name }
160 instance XmlImportFk InjuriesDetailListingXml
163 -- * InjuriesDetailListingPlayerListing
165 -- | XML representation of a \<PlayerListing\>, the main type of
166 -- element contains in Injuries_Detail_XML messages.
168 data InjuriesDetailListingPlayerListingXml =
169 InjuriesDetailListingPlayerListingXml {
170 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
171 -- characters long and not
172 -- necessarily numeric. Postgres
173 -- imposes no performance penalty
174 -- on a lengthless text field, so
175 -- we ignore the likely upper
176 -- bound of three characters.
177 -- We add the \"player\" to avoid conflict
178 -- with 'InjuriesDetailListingXml'.
179 xml_player_id :: Int,
183 xml_injury :: String,
184 xml_status :: String,
185 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
192 -- | Database representation of a
193 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
194 -- because it's redundant.
196 data InjuriesDetailListingPlayerListing =
197 InjuriesDetailListingPlayerListing {
198 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
205 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
210 instance ToDb InjuriesDetailListingPlayerListingXml where
211 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
212 -- 'InjuriesDetailListingPlayerListing'.
213 type Db InjuriesDetailListingPlayerListingXml =
214 InjuriesDetailListingPlayerListing
216 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
217 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
219 -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
220 -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
221 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
222 InjuriesDetailListingPlayerListing {
223 db_injuries_detail_listings_id = fk,
224 db_player_id = xml_player_id,
228 db_injury = xml_injury,
229 db_status = xml_status,
230 db_fantasy = xml_fantasy,
231 db_injured = xml_injured,
234 -- | This lets us call 'insert_xml' on a
235 -- 'InjuriesDetailListingPlayerListingXml' without having to
236 -- explicitly convert it to its database analogue first.
238 instance XmlImportFk InjuriesDetailListingPlayerListingXml
245 instance DbImport Message where
246 -- | To import a 'Message', we import all of its
247 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
250 msg_id <- insert_xml msg
252 forM_ (xml_listings msg) $ \listing -> do
253 l_id <- insert_xml_fk msg_id listing
254 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
256 return ImportSucceeded
260 migrate (undefined :: InjuriesDetail)
261 migrate (undefined :: InjuriesDetailListing)
262 migrate (undefined :: InjuriesDetailListingPlayerListing)
265 mkPersist tsn_codegen_config [groundhog|
266 - entity: InjuriesDetail
267 dbName: injuries_detail
269 - name: InjuriesDetail
271 - name: unique_injuries_detail
273 # Prevent multiple imports of the same message.
274 fields: [db_xml_file_id]
276 - entity: InjuriesDetailListing
277 dbName: injuries_detail_listings
279 - name: InjuriesDetailListing
281 - name: db_injuries_detail_id
285 - entity: InjuriesDetailListingPlayerListing
286 dbName: injuries_detail_listings_player_listings
288 - name: InjuriesDetailListingPlayerListing
290 - name: db_injuries_detail_listings_id
301 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
303 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
304 pickle_player_listing =
305 xpElem "PlayerListing" $
306 xpWrap (from_tuple, to_tuple) $
307 xp10Tuple (xpElem "TeamID" xpText)
308 (xpElem "PlayerID" xpInt)
309 (xpElem "Date" xp_date)
310 (xpElem "Pos" xpText)
311 (xpElem "Name" xpText)
312 (xpElem "Injury" xpText)
313 (xpElem "Status" xpText)
314 (xpElem "Fantasy" $ xpOption xpText)
315 (xpElem "Injured" xpPrim)
316 (xpElem "Type" xpText)
318 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
319 to_tuple pl = (xml_player_team_id pl,
331 -- | Convert 'Listing's to/from XML.
333 pickle_listing :: PU InjuriesDetailListingXml
336 xpWrap (from_tuple, to_tuple) $
337 xpTriple (xpElem "TeamID" xpText)
338 (xpElem "FullName" xpText)
339 (xpList pickle_player_listing)
341 from_tuple = uncurryN InjuriesDetailListingXml
342 to_tuple l = (xml_team_id l,
344 xml_player_listings l)
347 -- | Convert 'Message's to/from XML.
349 pickle_message :: PU Message
352 xpWrap (from_tuple, to_tuple) $
353 xp6Tuple (xpElem "XML_File_ID" xpInt)
354 (xpElem "heading" xpText)
355 (xpElem "category" xpText)
356 (xpElem "sport" xpText)
357 (xpList pickle_listing)
358 (xpElem "time_stamp" xp_time_stamp)
360 from_tuple = uncurryN Message
361 to_tuple m = (xml_xml_file_id m,
373 -- | A list of all tests for this module.
375 injuries_detail_tests :: TestTree
376 injuries_detail_tests =
378 "InjuriesDetail tests"
379 [ test_pickle_of_unpickle_is_identity,
380 test_unpickle_succeeds ]
383 -- | If we unpickle something and then pickle it, we should wind up
384 -- with the same thing we started with. WARNING: success of this
385 -- test does not mean that unpickling succeeded.
387 test_pickle_of_unpickle_is_identity :: TestTree
388 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
389 [ check "pickle composed with unpickle is the identity"
390 "test/xml/Injuries_Detail_XML.xml",
392 check "pickle composed with unpickle is the identity (non-int team_id)"
393 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
395 check desc path = testCase desc $ do
396 (expected, actual) <- pickle_unpickle pickle_message path
400 -- | Make sure we can actually unpickle these things.
402 test_unpickle_succeeds :: TestTree
403 test_unpickle_succeeds = testGroup "unpickle tests"
404 [ check "unpickling succeeds"
405 "test/xml/Injuries_Detail_XML.xml",
407 check "unpickling succeeds (non-int team_id)"
408 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
410 check desc path = testCase desc $ do
411 actual <- unpickleable path pickle_message