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 \"AutoRacingResultsXML.dtd\". Each
10 -- \<message\> element contains a \<Race_Information\> and a bunch of
13 module TSN.XML.AutoRacingResults (
17 auto_racing_results_tests,
18 -- * WARNING: these are private but exported to silence warnings
19 AutoRacingResultsConstructor(..),
20 AutoRacingResultsListingConstructor(..),
21 AutoRacingResultsRaceInformationConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Data ( Data )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import Data.Typeable ( Typeable )
30 import Database.Groundhog (
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
62 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
63 import TSN.Picklers ( xp_earnings, xp_datetime, xp_time_stamp )
64 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
74 -- | The DTD to which this module corresponds. Used to invoke dbimport.
77 dtd = "AutoRacingResultsXML.dtd"
83 -- * AutoRacingResults/Message
85 -- | Database representation of a 'Message'. Comparatively, it lacks
86 -- the listings and race information since they are linked via a
89 data AutoRacingResults =
91 db_xml_file_id :: Int,
93 db_category :: String,
96 db_race_date :: UTCTime,
98 db_track_location :: String,
99 db_laps_remaining :: Int,
100 db_checkered_flag :: Bool,
101 db_time_stamp :: UTCTime }
106 -- | XML Representation of an 'AutoRacingResults'. It has the same
107 -- fields, but in addition contains the 'xml_listings' and
108 -- 'xml_race_information'.
112 xml_xml_file_id :: Int,
113 xml_heading :: String,
114 xml_category :: String,
117 xml_race_date :: UTCTime,
119 xml_track_location :: String,
120 xml_laps_remaining :: Int,
121 xml_checkered_flag :: Bool,
122 xml_listings :: [AutoRacingResultsListingXml],
123 xml_race_information :: AutoRacingResultsRaceInformationXml,
124 xml_time_stamp :: UTCTime }
128 instance ToDb Message where
129 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
131 type Db Message = AutoRacingResults
134 -- | The 'FromXml' instance for 'Message' is required for the
135 -- 'XmlImport' instance.
137 instance FromXml Message where
138 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
139 -- the 'xml_listings' and 'xml_race_information'.
141 from_xml Message{..} =
143 db_xml_file_id = xml_xml_file_id,
144 db_heading = xml_heading,
145 db_category = xml_category,
146 db_sport = xml_sport,
147 db_race_id = xml_race_id,
148 db_race_date = xml_race_date,
149 db_title = xml_title,
150 db_track_location = xml_track_location,
151 db_laps_remaining = xml_laps_remaining,
152 db_checkered_flag = xml_checkered_flag,
153 db_time_stamp = xml_time_stamp }
156 -- | This allows us to insert the XML representation 'Message'
159 instance XmlImport Message
162 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
164 -- | Database representation of a \<Listing\> contained within a
167 data AutoRacingResultsListing =
168 AutoRacingResultsListing {
169 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
170 db_finish_position :: Int,
171 db_starting_position :: Int,
172 db_car_number :: Int,
175 db_car_make :: String,
177 db_laps_completed :: Int,
178 db_laps_leading :: Int,
179 db_status :: Maybe String,
180 db_dnf :: Maybe Bool,
182 db_earnings :: Maybe Int }
185 -- | XML representation of a \<Listing\> contained within a
188 data AutoRacingResultsListingXml =
189 AutoRacingResultsListingXml {
190 xml_finish_position :: Int,
191 xml_starting_position :: Int,
192 xml_car_number :: Int,
193 xml_driver_id :: Int,
194 xml_driver :: String,
195 xml_car_make :: String,
197 xml_laps_completed :: Int,
198 xml_laps_leading :: Int,
199 xml_status :: Maybe String,
200 xml_dnf :: Maybe Bool,
201 xml_nc :: Maybe Bool,
202 xml_earnings :: Maybe Int }
206 instance ToDb AutoRacingResultsListingXml where
207 -- | The database analogue of an 'AutoRacingResultsListingXml' is
208 -- an 'AutoRacingResultsListing'.
210 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
213 instance FromXmlFk AutoRacingResultsListingXml where
214 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
215 -- foreign key to) a 'AutoRacingResults'.
217 type Parent AutoRacingResultsListingXml = AutoRacingResults
219 -- | To convert an 'AutoRacingResultsListingXml' to an
220 -- 'AutoRacingResultsListing', we add the foreign key and copy
221 -- everything else verbatim.
223 from_xml_fk fk AutoRacingResultsListingXml{..} =
224 AutoRacingResultsListing {
225 db_auto_racing_results_id = fk,
226 db_finish_position = xml_finish_position,
227 db_starting_position = xml_starting_position,
228 db_car_number = xml_car_number,
229 db_driver_id = xml_driver_id,
230 db_driver = xml_driver,
231 db_car_make = xml_car_make,
232 db_points = xml_points,
233 db_laps_completed = xml_laps_completed,
234 db_laps_leading = xml_laps_leading,
235 db_status = xml_status,
238 db_earnings = xml_earnings }
241 -- | This allows us to insert the XML representation
242 -- 'AutoRacingResultsListingXml' directly.
244 instance XmlImportFk AutoRacingResultsListingXml
248 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
250 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
251 -- contains exactly three fields, so we just embed those three into
252 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
253 -- the \"db_\" prefix since our field namer is going to strip of
254 -- everything before the first underscore.
256 data MostLapsLeading =
258 db_most_laps_leading_driver_id :: Int,
259 db_most_laps_leading_driver :: String,
260 db_most_laps_leading_number_of_laps :: Int }
261 deriving (Data, Eq, Show, Typeable)
264 -- | Database representation of a \<Race_Information\> contained within a
267 data AutoRacingResultsRaceInformation =
268 AutoRacingResultsRaceInformation {
269 -- Note the apostrophe to disambiguate it from the
270 -- AutoRacingResultsListing field.
271 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
272 db_track_length :: Double,
273 db_track_length_kph :: Double,
275 db_average_speed_mph :: Maybe Double,
276 db_average_speed_kph :: Maybe Double,
277 db_average_speed :: Maybe Double,
278 db_time_of_race :: Maybe String,
279 db_margin_of_victory :: Maybe String,
280 db_cautions :: Maybe String,
281 db_lead_changes :: Maybe String,
282 db_lap_leaders :: Maybe String,
283 db_most_laps_leading :: MostLapsLeading }
286 -- | XML representation of a \<Listing\> contained within a
289 data AutoRacingResultsRaceInformationXml =
290 AutoRacingResultsRaceInformationXml {
291 xml_track_length :: Double,
292 xml_track_length_kph :: Double,
294 xml_average_speed_mph :: Maybe Double,
295 xml_average_speed_kph :: Maybe Double,
296 xml_average_speed :: Maybe Double,
297 xml_time_of_race :: Maybe String,
298 xml_margin_of_victory :: Maybe String,
299 xml_cautions :: Maybe String,
300 xml_lead_changes :: Maybe String,
301 xml_lap_leaders :: Maybe String,
302 xml_most_laps_leading :: MostLapsLeading }
306 instance ToDb AutoRacingResultsRaceInformationXml where
307 -- | The database analogue of an
308 -- 'AutoRacingResultsRaceInformationXml' is an
309 -- 'AutoRacingResultsRaceInformation'.
311 type Db AutoRacingResultsRaceInformationXml =
312 AutoRacingResultsRaceInformation
314 instance FromXmlFk AutoRacingResultsRaceInformationXml where
315 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
316 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
318 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
320 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
321 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
322 -- copy everything else verbatim.
324 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
325 AutoRacingResultsRaceInformation {
326 db_auto_racing_results_id' = fk,
327 db_track_length = xml_track_length,
328 db_track_length_kph = xml_track_length_kph,
330 db_average_speed_mph = xml_average_speed_mph,
331 db_average_speed_kph = xml_average_speed_kph,
332 db_average_speed = xml_average_speed,
333 db_time_of_race = xml_time_of_race,
334 db_margin_of_victory = xml_margin_of_victory,
335 db_cautions = xml_cautions,
336 db_lead_changes = xml_lead_changes,
337 db_lap_leaders = xml_lap_leaders,
338 db_most_laps_leading = xml_most_laps_leading }
341 -- | This allows us to insert the XML representation
342 -- 'AutoRacingResultsRaceInformationXml' directly.
344 instance XmlImportFk AutoRacingResultsRaceInformationXml
352 instance DbImport Message where
355 migrate (undefined :: AutoRacingResults)
356 migrate (undefined :: AutoRacingResultsListing)
357 migrate (undefined :: AutoRacingResultsRaceInformation)
359 -- | We insert the message, then use its ID to insert the listings
360 -- and race information.
362 msg_id <- insert_xml m
364 insert_xml_fk_ msg_id (xml_race_information m)
366 forM_ (xml_listings m) $ \listing -> do
367 insert_xml_fk_ msg_id listing
369 return ImportSucceeded
373 mkPersist tsn_codegen_config [groundhog|
374 - entity: AutoRacingResults
375 dbName: auto_racing_results
377 - name: AutoRacingResults
379 - name: unique_auto_racing_schedule
381 # Prevent multiple imports of the same message.
382 fields: [db_xml_file_id]
385 - entity: AutoRacingResultsListing
386 dbName: auto_racing_results_listings
388 - name: AutoRacingResultsListing
390 - name: db_auto_racing_results_id
394 # Note the apostrophe in the foreign key. This is to disambiguate
395 # it from the AutoRacingResultsListing foreign key of the same name.
396 # We strip it out of the dbName.
397 - entity: AutoRacingResultsRaceInformation
398 dbName: auto_racing_results_race_information
400 - name: AutoRacingResultsRaceInformation
402 - name: db_auto_racing_results_id'
403 dbName: auto_racing_results_id
406 - name: db_most_laps_leading
408 - {name: most_laps_leading_driver_id,
409 dbName: most_laps_leading_driver_id}
410 - {name: most_laps_leading_driver,
411 dbName: most_laps_leading_driver}
413 - embedded: MostLapsLeading
415 - name: db_most_laps_leading_driver_id
416 dbName: most_laps_leading_driver_id
417 - name: db_most_laps_leading_driver
418 dbName: most_laps_leading_driver
419 - name: db_most_laps_leading_number_of_laps
420 dbName: most_laps_leading_number_of_laps
428 -- | Pickler for the \<Listing\>s contained within \<message\>s.
430 pickle_listing :: PU AutoRacingResultsListingXml
433 xpWrap (from_tuple, to_tuple) $
434 xp13Tuple (xpElem "FinishPosition" xpInt)
435 (xpElem "StartingPosition" xpInt)
436 (xpElem "CarNumber" xpInt)
437 (xpElem "DriverID" xpInt)
438 (xpElem "Driver" xpText)
439 (xpElem "CarMake" xpText)
440 (xpElem "Points" xpInt)
441 (xpElem "Laps_Completed" xpInt)
442 (xpElem "Laps_Leading" xpInt)
443 (xpElem "Status" $ xpOption xpText)
444 (xpOption $ xpElem "DNF" xpPrim)
445 (xpOption $ xpElem "NC" xpPrim)
446 (xpElem "Earnings" xp_earnings)
448 from_tuple = uncurryN AutoRacingResultsListingXml
449 to_tuple m = (xml_finish_position m,
450 xml_starting_position m,
456 xml_laps_completed m,
464 -- | Pickler for the top-level 'Message'.
466 pickle_message :: PU Message
469 xpWrap (from_tuple, to_tuple) $
470 xp13Tuple (xpElem "XML_File_ID" xpInt)
471 (xpElem "heading" xpText)
472 (xpElem "category" xpText)
473 (xpElem "sport" xpText)
474 (xpElem "RaceID" xpInt)
475 (xpElem "RaceDate" xp_datetime)
476 (xpElem "Title" xpText)
477 (xpElem "Track_Location" xpText)
478 (xpElem "Laps_Remaining" xpInt)
479 (xpElem "Checkered_Flag" xpPrim)
480 (xpList pickle_listing)
481 pickle_race_information
482 (xpElem "time_stamp" xp_time_stamp)
484 from_tuple = uncurryN Message
485 to_tuple m = (xml_xml_file_id m,
492 xml_track_location m,
493 xml_laps_remaining m,
494 xml_checkered_flag m,
496 xml_race_information m,
500 -- | Pickler for the \<Most_Laps_Leading\> child of a
501 -- \<Race_Information\>.
503 pickle_most_laps_leading :: PU MostLapsLeading
504 pickle_most_laps_leading =
505 xpElem "Most_Laps_Leading" $
506 xpWrap (from_tuple, to_tuple) $
507 xpTriple (xpElem "DriverID" xpInt)
508 (xpElem "Driver" xpText)
509 (xpElem "NumberOfLaps" xpInt)
511 from_tuple = uncurryN MostLapsLeading
512 to_tuple m = (db_most_laps_leading_driver_id m,
513 db_most_laps_leading_driver m,
514 db_most_laps_leading_number_of_laps m)
517 -- | Pickler for the \<Race_Information\> child of \<message\>.
519 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
520 pickle_race_information =
521 xpElem "Race_Information" $
522 xpWrap (from_tuple, to_tuple) $
523 xp11Tuple (-- I can't think of another way to get both the
524 -- TrackLength and its KPH attribute. So we shove them
525 -- both in a 2-tuple. This should probably be an embedded type!
526 xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) )
527 (xpElem "Laps" xpInt)
528 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
529 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
530 (xpOption $ xpElem "AverageSpeed" xpPrim)
531 (xpOption $ xpElem "TimeOfRace" xpText)
532 (xpOption $ xpElem "MarginOfVictory" xpText)
533 (xpOption $ xpElem "Cautions" xpText)
534 (xpOption $ xpElem "LeadChanges" xpText)
535 (xpOption $ xpElem "LapLeaders" xpText)
536 pickle_most_laps_leading
538 -- Derp. Since the first two are paired, we have to
539 -- manually unpack the bazillion arguments.
540 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
541 AutoRacingResultsRaceInformationXml
542 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
544 -- And here we have to re-pair the first two.
545 to_tuple m = ((xml_track_length m, xml_track_length_kph m),
547 xml_average_speed_mph m,
548 xml_average_speed_kph m,
551 xml_margin_of_victory m,
555 xml_most_laps_leading m)
561 -- | A list of all tests for this module.
563 auto_racing_results_tests :: TestTree
564 auto_racing_results_tests =
566 "AutoRacingResults tests"
567 [ test_on_delete_cascade,
568 test_pickle_of_unpickle_is_identity,
569 test_unpickle_succeeds ]
571 -- | If we unpickle something and then pickle it, we should wind up
572 -- with the same thing we started with. WARNING: success of this
573 -- test does not mean that unpickling succeeded.
575 test_pickle_of_unpickle_is_identity :: TestTree
576 test_pickle_of_unpickle_is_identity =
577 testCase "pickle composed with unpickle is the identity" $ do
578 let path = "test/xml/AutoRacingResultsXML.xml"
579 (expected, actual) <- pickle_unpickle pickle_message path
584 -- | Make sure we can actually unpickle these things.
586 test_unpickle_succeeds :: TestTree
587 test_unpickle_succeeds =
588 testCase "unpickling succeeds" $ do
589 let path = "test/xml/AutoRacingResultsXML.xml"
590 actual <- unpickleable path pickle_message
597 -- | Make sure everything gets deleted when we delete the top-level
600 test_on_delete_cascade :: TestTree
601 test_on_delete_cascade =
602 testCase "deleting auto_racing_results deletes its children" $ do
603 let path = "test/xml/AutoRacingResultsXML.xml"
604 results <- unsafe_unpickle path pickle_message
605 let a = undefined :: AutoRacingResults
606 let b = undefined :: AutoRacingResultsListing
607 let c = undefined :: AutoRacingResultsRaceInformation
609 actual <- withSqliteConn ":memory:" $ runDbConn $ do
610 runMigration silentMigrationLogger $ do
614 _ <- dbimport results
616 count_a <- countAll a
617 count_b <- countAll b
618 count_c <- countAll c
619 return $ sum [count_a, count_b, count_c]