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 qualified Data.Vector.HFixed as H (
36 import Database.Groundhog (
42 silentMigrationLogger )
43 import Database.Groundhog.Generic ( runDbConn )
44 import Database.Groundhog.Sqlite ( withSqliteConn )
45 import Database.Groundhog.TH (
48 import qualified GHC.Generics as GHC ( Generic )
49 import Test.Tasty ( TestTree, testGroup )
50 import Test.Tasty.HUnit ( (@?=), testCase )
51 import Text.XML.HXT.Core (
65 import TSN.Codegen ( tsn_codegen_config )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 import TSN.Picklers( xp_date, xp_time_stamp )
68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
83 dtd = "Injuries_Detail_XML.dtd"
91 -- * InjuriesDetail/Message
94 -- | XML representation of the top-level \<message\> element. These
95 -- are not stored; the data type is used only for parsing.
99 xml_xml_file_id :: Int,
100 xml_heading :: String,
101 xml_category :: String,
103 xml_listings :: [InjuriesDetailListingXml],
104 xml_time_stamp :: UTCTime }
105 deriving (Eq, GHC.Generic, Show)
108 -- | For 'H.convert'.
110 instance H.HVector Message
113 -- | Database representation of a 'Message'.
115 data InjuriesDetail =
117 db_xml_file_id :: Int,
119 db_time_stamp :: UTCTime }
122 instance ToDb Message where
123 -- | The database representation of a 'Message' is an
126 type Db Message = InjuriesDetail
128 instance FromXml Message where
129 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
132 from_xml Message{..} =
134 db_xml_file_id = xml_xml_file_id,
135 db_sport = xml_sport,
136 db_time_stamp = xml_time_stamp }
139 -- | This allows us to insert the XML representation 'Message'
142 instance XmlImport Message
146 -- * InjuriesDetailListing/InjuriesDetailListingXml
148 -- | Database representation of a \<Listing\> element. It has a
149 -- foreign key pointing to its parent 'InjuriesDetail', and does not
150 -- contain the list of 'xml_player_listings' (which get their own
153 data InjuriesDetailListing =
154 InjuriesDetailListing {
155 db_injuries_detail_id :: DefaultKey InjuriesDetail,
156 db_team_id :: String,
157 db_full_name :: String }
160 -- | XML incarnation of a \<Listing\> element. We don't store these;
161 -- the data type is used only for parsing.
163 data InjuriesDetailListingXml =
164 InjuriesDetailListingXml {
165 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
166 -- characters long and not necessarily
169 xml_full_name :: String, -- ^ Team full name
170 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
171 deriving (Eq, GHC.Generic, Show)
174 -- | For 'H.convert'.
176 instance H.HVector InjuriesDetailListingXml
179 instance ToDb InjuriesDetailListingXml where
180 -- | The database analogue of an 'InjuriesDetailListingXml' is a
181 -- 'InjuriesDetailListing'.
182 type Db InjuriesDetailListingXml = InjuriesDetailListing
185 instance Child InjuriesDetailListingXml where
186 -- | Each 'InjuriesDetailListingXml' is contained in an
188 type Parent InjuriesDetailListingXml = InjuriesDetail
191 instance FromXmlFk InjuriesDetailListingXml where
192 -- | Construct a 'InjuriesDetailListing' from a
193 -- 'InjuriesDetailListingXml' and a foreign key to a
196 from_xml_fk fk InjuriesDetailListingXml{..} =
197 InjuriesDetailListing {
198 db_injuries_detail_id = fk,
199 db_team_id = xml_team_id,
200 db_full_name = xml_full_name }
202 -- | This allows us to insert the XML representation
203 -- 'InjuriesDetailListingXml' directly.
205 instance XmlImportFk InjuriesDetailListingXml
208 -- * InjuriesDetailListingPlayerListing
210 -- | XML representation of a \<PlayerListing\>, the main type of
211 -- element contains in Injuries_Detail_XML messages. The leading
212 -- underscores prevent unused field warnings.
214 data InjuriesDetailListingPlayerListingXml =
215 InjuriesDetailListingPlayerListingXml {
216 _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
217 -- characters long and not
218 -- necessarily numeric. Postgres
219 -- imposes no performance penalty
220 -- on a lengthless text field, so
221 -- we ignore the likely upper
222 -- bound of three characters.
223 -- We add the \"player\" to avoid conflict
224 -- with 'InjuriesDetailListingXml'.
225 _xml_player_id :: Int,
226 _xml_date :: UTCTime,
229 _xml_injury :: String,
230 _xml_status :: String,
231 _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
232 _xml_injured :: Bool,
233 _xml_type :: String }
234 deriving (Eq, GHC.Generic, Show)
237 -- | For 'H.convert'.
239 instance H.HVector InjuriesDetailListingPlayerListingXml
242 -- | Database representation of a
243 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
244 -- because it's redundant. The leading underscores prevent unused
247 data InjuriesDetailListingPlayerListing =
248 InjuriesDetailListingPlayerListing {
249 _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
250 _db_player_id :: Int,
254 _db_injury :: String,
255 _db_status :: String,
256 _db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
259 deriving ( GHC.Generic )
261 -- | For 'H.cons', 'H.tail', etc.
263 instance H.HVector InjuriesDetailListingPlayerListing
266 instance ToDb InjuriesDetailListingPlayerListingXml where
267 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
268 -- 'InjuriesDetailListingPlayerListing'.
269 type Db InjuriesDetailListingPlayerListingXml =
270 InjuriesDetailListingPlayerListing
273 instance Child InjuriesDetailListingPlayerListingXml where
274 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
275 -- 'InjuriesDetailListing'.
277 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
280 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
281 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
282 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
283 -- foreign key to an 'InjuriesDetailListing' after dropping the
284 -- '_xml_player_team_id'.
286 -- The 'H.asCVec' trick allows type inference to proceed in the
287 -- middle of two different magics.
289 from_xml_fk fk = (H.cons fk) . H.asCVec . H.tail
292 -- | This lets us insert the XML representation
293 -- 'InjuriesDetailListingPlayerListingXml' directly.
295 instance XmlImportFk InjuriesDetailListingPlayerListingXml
302 instance DbImport Message where
305 migrate (undefined :: InjuriesDetail)
306 migrate (undefined :: InjuriesDetailListing)
307 migrate (undefined :: InjuriesDetailListingPlayerListing)
309 -- | To import a 'Message', we import all of its
310 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
311 -- out of its 'Listing's.
314 msg_id <- insert_xml msg
316 forM_ (xml_listings msg) $ \listing -> do
317 l_id <- insert_xml_fk msg_id listing
318 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
320 return ImportSucceeded
323 mkPersist tsn_codegen_config [groundhog|
324 - entity: InjuriesDetail
325 dbName: injuries_detail
327 - name: InjuriesDetail
329 - name: unique_injuries_detail
331 # Prevent multiple imports of the same message.
332 fields: [db_xml_file_id]
334 - entity: InjuriesDetailListing
335 dbName: injuries_detail_listings
337 - name: InjuriesDetailListing
339 - name: db_injuries_detail_id
343 - entity: InjuriesDetailListingPlayerListing
344 dbName: injuries_detail_listings_player_listings
346 - name: InjuriesDetailListingPlayerListing
348 - name: _db_injuries_detail_listings_id
359 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
361 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
362 pickle_player_listing =
363 xpElem "PlayerListing" $
364 xpWrap (from_tuple, H.convert) $
365 xp10Tuple (xpElem "TeamID" xpText)
366 (xpElem "PlayerID" xpInt)
367 (xpElem "Date" xp_date)
368 (xpElem "Pos" xpText)
369 (xpElem "Name" xpText)
370 (xpElem "Injury" xpText)
371 (xpElem "Status" xpText)
372 (xpElem "Fantasy" $ xpOption xpText)
373 (xpElem "Injured" xpPrim)
374 (xpElem "Type" xpText)
376 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
379 -- | Convert 'Listing's to/from XML.
381 pickle_listing :: PU InjuriesDetailListingXml
384 xpWrap (from_tuple, H.convert) $
385 xpTriple (xpElem "TeamID" xpText)
386 (xpElem "FullName" xpText)
387 (xpList pickle_player_listing)
389 from_tuple = uncurryN InjuriesDetailListingXml
392 -- | Convert 'Message's to/from XML.
394 pickle_message :: PU Message
397 xpWrap (from_tuple, H.convert) $
398 xp6Tuple (xpElem "XML_File_ID" xpInt)
399 (xpElem "heading" xpText)
400 (xpElem "category" xpText)
401 (xpElem "sport" xpText)
402 (xpList pickle_listing)
403 (xpElem "time_stamp" xp_time_stamp)
405 from_tuple = uncurryN Message
412 -- | A list of all tests for this module.
414 injuries_detail_tests :: TestTree
415 injuries_detail_tests =
417 "InjuriesDetail tests"
418 [ test_on_delete_cascade,
419 test_pickle_of_unpickle_is_identity,
420 test_unpickle_succeeds ]
423 -- | If we unpickle something and then pickle it, we should wind up
424 -- with the same thing we started with. WARNING: success of this
425 -- test does not mean that unpickling succeeded.
427 test_pickle_of_unpickle_is_identity :: TestTree
428 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
429 [ check "pickle composed with unpickle is the identity"
430 "test/xml/Injuries_Detail_XML.xml",
432 check "pickle composed with unpickle is the identity (non-int team_id)"
433 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
435 check desc path = testCase desc $ do
436 (expected, actual) <- pickle_unpickle pickle_message path
440 -- | Make sure we can actually unpickle these things.
442 test_unpickle_succeeds :: TestTree
443 test_unpickle_succeeds = testGroup "unpickle tests"
444 [ check "unpickling succeeds"
445 "test/xml/Injuries_Detail_XML.xml",
447 check "unpickling succeeds (non-int team_id)"
448 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
450 check desc path = testCase desc $ do
451 actual <- unpickleable path pickle_message
456 -- | Make sure everything gets deleted when we delete the top-level
459 test_on_delete_cascade :: TestTree
460 test_on_delete_cascade = testGroup "cascading delete tests"
461 [ check "delete of injuries_detail deletes its children"
462 "test/xml/Injuries_Detail_XML.xml",
464 check "delete of injuries_detail deletes its children (non-int team_id)"
465 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
467 check desc path = testCase desc $ do
468 inj <- unsafe_unpickle path pickle_message
469 let a = undefined :: InjuriesDetail
470 let b = undefined :: InjuriesDetailListing
471 let c = undefined :: InjuriesDetailListingPlayerListing
472 actual <- withSqliteConn ":memory:" $ runDbConn $ do
473 runMigration silentMigrationLogger $ do
479 count_a <- countAll a
480 count_b <- countAll b
481 count_c <- countAll c
482 return $ count_a + count_b + count_c