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, xp_tba_time, xp_time_stamp )
60 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
70 -- | The DTD to which this module corresponds. Used to invoke dbimport.
73 dtd = "Auto_Racing_Schedule_XML.dtd"
79 -- * AutoRacingSchedule/Message
81 -- | Database representation of a 'Message'.
83 data AutoRacingSchedule =
85 db_xml_file_id :: Int,
87 db_category :: String,
90 db_complete_through :: String,
91 db_time_stamp :: UTCTime }
95 -- | XML Representation of an 'AutoRacingSchedule'.
99 xml_xml_file_id :: Int,
100 xml_heading :: String,
101 xml_category :: String,
104 xml_complete_through :: String,
105 xml_listings :: [AutoRacingScheduleListingXml],
106 xml_time_stamp :: UTCTime }
110 instance ToDb Message where
111 -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
113 type Db Message = AutoRacingSchedule
116 -- | The 'FromXml' instance for 'Message' is required for the
117 -- 'XmlImport' instance.
119 instance FromXml Message where
120 -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
121 -- the 'xml_listings'.
123 from_xml Message{..} =
125 db_xml_file_id = xml_xml_file_id,
126 db_heading = xml_heading,
127 db_category = xml_category,
128 db_sport = xml_sport,
129 db_title = xml_title,
130 db_complete_through = xml_complete_through,
131 db_time_stamp = xml_time_stamp }
134 -- | This allows us to insert the XML representation 'Message'
137 instance XmlImport Message
140 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
142 -- | Database representation of a \<Listing\> contained within a
143 -- \<Message\>. We combine the race date/time into a single
144 -- race_time, drop the race results list, and add a foreign key to
147 data AutoRacingScheduleListing =
148 AutoRacingScheduleListing {
149 db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
151 db_race_time :: UTCTime,
152 db_race_name :: String,
153 db_track_name :: String,
154 db_location :: String,
155 db_tv_listing :: Maybe String,
157 db_track_length :: String -- ^ Sometimes the word "miles" shows up.
161 -- | XML representation of a \<Listing\> contained within a
164 data AutoRacingScheduleListingXml =
165 AutoRacingScheduleListingXml {
167 xml_race_date :: UTCTime,
168 xml_race_time :: Maybe UTCTime,
169 xml_race_name :: String,
170 xml_track_name :: String,
171 xml_location :: String,
172 xml_tv_listing :: Maybe String,
174 xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
175 -- so we can't do the right thing and use
177 xml_race_results :: [AutoRacingScheduleListingRaceResult] }
181 -- | Pseudo-accessor to get the race result listings out of a
182 -- 'AutoRacingScheduleListingXml'. A poor man's lens.
184 result_listings :: AutoRacingScheduleListingXml
185 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
186 result_listings = (concatMap xml_race_result_listing) . xml_race_results
189 instance ToDb AutoRacingScheduleListingXml where
190 -- | The database analogue of an 'AutoRacingScheduleListingXml' is
191 -- an 'AutoRacingScheduleListing'.
193 type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
195 instance FromXmlFk AutoRacingScheduleListingXml where
196 -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
197 -- foreign key to) a 'AutoRacingSchedule'.
199 type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
201 -- | To convert an 'AutoRacingScheduleListingXml' to an
202 -- 'AutoRacingScheduleListing', we add the foreign key and drop
203 -- the 'xml_race_results'. We also mash the date/time together
206 from_xml_fk fk AutoRacingScheduleListingXml{..} =
207 AutoRacingScheduleListing {
208 db_auto_racing_schedules_id = fk,
209 db_race_id = xml_race_id,
210 db_race_time = make_race_time xml_race_date xml_race_time,
211 db_race_name = xml_race_name,
212 db_track_name = xml_track_name,
213 db_location = xml_location,
214 db_tv_listing = xml_tv_listing,
216 db_track_length = xml_track_length }
218 -- | Make the database \"race time\" from the XML
219 -- date/time. Simply take the day part from one and the time
222 make_race_time d Nothing = d
223 make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
226 -- | This allows us to insert the XML representation
227 -- 'AutoRacingScheduleListingXml' directly.
229 instance XmlImportFk AutoRacingScheduleListingXml
233 -- * AutoRacingScheduleListingRaceResult
235 -- | The XML representation of \<message\> -> \<Listing\> ->
236 -- \<RaceResults\>. This element serves only to contain
237 -- \<RaceResultsListing\>s, so we don't store the intermediate table
240 newtype AutoRacingScheduleListingRaceResult =
241 AutoRacingScheduleListingRaceResult {
242 xml_race_result_listing ::
243 [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
247 -- * AutoRacingScheduleListingRaceResultRaceResultListing /
248 -- AutoRacingScheduleListingRaceResultRaceResultListingXml
250 -- Sorry about the names yo.
253 -- | Database representation of \<RaceResultListing\> within
254 -- \<RaceResults\> within \<Listing\> within... \<message\>!
256 data AutoRacingScheduleListingRaceResultRaceResultListing =
257 AutoRacingScheduleListingRaceResultRaceResultListing {
258 db_auto_racing_schedules_listings_id ::
259 DefaultKey AutoRacingScheduleListing,
260 db_finish_position :: Int,
263 db_leading_laps :: Int,
264 db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
265 db_earnings :: String, -- ^ This should be an Int, but can have commas.
266 db_status :: String }
269 -- | XML Representation of an
270 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
272 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
273 AutoRacingScheduleListingRaceResultRaceResultListingXml {
274 xml_finish_position :: Int,
275 xml_driver_id :: Int,
277 xml_leading_laps :: Int,
278 xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
279 xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
280 xml_status :: String }
284 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
285 -- | The database representation of an
286 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
287 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
289 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
290 AutoRacingScheduleListingRaceResultRaceResultListing
293 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
294 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
295 -- is contained in (i.e. has a foreign key to) an
296 -- 'AutoRacingScheduleListing'. We skip the intermediate
299 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
300 AutoRacingScheduleListing
303 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
304 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
305 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
307 from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
308 AutoRacingScheduleListingRaceResultRaceResultListing {
309 db_auto_racing_schedules_listings_id = fk,
310 db_finish_position = xml_finish_position,
311 db_driver_id = xml_driver_id,
313 db_leading_laps = xml_leading_laps,
314 db_listing_laps = xml_listing_laps,
315 db_earnings = xml_earnings,
316 db_status = xml_earnings }
319 -- | This allows us to insert the XML representation
320 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
323 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
330 instance DbImport Message where
333 migrate (undefined :: AutoRacingSchedule)
334 migrate (undefined :: AutoRacingScheduleListing)
336 :: AutoRacingScheduleListingRaceResultRaceResultListing)
339 -- | We insert the message, then use its ID to insert the listings,
340 -- using their IDs to insert the race result listings.
343 msg_id <- insert_xml m
345 forM_ (xml_listings m) $ \listing -> do
346 listing_id <- insert_xml_fk msg_id listing
348 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
350 return ImportSucceeded
353 mkPersist tsn_codegen_config [groundhog|
354 - entity: AutoRacingSchedule
355 dbName: auto_racing_schedules
357 - name: AutoRacingSchedule
359 - name: unique_auto_racing_schedule
361 # Prevent multiple imports of the same message.
362 fields: [db_xml_file_id]
364 - entity: AutoRacingScheduleListing
365 dbName: auto_racing_schedules_listings
367 - name: AutoRacingScheduleListing
369 - name: db_auto_racing_schedules_id
373 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
374 dbName: auto_racing_schedules_listings_race_result_listings
376 - name: AutoRacingScheduleListingRaceResultRaceResultListing
378 - name: db_auto_racing_schedules_listings_id
389 -- | Pickler for the top-level 'Message'.
391 pickle_message :: PU Message
394 xpWrap (from_tuple, to_tuple) $
395 xp8Tuple (xpElem "XML_File_ID" xpInt)
396 (xpElem "heading" xpText)
397 (xpElem "category" xpText)
398 (xpElem "sport" xpText)
399 (xpElem "Title" xpText)
400 (xpElem "Complete_Through" xpText)
401 (xpList pickle_listing)
402 (xpElem "time_stamp" xp_time_stamp)
404 from_tuple = uncurryN Message
405 to_tuple m = (xml_xml_file_id m,
410 xml_complete_through m,
415 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
417 pickle_listing :: PU AutoRacingScheduleListingXml
420 xpWrap (from_tuple, to_tuple) $
421 xp10Tuple (xpElem "RaceID" xpInt)
422 (xpElem "Race_Date" xp_date)
423 (xpElem "Race_Time" xp_tba_time)
424 (xpElem "RaceName" xpText)
425 (xpElem "TrackName" xpText)
426 (xpElem "Location" xpText)
427 (xpElem "TV_Listing" $ xpOption xpText)
428 (xpElem "Laps" xpInt)
429 (xpElem "TrackLength" xpText)
430 (xpList pickle_race_results)
432 from_tuple = uncurryN AutoRacingScheduleListingXml
433 to_tuple m = (xml_race_id m,
445 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
447 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
448 pickle_race_results =
449 xpElem "RaceResults" $
450 xpWrap (to_result, from_result) $
451 xpList pickle_race_results_listing
453 to_result = AutoRacingScheduleListingRaceResult
454 from_result = xml_race_result_listing
458 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
461 pickle_race_results_listing ::
462 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
463 pickle_race_results_listing =
464 xpElem "RaceResultsListing" $
465 xpWrap (from_tuple, to_tuple) $
466 xp7Tuple (xpElem "FinishPosition" xpInt)
467 (xpElem "DriverID" xpInt)
468 (xpElem "Name" xpText)
469 (xpElem "LeadingLaps" xpInt)
470 (xpElem "Laps" xpInt)
471 (xpElem "Earnings" xpText)
472 (xpElem "Status" xpText)
475 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
477 to_tuple m = (xml_finish_position m,
490 -- | A list of all tests for this module.
492 auto_racing_schedule_tests :: TestTree
493 auto_racing_schedule_tests =
495 "AutoRacingSchedule tests"
496 [ test_on_delete_cascade,
497 test_pickle_of_unpickle_is_identity,
498 test_unpickle_succeeds ]
500 -- | If we unpickle something and then pickle it, we should wind up
501 -- with the same thing we started with. WARNING: success of this
502 -- test does not mean that unpickling succeeded.
504 test_pickle_of_unpickle_is_identity :: TestTree
505 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
506 [ check "pickle composed with unpickle is the identity"
507 "test/xml/Auto_Racing_Schedule_XML.xml",
509 check "pickle composed with unpickle is the identity (miles track length)"
510 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
512 check desc path = testCase desc $ do
513 (expected, actual) <- pickle_unpickle pickle_message path
517 -- | Make sure we can actually unpickle these things.
519 test_unpickle_succeeds :: TestTree
520 test_unpickle_succeeds = testGroup "unpickle tests"
521 [ check "unpickling succeeds"
522 "test/xml/Auto_Racing_Schedule_XML.xml",
524 check "unpickling succeeds (non-int team_id)"
525 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
527 check desc path = testCase desc $ do
528 actual <- unpickleable path pickle_message
533 -- | Make sure everything gets deleted when we delete the top-level
536 test_on_delete_cascade :: TestTree
537 test_on_delete_cascade = testGroup "cascading delete tests"
538 [ check "deleting auto_racing_schedules deletes its children"
539 "test/xml/Auto_Racing_Schedule_XML.xml" ,
541 check ("deleting auto_racing_schedules deletes its children " ++
542 "(miles track length)")
543 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
545 check desc path = testCase desc $ do
546 sched <- unsafe_unpickle path pickle_message
547 let a = undefined :: AutoRacingSchedule
548 let b = undefined :: AutoRacingScheduleListing
549 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
551 actual <- withSqliteConn ":memory:" $ runDbConn $ do
552 runMigration silentMigrationLogger $ do
558 count_a <- countAll a
559 count_b <- countAll b
560 count_c <- countAll c
561 return $ sum [count_a, count_b, count_c]