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.Maybe ( fromMaybe )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Data.Typeable ( Typeable )
31 import Database.Groundhog (
36 silentMigrationLogger )
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
62 import TSN.Codegen ( tsn_codegen_config )
63 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 xp_fracpart_only_double,
69 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
83 dtd = "AutoRacingResultsXML.dtd"
89 -- * AutoRacingResults/Message
91 -- | Database representation of a 'Message'. Comparatively, it lacks
92 -- the listings and race information since they are linked via a
95 data AutoRacingResults =
97 db_xml_file_id :: Int,
99 db_category :: String,
102 db_race_date :: UTCTime,
104 db_track_location :: String,
105 db_laps_remaining :: Int,
106 db_checkered_flag :: Bool,
107 db_time_stamp :: UTCTime }
112 -- | XML Representation of an 'AutoRacingResults'. It has the same
113 -- fields, but in addition contains the 'xml_listings' and
114 -- 'xml_race_information'.
118 xml_xml_file_id :: Int,
119 xml_heading :: String,
120 xml_category :: String,
123 xml_race_date :: UTCTime,
125 xml_track_location :: String,
126 xml_laps_remaining :: Int,
127 xml_checkered_flag :: Bool,
128 xml_listings :: [AutoRacingResultsListingXml],
129 xml_race_information :: AutoRacingResultsRaceInformationXml,
130 xml_time_stamp :: UTCTime }
134 instance ToDb Message where
135 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
137 type Db Message = AutoRacingResults
140 -- | The 'FromXml' instance for 'Message' is required for the
141 -- 'XmlImport' instance.
143 instance FromXml Message where
144 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
145 -- the 'xml_listings' and 'xml_race_information'.
147 from_xml Message{..} =
149 db_xml_file_id = xml_xml_file_id,
150 db_heading = xml_heading,
151 db_category = xml_category,
152 db_sport = xml_sport,
153 db_race_id = xml_race_id,
154 db_race_date = xml_race_date,
155 db_title = xml_title,
156 db_track_location = xml_track_location,
157 db_laps_remaining = xml_laps_remaining,
158 db_checkered_flag = xml_checkered_flag,
159 db_time_stamp = xml_time_stamp }
162 -- | This allows us to insert the XML representation 'Message'
165 instance XmlImport Message
168 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
170 -- | Database representation of a \<Listing\> contained within a
173 data AutoRacingResultsListing =
174 AutoRacingResultsListing {
175 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
176 db_finish_position :: Int,
177 db_starting_position :: Int,
178 db_car_number :: Int,
181 db_car_make :: String,
183 db_laps_completed :: Int,
184 db_laps_leading :: Int,
185 db_status :: Maybe String,
186 db_dnf :: Maybe Bool,
188 db_earnings :: Maybe Int }
191 -- | XML representation of a \<Listing\> contained within a
194 data AutoRacingResultsListingXml =
195 AutoRacingResultsListingXml {
196 xml_finish_position :: Int,
197 xml_starting_position :: Int,
198 xml_car_number :: Int,
199 xml_driver_id :: Int,
200 xml_driver :: String,
201 xml_car_make :: String,
203 xml_laps_completed :: Int,
204 xml_laps_leading :: Int,
205 xml_status :: Maybe String,
206 xml_dnf :: Maybe Bool,
207 xml_nc :: Maybe Bool,
208 xml_earnings :: Maybe Int }
212 instance ToDb AutoRacingResultsListingXml where
213 -- | The database analogue of an 'AutoRacingResultsListingXml' is
214 -- an 'AutoRacingResultsListing'.
216 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
219 instance Child AutoRacingResultsListingXml where
220 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
221 -- foreign key to) a 'AutoRacingResults'.
223 type Parent AutoRacingResultsListingXml = AutoRacingResults
226 instance FromXmlFk AutoRacingResultsListingXml where
227 -- | To convert an 'AutoRacingResultsListingXml' to an
228 -- 'AutoRacingResultsListing', we add the foreign key and copy
229 -- everything else verbatim.
231 from_xml_fk fk AutoRacingResultsListingXml{..} =
232 AutoRacingResultsListing {
233 db_auto_racing_results_id = fk,
234 db_finish_position = xml_finish_position,
235 db_starting_position = xml_starting_position,
236 db_car_number = xml_car_number,
237 db_driver_id = xml_driver_id,
238 db_driver = xml_driver,
239 db_car_make = xml_car_make,
240 db_points = xml_points,
241 db_laps_completed = xml_laps_completed,
242 db_laps_leading = xml_laps_leading,
243 db_status = xml_status,
246 db_earnings = xml_earnings }
249 -- | This allows us to insert the XML representation
250 -- 'AutoRacingResultsListingXml' directly.
252 instance XmlImportFk AutoRacingResultsListingXml
256 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
258 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
259 -- contains exactly three fields, so we just embed those three into
260 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
261 -- the \"db_\" prefix since our field namer is going to strip of
262 -- everything before the first underscore.
264 -- We make the three fields optional because the entire
265 -- \<Most_Laps_Leading\> is apparently optional (although it is
266 -- usually present). A 'Nothing' in the XML should get turned into
267 -- three 'Nothing's in the DB.
269 data MostLapsLeading =
271 db_most_laps_leading_driver_id :: Maybe Int,
272 db_most_laps_leading_driver :: Maybe String,
273 db_most_laps_leading_number_of_laps :: Maybe Int }
274 deriving (Data, Eq, Show, Typeable)
277 -- | Database representation of a \<Race_Information\> contained
278 -- within a \<message\>.
280 -- The 'db_most_laps_leading' field is not optional because when we
281 -- convert from our XML representation, a missing 'MostLapsLeading'
282 -- will be replaced with a 'MostLapsLeading' with three missing
285 data AutoRacingResultsRaceInformation =
286 AutoRacingResultsRaceInformation {
287 -- Note the apostrophe to disambiguate it from the
288 -- AutoRacingResultsListing field.
289 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
290 db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
291 -- like \"1.25 miles\".
292 db_track_length_kph :: Double,
294 db_average_speed_mph :: Maybe Double,
295 db_average_speed_kph :: Maybe Double,
296 db_average_speed :: Maybe Double,
297 db_time_of_race :: Maybe String,
298 db_margin_of_victory :: Maybe String,
299 db_cautions :: Maybe String,
300 db_lead_changes :: Maybe String,
301 db_lap_leaders :: Maybe String,
302 db_most_laps_leading :: MostLapsLeading }
305 -- | XML representation of a \<Listing\> contained within a
308 data AutoRacingResultsRaceInformationXml =
309 AutoRacingResultsRaceInformationXml {
310 xml_track_length :: String,
311 xml_track_length_kph :: Double,
313 xml_average_speed_mph :: Maybe Double,
314 xml_average_speed_kph :: Maybe Double,
315 xml_average_speed :: Maybe Double,
316 xml_time_of_race :: Maybe String,
317 xml_margin_of_victory :: Maybe String,
318 xml_cautions :: Maybe String,
319 xml_lead_changes :: Maybe String,
320 xml_lap_leaders :: Maybe String,
321 xml_most_laps_leading :: Maybe MostLapsLeading }
325 instance ToDb AutoRacingResultsRaceInformationXml where
326 -- | The database analogue of an
327 -- 'AutoRacingResultsRaceInformationXml' is an
328 -- 'AutoRacingResultsRaceInformation'.
330 type Db AutoRacingResultsRaceInformationXml =
331 AutoRacingResultsRaceInformation
334 instance Child AutoRacingResultsRaceInformationXml where
335 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
336 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
338 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
341 instance FromXmlFk AutoRacingResultsRaceInformationXml where
342 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
343 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
344 -- copy everything else verbatim.
346 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
347 AutoRacingResultsRaceInformation {
348 db_auto_racing_results_id' = fk,
349 db_track_length = xml_track_length,
350 db_track_length_kph = xml_track_length_kph,
352 db_average_speed_mph = xml_average_speed_mph,
353 db_average_speed_kph = xml_average_speed_kph,
354 db_average_speed = xml_average_speed,
355 db_time_of_race = xml_time_of_race,
356 db_margin_of_victory = xml_margin_of_victory,
357 db_cautions = xml_cautions,
358 db_lead_changes = xml_lead_changes,
359 db_lap_leaders = xml_lap_leaders,
360 db_most_laps_leading = most_laps_leading }
362 -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
363 -- the database with an (embedded) 'MostLapsLeading' with three
366 fromMaybe (MostLapsLeading Nothing Nothing Nothing)
367 xml_most_laps_leading
370 -- | This allows us to insert the XML representation
371 -- 'AutoRacingResultsRaceInformationXml' directly.
373 instance XmlImportFk AutoRacingResultsRaceInformationXml
381 instance DbImport Message where
384 migrate (undefined :: AutoRacingResults)
385 migrate (undefined :: AutoRacingResultsListing)
386 migrate (undefined :: AutoRacingResultsRaceInformation)
388 -- | We insert the message, then use its ID to insert the listings
389 -- and race information.
391 msg_id <- insert_xml m
393 insert_xml_fk_ msg_id (xml_race_information m)
395 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
397 return ImportSucceeded
401 mkPersist tsn_codegen_config [groundhog|
402 - entity: AutoRacingResults
403 dbName: auto_racing_results
405 - name: AutoRacingResults
407 - name: unique_auto_racing_results
409 # Prevent multiple imports of the same message.
410 fields: [db_xml_file_id]
413 - entity: AutoRacingResultsListing
414 dbName: auto_racing_results_listings
416 - name: AutoRacingResultsListing
418 - name: db_auto_racing_results_id
422 # Note the apostrophe in the foreign key. This is to disambiguate
423 # it from the AutoRacingResultsListing foreign key of the same name.
424 # We strip it out of the dbName.
425 - entity: AutoRacingResultsRaceInformation
426 dbName: auto_racing_results_race_information
428 - name: AutoRacingResultsRaceInformation
430 - name: db_auto_racing_results_id'
431 dbName: auto_racing_results_id
434 - name: db_most_laps_leading
436 - {name: most_laps_leading_driver_id,
437 dbName: most_laps_leading_driver_id}
438 - {name: most_laps_leading_driver,
439 dbName: most_laps_leading_driver}
441 - embedded: MostLapsLeading
443 - name: db_most_laps_leading_driver_id
444 dbName: most_laps_leading_driver_id
445 - name: db_most_laps_leading_driver
446 dbName: most_laps_leading_driver
447 - name: db_most_laps_leading_number_of_laps
448 dbName: most_laps_leading_number_of_laps
456 -- | Pickler for the \<Listing\>s contained within \<message\>s.
458 pickle_listing :: PU AutoRacingResultsListingXml
461 xpWrap (from_tuple, to_tuple) $
462 xp13Tuple (xpElem "FinishPosition" xpInt)
463 (xpElem "StartingPosition" xpInt)
464 (xpElem "CarNumber" xpInt)
465 (xpElem "DriverID" xpInt)
466 (xpElem "Driver" xpText)
467 (xpElem "CarMake" xpText)
468 (xpElem "Points" xpInt)
469 (xpElem "Laps_Completed" xpInt)
470 (xpElem "Laps_Leading" xpInt)
471 (xpElem "Status" $ xpOption xpText)
472 (xpOption $ xpElem "DNF" xpPrim)
473 (xpOption $ xpElem "NC" xpPrim)
474 (xpElem "Earnings" xp_earnings)
476 from_tuple = uncurryN AutoRacingResultsListingXml
477 to_tuple m = (xml_finish_position m,
478 xml_starting_position m,
484 xml_laps_completed m,
492 -- | Pickler for the top-level 'Message'.
494 pickle_message :: PU Message
497 xpWrap (from_tuple, to_tuple) $
498 xp13Tuple (xpElem "XML_File_ID" xpInt)
499 (xpElem "heading" xpText)
500 (xpElem "category" xpText)
501 (xpElem "sport" xpText)
502 (xpElem "RaceID" xpInt)
503 (xpElem "RaceDate" xp_datetime)
504 (xpElem "Title" xpText)
505 (xpElem "Track_Location" xpText)
506 (xpElem "Laps_Remaining" xpInt)
507 (xpElem "Checkered_Flag" xpPrim)
508 (xpList pickle_listing)
509 pickle_race_information
510 (xpElem "time_stamp" xp_time_stamp)
512 from_tuple = uncurryN Message
513 to_tuple m = (xml_xml_file_id m,
520 xml_track_location m,
521 xml_laps_remaining m,
522 xml_checkered_flag m,
524 xml_race_information m,
528 -- | Pickler for the \<Most_Laps_Leading\> child of a
529 -- \<Race_Information\>. This is complicated by the fact that the
530 -- three fields we're trying to parse are not actually optional;
531 -- only the entire \<Most_Laps_Leading\> is. So we always wrap what
532 -- we parse in a 'Just', and when converting from the DB to XML,
533 -- we'll drop the entire element if any of its fields are missing
534 -- (which they never should be).
536 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
537 pickle_most_laps_leading =
538 xpElem "Most_Laps_Leading" $
539 xpWrap (from_tuple, to_tuple) $
540 xpTriple (xpOption $ xpElem "DriverID" xpInt)
541 (xpOption $ xpElem "Driver" xpText)
542 (xpOption $ xpElem "NumberOfLaps" xpInt)
544 from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
545 from_tuple (Just x, Just y, Just z) =
546 Just $ MostLapsLeading (Just x) (Just y) (Just z)
547 from_tuple _ = Nothing
549 -- Sure had to go out of my way to avoid the warnings about unused
550 -- db_most_laps_foo fields here.
551 to_tuple :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
552 to_tuple Nothing = (Nothing, Nothing, Nothing)
553 to_tuple (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
554 to_tuple (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
555 to_tuple (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
556 to_tuple (Just m) = (db_most_laps_leading_driver_id m,
557 db_most_laps_leading_driver m,
558 db_most_laps_leading_number_of_laps m)
561 -- | Pickler for the \<Race_Information\> child of \<message\>.
563 -- There's so much voodoo going on here. We have a double-layered
564 -- Maybe on top of the MostLapsLeading. When unpickling, we return a
565 -- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
566 -- missing. But if the entire element is missing, unpickling
567 -- fails. 'xpOption' doesn't fix this because it would give us a
568 -- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
569 -- default of (Nothing :: Maybe MostLapsLeading) to stick one in
570 -- there if unpicking a (Maybe MostLapsLeading) fails because
571 -- \<Most_Laps_Leading\> is missing.
573 -- Clear as mud, I know.
575 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
576 pickle_race_information =
577 xpElem "Race_Information" $
578 xpWrap (from_tuple, to_tuple) $
579 xp11Tuple (-- I can't think of another way to get both the
580 -- TrackLength and its KPH attribute. So we shove them
581 -- both in a 2-tuple. This should probably be an embedded type!
582 xpElem "TrackLength" $
584 (xpAttr "KPH" xp_fracpart_only_double) )
585 (xpElem "Laps" xpInt)
586 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
587 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
588 (xpOption $ xpElem "AverageSpeed" xpPrim)
589 (xpOption $ xpElem "TimeOfRace" xpText)
590 (xpOption $ xpElem "MarginOfVictory" xpText)
591 (xpOption $ xpElem "Cautions" xpText)
592 (xpOption $ xpElem "LeadChanges" xpText)
593 (xpOption $ xpElem "LapLeaders" xpText)
594 (xpDefault Nothing pickle_most_laps_leading)
596 -- Derp. Since the first two are paired, we have to
597 -- manually unpack the bazillion arguments.
598 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
599 AutoRacingResultsRaceInformationXml
600 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
602 -- And here we have to re-pair the first two.
603 to_tuple m = ((xml_track_length m, xml_track_length_kph m),
605 xml_average_speed_mph m,
606 xml_average_speed_kph m,
609 xml_margin_of_victory m,
613 xml_most_laps_leading m)
619 -- | A list of all tests for this module.
621 auto_racing_results_tests :: TestTree
622 auto_racing_results_tests =
624 "AutoRacingResults tests"
625 [ test_on_delete_cascade,
626 test_pickle_of_unpickle_is_identity,
627 test_unpickle_succeeds ]
629 -- | If we unpickle something and then pickle it, we should wind up
630 -- with the same thing we started with. WARNING: success of this
631 -- test does not mean that unpickling succeeded.
633 test_pickle_of_unpickle_is_identity :: TestTree
634 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
635 [ check "pickle composed with unpickle is the identity"
636 "test/xml/AutoRacingResultsXML.xml",
638 check "pickle composed with unpickle is the identity (fractional KPH)"
639 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
641 check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
642 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
644 check desc path = testCase desc $ do
645 (expected, actual) <- pickle_unpickle pickle_message path
650 -- | Make sure we can actually unpickle these things.
652 test_unpickle_succeeds :: TestTree
653 test_unpickle_succeeds = testGroup "unpickle tests"
654 [ check "unpickling succeeds"
655 "test/xml/AutoRacingResultsXML.xml",
657 check "unpickling succeeds (fractional KPH)"
658 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
660 check "unpickling succeeds (no Most_Laps_Leading)"
661 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
663 check desc path = testCase desc $ do
664 actual <- unpickleable path pickle_message
670 -- | Make sure everything gets deleted when we delete the top-level
673 test_on_delete_cascade :: TestTree
674 test_on_delete_cascade = testGroup "cascading delete tests"
675 [ check "deleting auto_racing_results deletes its children"
676 "test/xml/AutoRacingResultsXML.xml",
678 check "deleting auto_racing_results deletes its children (fractional KPH)"
679 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
681 check ("deleting auto_racing_results deletes its children " ++
682 "(No Most_Laps_Leading)")
683 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
685 check desc path = testCase desc $ do
686 results <- unsafe_unpickle path pickle_message
687 let a = undefined :: AutoRacingResults
688 let b = undefined :: AutoRacingResultsListing
689 let c = undefined :: AutoRacingResultsRaceInformation
691 actual <- withSqliteConn ":memory:" $ runDbConn $ do
692 runMigration silentMigrationLogger $ do
696 _ <- dbimport results
698 count_a <- countAll a
699 count_b <- countAll b
700 count_c <- countAll c
701 return $ sum [count_a, count_b, count_c]