1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD
10 -- \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
11 -- \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
12 -- containing \<RaceResultsListing\>s.
14 module TSN.XML.AutoRacingSchedule (
18 auto_racing_schedule_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 AutoRacingScheduleConstructor(..),
21 AutoRacingScheduleListingConstructor(..),
22 AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
34 silentMigrationLogger )
35 import Database.Groundhog.Core ( DefaultKey )
36 import Database.Groundhog.Generic ( runDbConn )
37 import Database.Groundhog.Sqlite ( withSqliteConn )
38 import Database.Groundhog.TH (
41 import Test.Tasty ( TestTree, testGroup )
42 import Test.Tasty.HUnit ( (@?=), testCase )
43 import Text.XML.HXT.Core (
58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
59 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
60 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
74 dtd = "Auto_Racing_Schedule_XML.dtd"
80 -- * AutoRacingSchedule/Message
82 -- | Database representation of a 'Message'.
84 data AutoRacingSchedule =
86 db_xml_file_id :: Int,
88 db_category :: String,
91 db_complete_through :: String,
92 db_time_stamp :: UTCTime }
96 -- | XML Representation of an 'AutoRacingSchedule'.
100 xml_xml_file_id :: Int,
101 xml_heading :: String,
102 xml_category :: String,
105 xml_complete_through :: String,
106 xml_listings :: [AutoRacingScheduleListingXml],
107 xml_time_stamp :: UTCTime }
111 instance ToDb Message where
112 -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
114 type Db Message = AutoRacingSchedule
117 -- | The 'FromXml' instance for 'Message' is required for the
118 -- 'XmlImport' instance.
120 instance FromXml Message where
121 -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
122 -- the 'xml_listings'.
124 from_xml Message{..} =
126 db_xml_file_id = xml_xml_file_id,
127 db_heading = xml_heading,
128 db_category = xml_category,
129 db_sport = xml_sport,
130 db_title = xml_title,
131 db_complete_through = xml_complete_through,
132 db_time_stamp = xml_time_stamp }
135 -- | This allows us to insert the XML representation 'Message'
138 instance XmlImport Message
141 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
143 -- | Database representation of a \<Listing\> contained within a
144 -- \<message\>. We combine the race date/time into a single
145 -- race_time, drop the race results list, and add a foreign key to
148 data AutoRacingScheduleListing =
149 AutoRacingScheduleListing {
150 db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
152 db_race_time :: UTCTime,
153 db_race_name :: String,
154 db_track_name :: String,
155 db_location :: String,
156 db_tv_listing :: Maybe String,
158 db_track_length :: String -- ^ Sometimes the word "miles" shows up.
162 -- | XML representation of a \<Listing\> contained within a
165 data AutoRacingScheduleListingXml =
166 AutoRacingScheduleListingXml {
168 xml_race_date :: UTCTime,
169 xml_race_time :: Maybe UTCTime,
170 xml_race_name :: String,
171 xml_track_name :: String,
172 xml_location :: String,
173 xml_tv_listing :: Maybe String,
175 xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
176 -- so we can't do the right thing and use
178 xml_race_results :: [AutoRacingScheduleListingRaceResult] }
182 -- | Pseudo-accessor to get the race result listings out of a
183 -- 'AutoRacingScheduleListingXml'. A poor man's lens.
185 result_listings :: AutoRacingScheduleListingXml
186 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
187 result_listings = (concatMap xml_race_result_listing) . xml_race_results
190 instance ToDb AutoRacingScheduleListingXml where
191 -- | The database analogue of an 'AutoRacingScheduleListingXml' is
192 -- an 'AutoRacingScheduleListing'.
194 type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
197 instance Child AutoRacingScheduleListingXml where
198 -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
199 -- foreign key to) a 'AutoRacingSchedule'.
201 type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
204 instance FromXmlFk AutoRacingScheduleListingXml where
205 -- | To convert an 'AutoRacingScheduleListingXml' to an
206 -- 'AutoRacingScheduleListing', we add the foreign key and drop
207 -- the 'xml_race_results'. We also mash the date/time together
210 from_xml_fk fk AutoRacingScheduleListingXml{..} =
211 AutoRacingScheduleListing {
212 db_auto_racing_schedules_id = fk,
213 db_race_id = xml_race_id,
214 db_race_time = make_race_time xml_race_date xml_race_time,
215 db_race_name = xml_race_name,
216 db_track_name = xml_track_name,
217 db_location = xml_location,
218 db_tv_listing = xml_tv_listing,
220 db_track_length = xml_track_length }
222 -- | Make the database \"race time\" from the XML
223 -- date/time. Simply take the day part from one and the time
226 make_race_time d Nothing = d
227 make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
230 -- | This allows us to insert the XML representation
231 -- 'AutoRacingScheduleListingXml' directly.
233 instance XmlImportFk AutoRacingScheduleListingXml
237 -- * AutoRacingScheduleListingRaceResult
239 -- | The XML representation of \<message\> -> \<Listing\> ->
240 -- \<RaceResults\>. This element serves only to contain
241 -- \<RaceResultsListing\>s, so we don't store the intermediate table
244 newtype AutoRacingScheduleListingRaceResult =
245 AutoRacingScheduleListingRaceResult {
246 xml_race_result_listing ::
247 [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
251 -- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml
253 -- Sorry about the names yo.
256 -- | Database representation of \<RaceResultListing\> within
257 -- \<RaceResults\> within \<Listing\> within... \<message\>!
259 data AutoRacingScheduleListingRaceResultRaceResultListing =
260 AutoRacingScheduleListingRaceResultRaceResultListing {
261 db_auto_racing_schedules_listings_id ::
262 DefaultKey AutoRacingScheduleListing,
263 db_finish_position :: Int,
266 db_leading_laps :: Int,
267 db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
268 db_earnings :: String, -- ^ This should be an Int, but can have commas.
269 db_status :: String }
272 -- | XML Representation of an
273 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
275 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
276 AutoRacingScheduleListingRaceResultRaceResultListingXml {
277 xml_finish_position :: Int,
278 xml_driver_id :: Int,
280 xml_leading_laps :: Int,
281 xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
282 xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
283 xml_status :: String }
287 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
288 -- | The database representation of an
289 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
290 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
292 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
293 AutoRacingScheduleListingRaceResultRaceResultListing
296 instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where
297 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
298 -- is contained in (i.e. has a foreign key to) an
299 -- 'AutoRacingScheduleListing'. We skip the intermediate
302 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
303 AutoRacingScheduleListing
306 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
308 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
309 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
310 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
312 from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
313 AutoRacingScheduleListingRaceResultRaceResultListing {
314 db_auto_racing_schedules_listings_id = fk,
315 db_finish_position = xml_finish_position,
316 db_driver_id = xml_driver_id,
318 db_leading_laps = xml_leading_laps,
319 db_listing_laps = xml_listing_laps,
320 db_earnings = xml_earnings,
321 db_status = xml_earnings }
324 -- | This allows us to insert the XML representation
325 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
328 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
335 instance DbImport Message where
338 migrate (undefined :: AutoRacingSchedule)
339 migrate (undefined :: AutoRacingScheduleListing)
341 :: AutoRacingScheduleListingRaceResultRaceResultListing)
344 -- | We insert the message, then use its ID to insert the listings,
345 -- using their IDs to insert the race result listings.
348 msg_id <- insert_xml m
350 forM_ (xml_listings m) $ \listing -> do
351 listing_id <- insert_xml_fk msg_id listing
353 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
355 return ImportSucceeded
358 mkPersist tsn_codegen_config [groundhog|
359 - entity: AutoRacingSchedule
360 dbName: auto_racing_schedules
362 - name: AutoRacingSchedule
364 - name: unique_auto_racing_schedule
366 # Prevent multiple imports of the same message.
367 fields: [db_xml_file_id]
369 - entity: AutoRacingScheduleListing
370 dbName: auto_racing_schedules_listings
372 - name: AutoRacingScheduleListing
374 - name: db_auto_racing_schedules_id
378 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
379 dbName: auto_racing_schedules_listings_race_result_listings
381 - name: AutoRacingScheduleListingRaceResultRaceResultListing
383 - name: db_auto_racing_schedules_listings_id
394 -- | Pickler for the top-level 'Message'.
396 pickle_message :: PU Message
399 xpWrap (from_tuple, to_tuple) $
400 xp8Tuple (xpElem "XML_File_ID" xpInt)
401 (xpElem "heading" xpText)
402 (xpElem "category" xpText)
403 (xpElem "sport" xpText)
404 (xpElem "Title" xpText)
405 (xpElem "Complete_Through" xpText)
406 (xpList pickle_listing)
407 (xpElem "time_stamp" xp_time_stamp)
409 from_tuple = uncurryN Message
410 to_tuple m = (xml_xml_file_id m,
415 xml_complete_through m,
420 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
422 pickle_listing :: PU AutoRacingScheduleListingXml
425 xpWrap (from_tuple, to_tuple) $
426 xp10Tuple (xpElem "RaceID" xpInt)
427 (xpElem "Race_Date" xp_date_padded)
428 (xpElem "Race_Time" xp_tba_time)
429 (xpElem "RaceName" xpText)
430 (xpElem "TrackName" xpText)
431 (xpElem "Location" xpText)
432 (xpElem "TV_Listing" $ xpOption xpText)
433 (xpElem "Laps" xpInt)
434 (xpElem "TrackLength" xpText)
435 (xpList pickle_race_results)
437 from_tuple = uncurryN AutoRacingScheduleListingXml
438 to_tuple m = (xml_race_id m,
450 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
452 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
453 pickle_race_results =
454 xpElem "RaceResults" $
455 xpWrap (to_result, from_result) $
456 xpList pickle_race_results_listing
458 to_result = AutoRacingScheduleListingRaceResult
459 from_result = xml_race_result_listing
463 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
466 pickle_race_results_listing ::
467 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
468 pickle_race_results_listing =
469 xpElem "RaceResultsListing" $
470 xpWrap (from_tuple, to_tuple) $
471 xp7Tuple (xpElem "FinishPosition" xpInt)
472 (xpElem "DriverID" xpInt)
473 (xpElem "Name" xpText)
474 (xpElem "LeadingLaps" xpInt)
475 (xpElem "Laps" xpInt)
476 (xpElem "Earnings" xpText)
477 (xpElem "Status" xpText)
480 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
482 to_tuple m = (xml_finish_position m,
495 -- | A list of all tests for this module.
497 auto_racing_schedule_tests :: TestTree
498 auto_racing_schedule_tests =
500 "AutoRacingSchedule tests"
501 [ test_on_delete_cascade,
502 test_pickle_of_unpickle_is_identity,
503 test_unpickle_succeeds ]
505 -- | If we unpickle something and then pickle it, we should wind up
506 -- with the same thing we started with. WARNING: success of this
507 -- test does not mean that unpickling succeeded.
509 test_pickle_of_unpickle_is_identity :: TestTree
510 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
511 [ check "pickle composed with unpickle is the identity"
512 "test/xml/Auto_Racing_Schedule_XML.xml",
514 check "pickle composed with unpickle is the identity (miles track length)"
515 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
517 check desc path = testCase desc $ do
518 (expected, actual) <- pickle_unpickle pickle_message path
522 -- | Make sure we can actually unpickle these things.
524 test_unpickle_succeeds :: TestTree
525 test_unpickle_succeeds = testGroup "unpickle tests"
526 [ check "unpickling succeeds"
527 "test/xml/Auto_Racing_Schedule_XML.xml",
529 check "unpickling succeeds (non-int team_id)"
530 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
532 check desc path = testCase desc $ do
533 actual <- unpickleable path pickle_message
538 -- | Make sure everything gets deleted when we delete the top-level
541 test_on_delete_cascade :: TestTree
542 test_on_delete_cascade = testGroup "cascading delete tests"
543 [ check "deleting auto_racing_schedules deletes its children"
544 "test/xml/Auto_Racing_Schedule_XML.xml" ,
546 check ("deleting auto_racing_schedules deletes its children " ++
547 "(miles track length)")
548 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
550 check desc path = testCase desc $ do
551 sched <- unsafe_unpickle path pickle_message
552 let a = undefined :: AutoRacingSchedule
553 let b = undefined :: AutoRacingScheduleListing
554 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
556 actual <- withSqliteConn ":memory:" $ runDbConn $ do
557 runMigration silentMigrationLogger $ do
563 count_a <- countAll a
564 count_b <- countAll b
565 count_c <- countAll c
566 return $ sum [count_a, count_b, count_c]