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_racedate, 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'.
87 data AutoRacingResults =
89 db_xml_file_id :: Int,
91 db_category :: String,
94 db_race_date :: UTCTime,
96 db_track_location :: String,
97 db_laps_remaining :: Int,
98 db_checkered_flag :: Bool,
99 db_time_stamp :: UTCTime }
104 -- | XML Representation of an 'AutoRacingResults'.
108 xml_xml_file_id :: Int,
109 xml_heading :: String,
110 xml_category :: String,
113 xml_race_date :: UTCTime,
115 xml_track_location :: String,
116 xml_laps_remaining :: Int,
117 xml_checkered_flag :: Bool,
118 xml_listings :: [AutoRacingResultsListingXml],
119 xml_race_information :: AutoRacingResultsRaceInformationXml,
120 xml_time_stamp :: UTCTime }
124 instance ToDb Message where
125 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
127 type Db Message = AutoRacingResults
130 -- | The 'FromXml' instance for 'Message' is required for the
131 -- 'XmlImport' instance.
133 instance FromXml Message where
134 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
135 -- the 'xml_listings' and 'xml_race_information'.
137 from_xml Message{..} =
139 db_xml_file_id = xml_xml_file_id,
140 db_heading = xml_heading,
141 db_category = xml_category,
142 db_sport = xml_sport,
143 db_race_id = xml_race_id,
144 db_race_date = xml_race_date,
145 db_title = xml_title,
146 db_track_location = xml_track_location,
147 db_laps_remaining = xml_laps_remaining,
148 db_checkered_flag = xml_checkered_flag,
149 db_time_stamp = xml_time_stamp }
152 -- | This allows us to insert the XML representation 'Message'
155 instance XmlImport Message
158 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
160 -- | Database representation of a \<Listing\> contained within a
163 data AutoRacingResultsListing =
164 AutoRacingResultsListing {
165 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
166 db_finish_position :: Int,
167 db_starting_position :: Int,
168 db_car_number :: Int,
171 db_car_make :: String,
173 db_laps_completed :: Int,
174 db_laps_leading :: Int,
175 db_status :: Maybe String,
176 db_dnf :: Maybe Bool,
178 db_earnings :: Maybe Int }
180 -- | XML representation of a \<Listing\> contained within a
183 data AutoRacingResultsListingXml =
184 AutoRacingResultsListingXml {
185 xml_finish_position :: Int,
186 xml_starting_position :: Int,
187 xml_car_number :: Int,
188 xml_driver_id :: Int,
189 xml_driver :: String,
190 xml_car_make :: String,
192 xml_laps_completed :: Int,
193 xml_laps_leading :: Int,
194 xml_status :: Maybe String,
195 xml_dnf :: Maybe Bool,
196 xml_nc :: Maybe Bool,
197 xml_earnings :: Maybe Int }
201 instance ToDb AutoRacingResultsListingXml where
202 -- | The database analogue of an 'AutoRacingResultsListingXml' is
203 -- an 'AutoRacingResultsListing'.
205 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
207 instance FromXmlFk AutoRacingResultsListingXml where
208 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
209 -- foreign key to) a 'AutoRacingResults'.
211 type Parent AutoRacingResultsListingXml = AutoRacingResults
213 -- | To convert an 'AutoRacingResultsListingXml' to an
214 -- 'AutoRacingResultsListing', we add the foreign key and copy
215 -- everything else verbatim.
217 from_xml_fk fk AutoRacingResultsListingXml{..} =
218 AutoRacingResultsListing {
219 db_auto_racing_results_id = fk,
220 db_finish_position = xml_finish_position,
221 db_starting_position = xml_starting_position,
222 db_car_number = xml_car_number,
223 db_driver_id = xml_driver_id,
224 db_driver = xml_driver,
225 db_car_make = xml_car_make,
226 db_points = xml_points,
227 db_laps_completed = xml_laps_completed,
228 db_laps_leading = xml_laps_leading,
229 db_status = xml_status,
232 db_earnings = xml_earnings }
235 -- | This allows us to insert the XML representation
236 -- 'AutoRacingResultsListingXml' directly.
238 instance XmlImportFk AutoRacingResultsListingXml
242 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
244 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
245 -- contains exactly three fields, so we just embed those three into
246 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
247 -- the \"db_\" prefix since our field namer is going to strip of
248 -- everything before the first underscore.
250 data MostLapsLeading =
252 db_most_laps_leading_driver_id :: Int,
253 db_most_laps_leading_driver :: String,
254 db_most_laps_leading_number_of_laps :: Int }
255 deriving (Data, Eq, Show, Typeable)
258 -- | Database representation of a \<Race_Information\> contained within a
261 data AutoRacingResultsRaceInformation =
262 AutoRacingResultsRaceInformation {
263 -- Note the apostrophe to disambiguate it from the
264 -- AutoRacingResultsListing filed.
265 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
266 db_track_length :: Double,
267 db_track_length_kph :: Double,
269 db_average_speed_mph :: Maybe Double,
270 db_average_speed_kph :: Maybe Double,
271 db_average_speed :: Maybe Double,
272 db_time_of_race :: Maybe String,
273 db_margin_of_victory :: Maybe String,
274 db_cautions :: Maybe String,
275 db_lead_changes :: Maybe String,
276 db_lap_leaders :: Maybe String,
277 db_most_laps_leading :: MostLapsLeading }
280 -- | XML representation of a \<Listing\> contained within a
283 data AutoRacingResultsRaceInformationXml =
284 AutoRacingResultsRaceInformationXml {
285 xml_track_length :: Double,
286 xml_track_length_kph :: Double,
288 xml_average_speed_mph :: Maybe Double,
289 xml_average_speed_kph :: Maybe Double,
290 xml_average_speed :: Maybe Double,
291 xml_time_of_race :: Maybe String,
292 xml_margin_of_victory :: Maybe String,
293 xml_cautions :: Maybe String,
294 xml_lead_changes :: Maybe String,
295 xml_lap_leaders :: Maybe String,
296 xml_most_laps_leading :: MostLapsLeading }
300 instance ToDb AutoRacingResultsRaceInformationXml where
301 -- | The database analogue of an
302 -- 'AutoRacingResultsRaceInformationXml' is an
303 -- 'AutoRacingResultsRaceInformation'.
305 type Db AutoRacingResultsRaceInformationXml =
306 AutoRacingResultsRaceInformation
308 instance FromXmlFk AutoRacingResultsRaceInformationXml where
309 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
310 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
312 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
314 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
315 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
316 -- copy everything else verbatim.
318 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
319 AutoRacingResultsRaceInformation {
320 db_auto_racing_results_id' = fk,
321 db_track_length = xml_track_length,
322 db_track_length_kph = xml_track_length_kph,
324 db_average_speed_mph = xml_average_speed_mph,
325 db_average_speed_kph = xml_average_speed_kph,
326 db_average_speed = xml_average_speed,
327 db_time_of_race = xml_time_of_race,
328 db_margin_of_victory = xml_margin_of_victory,
329 db_cautions = xml_cautions,
330 db_lead_changes = xml_lead_changes,
331 db_lap_leaders = xml_lap_leaders,
332 db_most_laps_leading = xml_most_laps_leading }
335 -- | This allows us to insert the XML representation
336 -- 'AutoRacingResultsRaceInformationXml' directly.
338 instance XmlImportFk AutoRacingResultsRaceInformationXml
346 instance DbImport Message where
349 migrate (undefined :: AutoRacingResults)
350 migrate (undefined :: AutoRacingResultsListing)
351 migrate (undefined :: AutoRacingResultsRaceInformation)
353 -- | We insert the message, then use its ID to insert the listings
354 -- and race information.
356 msg_id <- insert_xml m
358 insert_xml_fk_ msg_id (xml_race_information m)
360 forM_ (xml_listings m) $ \listing -> do
361 insert_xml_fk_ msg_id listing
363 return ImportSucceeded
367 mkPersist tsn_codegen_config [groundhog|
368 - entity: AutoRacingResults
369 dbName: auto_racing_results
371 - name: AutoRacingResults
373 - name: unique_auto_racing_schedule
375 # Prevent multiple imports of the same message.
376 fields: [db_xml_file_id]
379 - entity: AutoRacingResultsListing
380 dbName: auto_racing_results_listings
382 - name: AutoRacingResultsListing
384 - name: db_auto_racing_results_id
389 - entity: AutoRacingResultsRaceInformation
390 dbName: auto_racing_results_race_information
392 - name: AutoRacingResultsRaceInformation
394 - name: db_auto_racing_results_id'
397 - name: db_most_laps_leading
399 - {name: most_laps_leading_driver_id, dbName: most_laps_leading_driver_id}
400 - {name: most_laps_leading_driver, dbName: most_laps_leading_driver}
402 - embedded: MostLapsLeading
404 - name: db_most_laps_leading_driver_id
405 dbName: most_laps_leading_driver_id
406 - name: db_most_laps_leading_driver
407 dbName: most_laps_leading_driver
408 - name: db_most_laps_leading_number_of_laps
409 dbName: most_laps_leading_number_of_laps
417 pickle_listing :: PU AutoRacingResultsListingXml
420 xpWrap (from_tuple, to_tuple) $
421 xp13Tuple (xpElem "FinishPosition" xpInt)
422 (xpElem "StartingPosition" xpInt)
423 (xpElem "CarNumber" xpInt)
424 (xpElem "DriverID" xpInt)
425 (xpElem "Driver" xpText)
426 (xpElem "CarMake" xpText)
427 (xpElem "Points" xpInt)
428 (xpElem "Laps_Completed" xpInt)
429 (xpElem "Laps_Leading" xpInt)
430 (xpElem "Status" $ xpOption xpText)
431 (xpOption $ xpElem "DNF" xpPrim)
432 (xpOption $ xpElem "NC" xpPrim)
433 (xpElem "Earnings" xp_earnings)
435 from_tuple = uncurryN AutoRacingResultsListingXml
436 to_tuple m = (xml_finish_position m,
437 xml_starting_position m,
443 xml_laps_completed m,
451 -- | Pickler for the top-level 'Message'.
452 pickle_message :: PU Message
455 xpWrap (from_tuple, to_tuple) $
456 xp13Tuple (xpElem "XML_File_ID" xpInt)
457 (xpElem "heading" xpText)
458 (xpElem "category" xpText)
459 (xpElem "sport" xpText)
460 (xpElem "RaceID" xpInt)
461 (xpElem "RaceDate" xp_racedate)
462 (xpElem "Title" xpText)
463 (xpElem "Track_Location" xpText)
464 (xpElem "Laps_Remaining" xpInt)
465 (xpElem "Checkered_Flag" xpPrim)
466 (xpList pickle_listing)
467 pickle_race_information
468 (xpElem "time_stamp" xp_time_stamp)
470 from_tuple = uncurryN Message
471 to_tuple m = (xml_xml_file_id m,
478 xml_track_location m,
479 xml_laps_remaining m,
480 xml_checkered_flag m,
482 xml_race_information m,
486 pickle_most_laps_leading :: PU MostLapsLeading
487 pickle_most_laps_leading =
488 xpElem "Most_Laps_Leading" $
489 xpWrap (from_tuple, to_tuple) $
490 xpTriple (xpElem "DriverID" xpInt)
491 (xpElem "Driver" xpText)
492 (xpElem "NumberOfLaps" xpInt)
494 from_tuple = uncurryN MostLapsLeading
495 to_tuple m = (db_most_laps_leading_driver_id m,
496 db_most_laps_leading_driver m,
497 db_most_laps_leading_number_of_laps m)
499 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
500 pickle_race_information =
501 xpElem "Race_Information" $
502 xpWrap (from_tuple, to_tuple) $
503 xp11Tuple (-- I can't think of another way to get both the
504 -- TrackLength and its KPH attribute. So we shove them
505 -- both in a 2-tuple.
506 xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) )
507 (xpElem "Laps" xpInt)
508 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
509 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
510 (xpOption $ xpElem "AverageSpeed" xpPrim)
511 (xpOption $ xpElem "TimeOfRace" xpText)
512 (xpOption $ xpElem "MarginOfVictory" xpText)
513 (xpOption $ xpElem "Cautions" xpText)
514 (xpOption $ xpElem "LeadChanges" xpText)
515 (xpOption $ xpElem "LapLeaders" xpText)
516 pickle_most_laps_leading
518 -- Derp. Since the first two are paired, we have to
519 -- manually unpack the bazillion arguments.
520 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
521 AutoRacingResultsRaceInformationXml
522 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
524 -- And here we have to re-pair the first two.
525 to_tuple m = ((xml_track_length m, xml_track_length_kph m),
527 xml_average_speed_mph m,
528 xml_average_speed_kph m,
531 xml_margin_of_victory m,
535 xml_most_laps_leading m)
541 -- | A list of all tests for this module.
543 auto_racing_results_tests :: TestTree
544 auto_racing_results_tests =
546 "AutoRacingResults tests"
547 [ test_on_delete_cascade,
548 test_pickle_of_unpickle_is_identity,
549 test_unpickle_succeeds ]
551 -- | If we unpickle something and then pickle it, we should wind up
552 -- with the same thing we started with. WARNING: success of this
553 -- test does not mean that unpickling succeeded.
555 test_pickle_of_unpickle_is_identity :: TestTree
556 test_pickle_of_unpickle_is_identity =
557 testCase "pickle composed with unpickle is the identity" $ do
558 let path = "test/xml/AutoRacingResultsXML.xml"
559 (expected, actual) <- pickle_unpickle pickle_message path
564 -- | Make sure we can actually unpickle these things.
566 test_unpickle_succeeds :: TestTree
567 test_unpickle_succeeds =
568 testCase "unpickling succeeds" $ do
569 let path = "test/xml/AutoRacingResultsXML.xml"
570 actual <- unpickleable path pickle_message
577 -- | Make sure everything gets deleted when we delete the top-level
580 test_on_delete_cascade :: TestTree
581 test_on_delete_cascade =
582 testCase "deleting auto_racing_results deletes its children" $ do
583 let path = "test/xml/AutoRacingResultsXML.xml"
584 results <- unsafe_unpickle path pickle_message
585 let a = undefined :: AutoRacingResults
586 let b = undefined :: AutoRacingResultsListing
587 let c = undefined :: AutoRacingResultsRaceInformation
589 actual <- withSqliteConn ":memory:" $ runDbConn $ do
590 runMigration silentMigrationLogger $ do
594 _ <- dbimport results
596 count_a <- countAll a
597 count_b <- countAll b
598 count_c <- countAll c
599 return $ sum [count_a, count_b, count_c]