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'.
89 db_time_stamp :: UTCTime }
92 instance ToDb Message where
93 -- | The database representation of a 'Message' is an
95 type Db Message = InjuriesDetail
97 instance FromXml Message where
98 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
101 from_xml Message{..} =
103 db_sport = xml_sport,
104 db_time_stamp = xml_time_stamp }
107 -- | This allows us to call 'insert_xml' directly on the XML
109 instance XmlImport Message
113 -- * InjuriesDetailListing/InjuriesDetailListingXml
115 data InjuriesDetailListing =
116 InjuriesDetailListing {
117 db_injuries_detail_id :: DefaultKey InjuriesDetail,
118 db_team_id :: String,
119 db_full_name :: String }
122 -- | XML incarnation of a \<Listing\> element. We don't store these;
123 -- the data type is used only for parsing.
125 data InjuriesDetailListingXml =
126 InjuriesDetailListingXml {
127 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
128 -- characters long and not necessarily
131 xml_full_name :: String, -- ^ Team full name
132 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
135 instance ToDb InjuriesDetailListingXml where
136 type Db InjuriesDetailListingXml = InjuriesDetailListing
138 instance FromXmlFk InjuriesDetailListingXml where
139 type Parent InjuriesDetailListingXml = InjuriesDetail
141 from_xml_fk fk InjuriesDetailListingXml{..} =
142 InjuriesDetailListing {
143 db_injuries_detail_id = fk,
144 db_team_id = xml_team_id,
145 db_full_name = xml_full_name }
147 instance XmlImportFk InjuriesDetailListingXml
150 -- * InjuriesDetailListingPlayerListing
152 -- | XML representation of a \<PlayerListing\>, the main type of
153 -- element contains in Injuries_Detail_XML messages.
155 data InjuriesDetailListingPlayerListingXml =
156 InjuriesDetailListingPlayerListingXml {
157 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
158 -- characters long and not
159 -- necessarily numeric. Postgres
160 -- imposes no performance penalty
161 -- on a lengthless text field, so
162 -- we ignore the likely upper
163 -- bound of three characters.
164 -- We add the \"player\" to avoid conflict
165 -- with 'InjuriesDetailListingXml'.
166 xml_player_id :: Int,
170 xml_injury :: String,
171 xml_status :: String,
172 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
179 -- | Database representation of a
180 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
181 -- because it's redundant.
183 data InjuriesDetailListingPlayerListing =
184 InjuriesDetailListingPlayerListing {
185 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
192 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
197 instance ToDb InjuriesDetailListingPlayerListingXml where
198 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
199 -- 'InjuriesDetailListingPlayerListing'.
200 type Db InjuriesDetailListingPlayerListingXml =
201 InjuriesDetailListingPlayerListing
203 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
204 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
206 -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
207 -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
208 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
209 InjuriesDetailListingPlayerListing {
210 db_injuries_detail_listings_id = fk,
211 db_player_id = xml_player_id,
215 db_injury = xml_injury,
216 db_status = xml_status,
217 db_fantasy = xml_fantasy,
218 db_injured = xml_injured,
221 -- | This lets us call 'insert_xml' on a
222 -- 'InjuriesDetailListingPlayerListingXml' without having to
223 -- explicitly convert it to its database analogue first.
225 instance XmlImportFk InjuriesDetailListingPlayerListingXml
232 instance DbImport Message where
233 -- | To import a 'Message', we import all of its
234 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
237 msg_id <- insert_xml msg
239 forM_ (xml_listings msg) $ \listing -> do
240 l_id <- insert_xml_fk msg_id listing
241 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
243 return ImportSucceeded
247 migrate (undefined :: InjuriesDetail)
248 migrate (undefined :: InjuriesDetailListing)
249 migrate (undefined :: InjuriesDetailListingPlayerListing)
252 mkPersist tsn_codegen_config [groundhog|
253 - entity: InjuriesDetail
254 dbName: injuries_detail
256 - entity: InjuriesDetailListing
257 dbName: injuries_detail_listings
259 - name: InjuriesDetailListing
261 - name: db_injuries_detail_id
265 - entity: InjuriesDetailListingPlayerListing
266 dbName: injuries_detail_listings_player_listings
268 - name: InjuriesDetailListingPlayerListing
270 - name: db_injuries_detail_listings_id
281 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
283 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
284 pickle_player_listing =
285 xpElem "PlayerListing" $
286 xpWrap (from_tuple, to_tuple) $
287 xp10Tuple (xpElem "TeamID" xpText)
288 (xpElem "PlayerID" xpInt)
289 (xpElem "Date" xp_date)
290 (xpElem "Pos" xpText)
291 (xpElem "Name" xpText)
292 (xpElem "Injury" xpText)
293 (xpElem "Status" xpText)
294 (xpElem "Fantasy" $ xpOption xpText)
295 (xpElem "Injured" xpPrim)
296 (xpElem "Type" xpText)
298 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
299 to_tuple pl = (xml_player_team_id pl,
311 -- | Convert 'Listing's to/from XML.
313 pickle_listing :: PU InjuriesDetailListingXml
316 xpWrap (from_tuple, to_tuple) $
317 xpTriple (xpElem "TeamID" xpText)
318 (xpElem "FullName" xpText)
319 (xpList pickle_player_listing)
321 from_tuple = uncurryN InjuriesDetailListingXml
322 to_tuple l = (xml_team_id l,
324 xml_player_listings l)
327 -- | Convert 'Message's to/from XML.
329 pickle_message :: PU Message
332 xpWrap (from_tuple, to_tuple) $
333 xp6Tuple (xpElem "XML_File_ID" xpInt)
334 (xpElem "heading" xpText)
335 (xpElem "category" xpText)
336 (xpElem "sport" xpText)
337 (xpList pickle_listing)
338 (xpElem "time_stamp" xp_time_stamp)
340 from_tuple = uncurryN Message
341 to_tuple m = (xml_xml_file_id m,
353 -- | A list of all tests for this module.
355 injuries_detail_tests :: TestTree
356 injuries_detail_tests =
358 "InjuriesDetail tests"
359 [ test_pickle_of_unpickle_is_identity,
360 test_unpickle_succeeds ]
363 -- | If we unpickle something and then pickle it, we should wind up
364 -- with the same thing we started with. WARNING: success of this
365 -- test does not mean that unpickling succeeded.
367 test_pickle_of_unpickle_is_identity :: TestTree
368 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
369 [ check "pickle composed with unpickle is the identity"
370 "test/xml/Injuries_Detail_XML.xml",
372 check "pickle composed with unpickle is the identity (non-int team_id)"
373 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
375 check desc path = testCase desc $ do
376 (expected, actual) <- pickle_unpickle pickle_message path
380 -- | Make sure we can actually unpickle these things.
382 test_unpickle_succeeds :: TestTree
383 test_unpickle_succeeds = testGroup "unpickle tests"
384 [ check "unpickling succeeds"
385 "test/xml/Injuries_Detail_XML.xml",
387 check "unpickling succeeds (non-int team_id)"
388 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
390 check desc path = testCase desc $ do
391 actual <- unpickleable path pickle_message