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(..) )
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 / AutoRacingScheduleListingRaceResultRaceResultListingXml
249 -- Sorry about the names yo.
252 -- | Database representation of \<RaceResultListing\> within
253 -- \<RaceResults\> within \<Listing\> within... \<message\>!
255 data AutoRacingScheduleListingRaceResultRaceResultListing =
256 AutoRacingScheduleListingRaceResultRaceResultListing {
257 db_auto_racing_schedules_listings_id ::
258 DefaultKey AutoRacingScheduleListing,
259 db_finish_position :: Int,
262 db_leading_laps :: Int,
263 db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
264 db_earnings :: String, -- ^ This should be an Int, but can have commas.
265 db_status :: String }
268 -- | XML Representation of an
269 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
271 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
272 AutoRacingScheduleListingRaceResultRaceResultListingXml {
273 xml_finish_position :: Int,
274 xml_driver_id :: Int,
276 xml_leading_laps :: Int,
277 xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
278 xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
279 xml_status :: String }
283 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
284 -- | The database representation of an
285 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
286 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
288 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
289 AutoRacingScheduleListingRaceResultRaceResultListing
292 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
293 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
294 -- is contained in (i.e. has a foreign key to) an
295 -- 'AutoRacingScheduleListing'. We skip the intermediate
298 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
299 AutoRacingScheduleListing
302 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
303 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
304 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
306 from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
307 AutoRacingScheduleListingRaceResultRaceResultListing {
308 db_auto_racing_schedules_listings_id = fk,
309 db_finish_position = xml_finish_position,
310 db_driver_id = xml_driver_id,
312 db_leading_laps = xml_leading_laps,
313 db_listing_laps = xml_listing_laps,
314 db_earnings = xml_earnings,
315 db_status = xml_earnings }
318 -- | This allows us to insert the XML representation
319 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
322 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
329 instance DbImport Message where
332 migrate (undefined :: AutoRacingSchedule)
333 migrate (undefined :: AutoRacingScheduleListing)
335 :: AutoRacingScheduleListingRaceResultRaceResultListing)
338 -- | We insert the message, then use its ID to insert the listings,
339 -- using their IDs to insert the race result listings.
342 msg_id <- insert_xml m
344 forM_ (xml_listings m) $ \listing -> do
345 listing_id <- insert_xml_fk msg_id listing
347 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
349 return ImportSucceeded
352 mkPersist tsn_codegen_config [groundhog|
353 - entity: AutoRacingSchedule
354 dbName: auto_racing_schedules
356 - name: AutoRacingSchedule
358 - name: unique_auto_racing_schedule
360 # Prevent multiple imports of the same message.
361 fields: [db_xml_file_id]
363 - entity: AutoRacingScheduleListing
364 dbName: auto_racing_schedules_listings
366 - name: AutoRacingScheduleListing
368 - name: db_auto_racing_schedules_id
372 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
373 dbName: auto_racing_schedules_listings_race_result_listings
375 - name: AutoRacingScheduleListingRaceResultRaceResultListing
377 - name: db_auto_racing_schedules_listings_id
388 -- | Pickler for the top-level 'Message'.
390 pickle_message :: PU Message
393 xpWrap (from_tuple, to_tuple) $
394 xp8Tuple (xpElem "XML_File_ID" xpInt)
395 (xpElem "heading" xpText)
396 (xpElem "category" xpText)
397 (xpElem "sport" xpText)
398 (xpElem "Title" xpText)
399 (xpElem "Complete_Through" xpText)
400 (xpList pickle_listing)
401 (xpElem "time_stamp" xp_time_stamp)
403 from_tuple = uncurryN Message
404 to_tuple m = (xml_xml_file_id m,
409 xml_complete_through m,
414 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
416 pickle_listing :: PU AutoRacingScheduleListingXml
419 xpWrap (from_tuple, to_tuple) $
420 xp10Tuple (xpElem "RaceID" xpInt)
421 (xpElem "Race_Date" xp_date_padded)
422 (xpElem "Race_Time" xp_tba_time)
423 (xpElem "RaceName" xpText)
424 (xpElem "TrackName" xpText)
425 (xpElem "Location" xpText)
426 (xpElem "TV_Listing" $ xpOption xpText)
427 (xpElem "Laps" xpInt)
428 (xpElem "TrackLength" xpText)
429 (xpList pickle_race_results)
431 from_tuple = uncurryN AutoRacingScheduleListingXml
432 to_tuple m = (xml_race_id m,
444 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
446 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
447 pickle_race_results =
448 xpElem "RaceResults" $
449 xpWrap (to_result, from_result) $
450 xpList pickle_race_results_listing
452 to_result = AutoRacingScheduleListingRaceResult
453 from_result = xml_race_result_listing
457 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
460 pickle_race_results_listing ::
461 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
462 pickle_race_results_listing =
463 xpElem "RaceResultsListing" $
464 xpWrap (from_tuple, to_tuple) $
465 xp7Tuple (xpElem "FinishPosition" xpInt)
466 (xpElem "DriverID" xpInt)
467 (xpElem "Name" xpText)
468 (xpElem "LeadingLaps" xpInt)
469 (xpElem "Laps" xpInt)
470 (xpElem "Earnings" xpText)
471 (xpElem "Status" xpText)
474 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
476 to_tuple m = (xml_finish_position m,
489 -- | A list of all tests for this module.
491 auto_racing_schedule_tests :: TestTree
492 auto_racing_schedule_tests =
494 "AutoRacingSchedule tests"
495 [ test_on_delete_cascade,
496 test_pickle_of_unpickle_is_identity,
497 test_unpickle_succeeds ]
499 -- | If we unpickle something and then pickle it, we should wind up
500 -- with the same thing we started with. WARNING: success of this
501 -- test does not mean that unpickling succeeded.
503 test_pickle_of_unpickle_is_identity :: TestTree
504 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
505 [ check "pickle composed with unpickle is the identity"
506 "test/xml/Auto_Racing_Schedule_XML.xml",
508 check "pickle composed with unpickle is the identity (miles track length)"
509 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
511 check desc path = testCase desc $ do
512 (expected, actual) <- pickle_unpickle pickle_message path
516 -- | Make sure we can actually unpickle these things.
518 test_unpickle_succeeds :: TestTree
519 test_unpickle_succeeds = testGroup "unpickle tests"
520 [ check "unpickling succeeds"
521 "test/xml/Auto_Racing_Schedule_XML.xml",
523 check "unpickling succeeds (non-int team_id)"
524 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
526 check desc path = testCase desc $ do
527 actual <- unpickleable path pickle_message
532 -- | Make sure everything gets deleted when we delete the top-level
535 test_on_delete_cascade :: TestTree
536 test_on_delete_cascade = testGroup "cascading delete tests"
537 [ check "deleting auto_racing_schedules deletes its children"
538 "test/xml/Auto_Racing_Schedule_XML.xml" ,
540 check ("deleting auto_racing_schedules deletes its children " ++
541 "(miles track length)")
542 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
544 check desc path = testCase desc $ do
545 sched <- unsafe_unpickle path pickle_message
546 let a = undefined :: AutoRacingSchedule
547 let b = undefined :: AutoRacingScheduleListing
548 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
550 actual <- withSqliteConn ":memory:" $ runDbConn $ do
551 runMigration silentMigrationLogger $ do
557 count_a <- countAll a
558 count_b <- countAll b
559 count_c <- countAll c
560 return $ sum [count_a, count_b, count_c]