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 ( HVector, cons, convert, tail )
31 import qualified Data.Vector.HFixed.Cont as H (ContVec)
32 import Database.Groundhog (
38 silentMigrationLogger )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
44 import qualified GHC.Generics as GHC ( Generic )
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.XML.HXT.Core (
61 import TSN.Codegen ( tsn_codegen_config )
62 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
63 import TSN.Picklers( xp_date, xp_time_stamp )
64 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
79 dtd = "Injuries_Detail_XML.dtd"
87 -- * InjuriesDetail/Message
90 -- | XML representation of the top-level \<message\> element. These
91 -- are not stored; the data type is used only for parsing.
95 xml_xml_file_id :: Int,
96 xml_heading :: String,
97 xml_category :: String,
99 xml_listings :: [InjuriesDetailListingXml],
100 xml_time_stamp :: UTCTime }
101 deriving (Eq, GHC.Generic, Show)
104 -- | For 'H.convert'.
106 instance H.HVector Message
109 -- | Database representation of a 'Message'.
111 data InjuriesDetail =
113 db_xml_file_id :: Int,
115 db_time_stamp :: UTCTime }
118 instance ToDb Message where
119 -- | The database representation of a 'Message' is an
122 type Db Message = InjuriesDetail
124 instance FromXml Message where
125 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
128 from_xml Message{..} =
130 db_xml_file_id = xml_xml_file_id,
131 db_sport = xml_sport,
132 db_time_stamp = xml_time_stamp }
135 -- | This allows us to insert the XML representation 'Message'
138 instance XmlImport Message
142 -- * InjuriesDetailListing/InjuriesDetailListingXml
144 -- | Database representation of a \<Listing\> element. It has a
145 -- foreign key pointing to its parent 'InjuriesDetail', and does not
146 -- contain the list of 'xml_player_listings' (which get their own
149 data InjuriesDetailListing =
150 InjuriesDetailListing {
151 db_injuries_detail_id :: DefaultKey InjuriesDetail,
152 db_team_id :: String,
153 db_full_name :: String }
156 -- | XML incarnation of a \<Listing\> element. We don't store these;
157 -- the data type is used only for parsing.
159 data InjuriesDetailListingXml =
160 InjuriesDetailListingXml {
161 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
162 -- characters long and not necessarily
165 xml_full_name :: String, -- ^ Team full name
166 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
167 deriving (Eq, GHC.Generic, Show)
170 -- | For 'H.convert'.
172 instance H.HVector InjuriesDetailListingXml
175 instance ToDb InjuriesDetailListingXml where
176 -- | The database analogue of an 'InjuriesDetailListingXml' is a
177 -- 'InjuriesDetailListing'.
178 type Db InjuriesDetailListingXml = InjuriesDetailListing
181 instance Child InjuriesDetailListingXml where
182 -- | Each 'InjuriesDetailListingXml' is contained in an
184 type Parent InjuriesDetailListingXml = InjuriesDetail
187 instance FromXmlFk InjuriesDetailListingXml where
188 -- | Construct a 'InjuriesDetailListing' from a
189 -- 'InjuriesDetailListingXml' and a foreign key to a
192 from_xml_fk fk InjuriesDetailListingXml{..} =
193 InjuriesDetailListing {
194 db_injuries_detail_id = fk,
195 db_team_id = xml_team_id,
196 db_full_name = xml_full_name }
198 -- | This allows us to insert the XML representation
199 -- 'InjuriesDetailListingXml' directly.
201 instance XmlImportFk InjuriesDetailListingXml
204 -- * InjuriesDetailListingPlayerListing
206 -- | XML representation of a \<PlayerListing\>, the main type of
207 -- element contains in Injuries_Detail_XML messages. The leading
208 -- underscores prevent unused field warnings.
210 data InjuriesDetailListingPlayerListingXml =
211 InjuriesDetailListingPlayerListingXml {
212 _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
213 -- characters long and not
214 -- necessarily numeric. Postgres
215 -- imposes no performance penalty
216 -- on a lengthless text field, so
217 -- we ignore the likely upper
218 -- bound of three characters.
219 -- We add the \"player\" to avoid conflict
220 -- with 'InjuriesDetailListingXml'.
221 _xml_player_id :: Int,
222 _xml_date :: UTCTime,
225 _xml_injury :: String,
226 _xml_status :: String,
227 _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
228 _xml_injured :: Bool,
229 _xml_type :: String }
230 deriving (Eq, GHC.Generic, Show)
233 -- | For 'H.convert'.
235 instance H.HVector InjuriesDetailListingPlayerListingXml
238 -- | Database representation of a
239 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
240 -- because it's redundant. The leading underscores prevent unused
243 data InjuriesDetailListingPlayerListing =
244 InjuriesDetailListingPlayerListing {
245 _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
246 _db_player_id :: Int,
250 _db_injury :: String,
251 _db_status :: String,
252 _db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
255 deriving ( GHC.Generic )
257 -- | For 'H.cons', 'H.tail', etc.
259 instance H.HVector InjuriesDetailListingPlayerListing
262 instance ToDb InjuriesDetailListingPlayerListingXml where
263 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
264 -- 'InjuriesDetailListingPlayerListing'.
265 type Db InjuriesDetailListingPlayerListingXml =
266 InjuriesDetailListingPlayerListing
269 instance Child InjuriesDetailListingPlayerListingXml where
270 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
271 -- 'InjuriesDetailListing'.
273 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
276 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
277 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
278 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
279 -- foreign key to an 'InjuriesDetailListing'.
281 from_xml_fk fk = (H.cons fk) . asCont . H.tail
283 -- Should be in the library soon.
284 asCont :: H.ContVec a -> H.ContVec a
288 -- | This lets us insert the XML representation
289 -- 'InjuriesDetailListingPlayerListingXml' directly.
291 instance XmlImportFk InjuriesDetailListingPlayerListingXml
298 instance DbImport Message where
301 migrate (undefined :: InjuriesDetail)
302 migrate (undefined :: InjuriesDetailListing)
303 migrate (undefined :: InjuriesDetailListingPlayerListing)
305 -- | To import a 'Message', we import all of its
306 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
307 -- out of its 'Listing's.
310 msg_id <- insert_xml msg
312 forM_ (xml_listings msg) $ \listing -> do
313 l_id <- insert_xml_fk msg_id listing
314 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
316 return ImportSucceeded
319 mkPersist tsn_codegen_config [groundhog|
320 - entity: InjuriesDetail
321 dbName: injuries_detail
323 - name: InjuriesDetail
325 - name: unique_injuries_detail
327 # Prevent multiple imports of the same message.
328 fields: [db_xml_file_id]
330 - entity: InjuriesDetailListing
331 dbName: injuries_detail_listings
333 - name: InjuriesDetailListing
335 - name: db_injuries_detail_id
339 - entity: InjuriesDetailListingPlayerListing
340 dbName: injuries_detail_listings_player_listings
342 - name: InjuriesDetailListingPlayerListing
344 - name: _db_injuries_detail_listings_id
355 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
357 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
358 pickle_player_listing =
359 xpElem "PlayerListing" $
360 xpWrap (from_tuple, H.convert) $
361 xp10Tuple (xpElem "TeamID" xpText)
362 (xpElem "PlayerID" xpInt)
363 (xpElem "Date" xp_date)
364 (xpElem "Pos" xpText)
365 (xpElem "Name" xpText)
366 (xpElem "Injury" xpText)
367 (xpElem "Status" xpText)
368 (xpElem "Fantasy" $ xpOption xpText)
369 (xpElem "Injured" xpPrim)
370 (xpElem "Type" xpText)
372 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
375 -- | Convert 'Listing's to/from XML.
377 pickle_listing :: PU InjuriesDetailListingXml
380 xpWrap (from_tuple, H.convert) $
381 xpTriple (xpElem "TeamID" xpText)
382 (xpElem "FullName" xpText)
383 (xpList pickle_player_listing)
385 from_tuple = uncurryN InjuriesDetailListingXml
388 -- | Convert 'Message's to/from XML.
390 pickle_message :: PU Message
393 xpWrap (from_tuple, H.convert) $
394 xp6Tuple (xpElem "XML_File_ID" xpInt)
395 (xpElem "heading" xpText)
396 (xpElem "category" xpText)
397 (xpElem "sport" xpText)
398 (xpList pickle_listing)
399 (xpElem "time_stamp" xp_time_stamp)
401 from_tuple = uncurryN Message
408 -- | A list of all tests for this module.
410 injuries_detail_tests :: TestTree
411 injuries_detail_tests =
413 "InjuriesDetail tests"
414 [ test_on_delete_cascade,
415 test_pickle_of_unpickle_is_identity,
416 test_unpickle_succeeds ]
419 -- | If we unpickle something and then pickle it, we should wind up
420 -- with the same thing we started with. WARNING: success of this
421 -- test does not mean that unpickling succeeded.
423 test_pickle_of_unpickle_is_identity :: TestTree
424 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
425 [ check "pickle composed with unpickle is the identity"
426 "test/xml/Injuries_Detail_XML.xml",
428 check "pickle composed with unpickle is the identity (non-int team_id)"
429 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
431 check desc path = testCase desc $ do
432 (expected, actual) <- pickle_unpickle pickle_message path
436 -- | Make sure we can actually unpickle these things.
438 test_unpickle_succeeds :: TestTree
439 test_unpickle_succeeds = testGroup "unpickle tests"
440 [ check "unpickling succeeds"
441 "test/xml/Injuries_Detail_XML.xml",
443 check "unpickling succeeds (non-int team_id)"
444 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
446 check desc path = testCase desc $ do
447 actual <- unpickleable path pickle_message
452 -- | Make sure everything gets deleted when we delete the top-level
455 test_on_delete_cascade :: TestTree
456 test_on_delete_cascade = testGroup "cascading delete tests"
457 [ check "delete of injuries_detail deletes its children"
458 "test/xml/Injuries_Detail_XML.xml",
460 check "delete of injuries_detail deletes its children (non-int team_id)"
461 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
463 check desc path = testCase desc $ do
464 inj <- unsafe_unpickle path pickle_message
465 let a = undefined :: InjuriesDetail
466 let b = undefined :: InjuriesDetailListing
467 let c = undefined :: InjuriesDetailListingPlayerListing
468 actual <- withSqliteConn ":memory:" $ runDbConn $ do
469 runMigration silentMigrationLogger $ do
475 count_a <- countAll a
476 count_b <- countAll b
477 count_c <- countAll c
478 return $ count_a + count_b + count_c