1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each
11 -- \<message\> element contains a \<Race_Information\> and a bunch of
14 module TSN.XML.AutoRacingResults (
18 auto_racing_results_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 AutoRacingResultsConstructor(..),
21 AutoRacingResultsListingConstructor(..),
22 AutoRacingResultsRaceInformationConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Data ( Data )
28 import Data.Maybe ( fromMaybe )
29 import Data.Time ( UTCTime(..) )
30 import Data.Tuple.Curry ( uncurryN )
31 import Data.Typeable ( Typeable )
32 import Database.Groundhog (
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
44 import qualified GHC.Generics as GHC ( Generic )
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.XML.HXT.Core (
64 import Generics ( Generic(..), to_tuple )
65 import TSN.Codegen ( tsn_codegen_config )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
69 xp_fracpart_only_double,
72 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
83 -- | The DTD to which this module corresponds. Used to invoke dbimport.
86 dtd = "AutoRacingResultsXML.dtd"
92 -- * AutoRacingResults/Message
94 -- | Database representation of a 'Message'. Comparatively, it lacks
95 -- the listings and race information since they are linked via a
98 data AutoRacingResults =
100 db_xml_file_id :: Int,
101 db_heading :: String,
102 db_category :: String,
105 db_race_date :: UTCTime,
107 db_track_location :: String,
108 db_laps_remaining :: Int,
109 db_checkered_flag :: Bool,
110 db_time_stamp :: UTCTime }
115 -- | XML Representation of an 'AutoRacingResults'. It has the same
116 -- fields, but in addition contains the 'xml_listings' and
117 -- 'xml_race_information'.
121 xml_xml_file_id :: Int,
122 xml_heading :: String,
123 xml_category :: String,
126 xml_race_date :: UTCTime,
128 xml_track_location :: String,
129 xml_laps_remaining :: Int,
130 xml_checkered_flag :: Bool,
131 xml_listings :: [AutoRacingResultsListingXml],
132 xml_race_information :: AutoRacingResultsRaceInformationXml,
133 xml_time_stamp :: UTCTime }
134 deriving (Eq, GHC.Generic, Show)
136 -- | For 'Generics.to_tuple'.
138 instance Generic Message
141 instance ToDb Message where
142 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
144 type Db Message = AutoRacingResults
147 -- | The 'FromXml' instance for 'Message' is required for the
148 -- 'XmlImport' instance.
150 instance FromXml Message where
151 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
152 -- the 'xml_listings' and 'xml_race_information'.
154 from_xml Message{..} =
156 db_xml_file_id = xml_xml_file_id,
157 db_heading = xml_heading,
158 db_category = xml_category,
159 db_sport = xml_sport,
160 db_race_id = xml_race_id,
161 db_race_date = xml_race_date,
162 db_title = xml_title,
163 db_track_location = xml_track_location,
164 db_laps_remaining = xml_laps_remaining,
165 db_checkered_flag = xml_checkered_flag,
166 db_time_stamp = xml_time_stamp }
169 -- | This allows us to insert the XML representation 'Message'
172 instance XmlImport Message
175 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
177 -- | Database representation of a \<Listing\> contained within a
180 data AutoRacingResultsListing =
181 AutoRacingResultsListing {
182 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
183 db_finish_position :: Int,
184 db_starting_position :: Int,
185 db_car_number :: Int,
188 db_car_make :: String,
190 db_laps_completed :: Int,
191 db_laps_leading :: Int,
192 db_status :: Maybe String,
193 db_dnf :: Maybe Bool,
195 db_earnings :: Maybe Int }
198 -- | XML representation of a \<Listing\> contained within a
201 data AutoRacingResultsListingXml =
202 AutoRacingResultsListingXml {
203 xml_finish_position :: Int,
204 xml_starting_position :: Int,
205 xml_car_number :: Int,
206 xml_driver_id :: Int,
207 xml_driver :: String,
208 xml_car_make :: String,
210 xml_laps_completed :: Int,
211 xml_laps_leading :: Int,
212 xml_status :: Maybe String,
213 xml_dnf :: Maybe Bool,
214 xml_nc :: Maybe Bool,
215 xml_earnings :: Maybe Int }
216 deriving (Eq, GHC.Generic, Show)
218 -- | For 'Generics.to_tuple'.
220 instance Generic AutoRacingResultsListingXml
222 instance ToDb AutoRacingResultsListingXml where
223 -- | The database analogue of an 'AutoRacingResultsListingXml' is
224 -- an 'AutoRacingResultsListing'.
226 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
229 instance Child AutoRacingResultsListingXml where
230 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
231 -- foreign key to) a 'AutoRacingResults'.
233 type Parent AutoRacingResultsListingXml = AutoRacingResults
236 instance FromXmlFk AutoRacingResultsListingXml where
237 -- | To convert an 'AutoRacingResultsListingXml' to an
238 -- 'AutoRacingResultsListing', we add the foreign key and copy
239 -- everything else verbatim.
241 from_xml_fk fk AutoRacingResultsListingXml{..} =
242 AutoRacingResultsListing {
243 db_auto_racing_results_id = fk,
244 db_finish_position = xml_finish_position,
245 db_starting_position = xml_starting_position,
246 db_car_number = xml_car_number,
247 db_driver_id = xml_driver_id,
248 db_driver = xml_driver,
249 db_car_make = xml_car_make,
250 db_points = xml_points,
251 db_laps_completed = xml_laps_completed,
252 db_laps_leading = xml_laps_leading,
253 db_status = xml_status,
256 db_earnings = xml_earnings }
259 -- | This allows us to insert the XML representation
260 -- 'AutoRacingResultsListingXml' directly.
262 instance XmlImportFk AutoRacingResultsListingXml
266 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
268 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
269 -- contains exactly three fields, so we just embed those three into
270 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
271 -- the \"db_\" prefix since our field namer is going to strip of
272 -- everything before the first underscore.
274 -- We make the three fields optional because the entire
275 -- \<Most_Laps_Leading\> is apparently optional (although it is
276 -- usually present). A 'Nothing' in the XML should get turned into
277 -- three 'Nothing's in the DB.
279 data MostLapsLeading =
281 db_most_laps_leading_driver_id :: Maybe Int,
282 db_most_laps_leading_driver :: Maybe String,
283 db_most_laps_leading_number_of_laps :: Maybe Int }
284 deriving (Data, Eq, Show, Typeable)
287 -- | Database representation of a \<Race_Information\> contained
288 -- within a \<message\>.
290 -- The 'db_most_laps_leading' field is not optional because when we
291 -- convert from our XML representation, a missing 'MostLapsLeading'
292 -- will be replaced with a 'MostLapsLeading' with three missing
295 data AutoRacingResultsRaceInformation =
296 AutoRacingResultsRaceInformation {
297 -- Note the apostrophe to disambiguate it from the
298 -- AutoRacingResultsListing field.
299 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
300 db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
301 -- like \"1.25 miles\".
302 db_track_length_kph :: Double,
304 db_average_speed_mph :: Maybe Double,
305 db_average_speed_kph :: Maybe Double,
306 db_average_speed :: Maybe Double,
307 db_time_of_race :: Maybe String,
308 db_margin_of_victory :: Maybe String,
309 db_cautions :: Maybe String,
310 db_lead_changes :: Maybe String,
311 db_lap_leaders :: Maybe String,
312 db_most_laps_leading :: MostLapsLeading }
315 -- | XML representation of a \<Listing\> contained within a
318 data AutoRacingResultsRaceInformationXml =
319 AutoRacingResultsRaceInformationXml {
320 xml_track_length :: String,
321 xml_track_length_kph :: Double,
323 xml_average_speed_mph :: Maybe Double,
324 xml_average_speed_kph :: Maybe Double,
325 xml_average_speed :: Maybe Double,
326 xml_time_of_race :: Maybe String,
327 xml_margin_of_victory :: Maybe String,
328 xml_cautions :: Maybe String,
329 xml_lead_changes :: Maybe String,
330 xml_lap_leaders :: Maybe String,
331 xml_most_laps_leading :: Maybe MostLapsLeading }
335 instance ToDb AutoRacingResultsRaceInformationXml where
336 -- | The database analogue of an
337 -- 'AutoRacingResultsRaceInformationXml' is an
338 -- 'AutoRacingResultsRaceInformation'.
340 type Db AutoRacingResultsRaceInformationXml =
341 AutoRacingResultsRaceInformation
344 instance Child AutoRacingResultsRaceInformationXml where
345 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
346 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
348 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
351 instance FromXmlFk AutoRacingResultsRaceInformationXml where
352 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
353 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
354 -- copy everything else verbatim.
356 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
357 AutoRacingResultsRaceInformation {
358 db_auto_racing_results_id' = fk,
359 db_track_length = xml_track_length,
360 db_track_length_kph = xml_track_length_kph,
362 db_average_speed_mph = xml_average_speed_mph,
363 db_average_speed_kph = xml_average_speed_kph,
364 db_average_speed = xml_average_speed,
365 db_time_of_race = xml_time_of_race,
366 db_margin_of_victory = xml_margin_of_victory,
367 db_cautions = xml_cautions,
368 db_lead_changes = xml_lead_changes,
369 db_lap_leaders = xml_lap_leaders,
370 db_most_laps_leading = most_laps_leading }
372 -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
373 -- the database with an (embedded) 'MostLapsLeading' with three
376 fromMaybe (MostLapsLeading Nothing Nothing Nothing)
377 xml_most_laps_leading
380 -- | This allows us to insert the XML representation
381 -- 'AutoRacingResultsRaceInformationXml' directly.
383 instance XmlImportFk AutoRacingResultsRaceInformationXml
391 instance DbImport Message where
394 migrate (undefined :: AutoRacingResults)
395 migrate (undefined :: AutoRacingResultsListing)
396 migrate (undefined :: AutoRacingResultsRaceInformation)
398 -- | We insert the message, then use its ID to insert the listings
399 -- and race information.
401 msg_id <- insert_xml m
403 insert_xml_fk_ msg_id (xml_race_information m)
405 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
407 return ImportSucceeded
411 mkPersist tsn_codegen_config [groundhog|
412 - entity: AutoRacingResults
413 dbName: auto_racing_results
415 - name: AutoRacingResults
417 - name: unique_auto_racing_results
419 # Prevent multiple imports of the same message.
420 fields: [db_xml_file_id]
423 - entity: AutoRacingResultsListing
424 dbName: auto_racing_results_listings
426 - name: AutoRacingResultsListing
428 - name: db_auto_racing_results_id
432 # Note the apostrophe in the foreign key. This is to disambiguate
433 # it from the AutoRacingResultsListing foreign key of the same name.
434 # We strip it out of the dbName.
435 - entity: AutoRacingResultsRaceInformation
436 dbName: auto_racing_results_race_information
438 - name: AutoRacingResultsRaceInformation
440 - name: db_auto_racing_results_id'
441 dbName: auto_racing_results_id
444 - name: db_most_laps_leading
446 - {name: most_laps_leading_driver_id,
447 dbName: most_laps_leading_driver_id}
448 - {name: most_laps_leading_driver,
449 dbName: most_laps_leading_driver}
451 - embedded: MostLapsLeading
453 - name: db_most_laps_leading_driver_id
454 dbName: most_laps_leading_driver_id
455 - name: db_most_laps_leading_driver
456 dbName: most_laps_leading_driver
457 - name: db_most_laps_leading_number_of_laps
458 dbName: most_laps_leading_number_of_laps
466 -- | Pickler for the \<Listing\>s contained within \<message\>s.
468 pickle_listing :: PU AutoRacingResultsListingXml
471 xpWrap (from_tuple, to_tuple) $
472 xp13Tuple (xpElem "FinishPosition" xpInt)
473 (xpElem "StartingPosition" xpInt)
474 (xpElem "CarNumber" xpInt)
475 (xpElem "DriverID" xpInt)
476 (xpElem "Driver" xpText)
477 (xpElem "CarMake" xpText)
478 (xpElem "Points" xpInt)
479 (xpElem "Laps_Completed" xpInt)
480 (xpElem "Laps_Leading" xpInt)
481 (xpElem "Status" $ xpOption xpText)
482 (xpOption $ xpElem "DNF" xpPrim)
483 (xpOption $ xpElem "NC" xpPrim)
484 (xpElem "Earnings" xp_earnings)
486 from_tuple = uncurryN AutoRacingResultsListingXml
489 -- | Pickler for the top-level 'Message'.
491 pickle_message :: PU Message
494 xpWrap (from_tuple, to_tuple) $
495 xp13Tuple (xpElem "XML_File_ID" xpInt)
496 (xpElem "heading" xpText)
497 (xpElem "category" xpText)
498 (xpElem "sport" xpText)
499 (xpElem "RaceID" xpInt)
500 (xpElem "RaceDate" xp_datetime)
501 (xpElem "Title" xpText)
502 (xpElem "Track_Location" xpText)
503 (xpElem "Laps_Remaining" xpInt)
504 (xpElem "Checkered_Flag" xpPrim)
505 (xpList pickle_listing)
506 pickle_race_information
507 (xpElem "time_stamp" xp_time_stamp)
509 from_tuple = uncurryN Message
512 -- | Pickler for the \<Most_Laps_Leading\> child of a
513 -- \<Race_Information\>. This is complicated by the fact that the
514 -- three fields we're trying to parse are not actually optional;
515 -- only the entire \<Most_Laps_Leading\> is. So we always wrap what
516 -- we parse in a 'Just', and when converting from the DB to XML,
517 -- we'll drop the entire element if any of its fields are missing
518 -- (which they never should be).
520 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
521 pickle_most_laps_leading =
522 xpElem "Most_Laps_Leading" $
523 xpWrap (from_tuple, to_tuple') $
524 xpTriple (xpOption $ xpElem "DriverID" xpInt)
525 (xpOption $ xpElem "Driver" xpText)
526 (xpOption $ xpElem "NumberOfLaps" xpInt)
528 from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
529 from_tuple (Just x, Just y, Just z) =
530 Just $ MostLapsLeading (Just x) (Just y) (Just z)
531 from_tuple _ = Nothing
533 -- Sure had to go out of my way to avoid the warnings about unused
534 -- db_most_laps_foo fields here.
535 to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
536 to_tuple' Nothing = (Nothing, Nothing, Nothing)
537 to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
538 to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
539 to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
540 to_tuple' (Just m) = (db_most_laps_leading_driver_id m,
541 db_most_laps_leading_driver m,
542 db_most_laps_leading_number_of_laps m)
545 -- | Pickler for the \<Race_Information\> child of \<message\>.
547 -- There's so much voodoo going on here. We have a double-layered
548 -- Maybe on top of the MostLapsLeading. When unpickling, we return a
549 -- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
550 -- missing. But if the entire element is missing, unpickling
551 -- fails. 'xpOption' doesn't fix this because it would give us a
552 -- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
553 -- default of (Nothing :: Maybe MostLapsLeading) to stick one in
554 -- there if unpicking a (Maybe MostLapsLeading) fails because
555 -- \<Most_Laps_Leading\> is missing.
557 -- Clear as mud, I know.
559 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
560 pickle_race_information =
561 xpElem "Race_Information" $
562 xpWrap (from_tuple, to_tuple') $
563 xp11Tuple (-- I can't think of another way to get both the
564 -- TrackLength and its KPH attribute. So we shove them
565 -- both in a 2-tuple. This should probably be an embedded type!
566 xpElem "TrackLength" $
568 (xpAttr "KPH" xp_fracpart_only_double) )
569 (xpElem "Laps" xpInt)
570 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
571 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
572 (xpOption $ xpElem "AverageSpeed" xpPrim)
573 (xpOption $ xpElem "TimeOfRace" xpText)
574 (xpOption $ xpElem "MarginOfVictory" xpText)
575 (xpOption $ xpElem "Cautions" xpText)
576 (xpOption $ xpElem "LeadChanges" xpText)
577 (xpOption $ xpElem "LapLeaders" xpText)
578 (xpDefault Nothing pickle_most_laps_leading)
580 -- Derp. Since the first two are paired, we have to
581 -- manually unpack the bazillion arguments.
582 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
583 AutoRacingResultsRaceInformationXml
584 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
586 -- And here we have to re-pair the first two.
587 to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
589 xml_average_speed_mph m,
590 xml_average_speed_kph m,
593 xml_margin_of_victory m,
597 xml_most_laps_leading m)
603 -- | A list of all tests for this module.
605 auto_racing_results_tests :: TestTree
606 auto_racing_results_tests =
608 "AutoRacingResults tests"
609 [ test_on_delete_cascade,
610 test_pickle_of_unpickle_is_identity,
611 test_unpickle_succeeds ]
613 -- | If we unpickle something and then pickle it, we should wind up
614 -- with the same thing we started with. WARNING: success of this
615 -- test does not mean that unpickling succeeded.
617 test_pickle_of_unpickle_is_identity :: TestTree
618 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
619 [ check "pickle composed with unpickle is the identity"
620 "test/xml/AutoRacingResultsXML.xml",
622 check "pickle composed with unpickle is the identity (fractional KPH)"
623 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
625 check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
626 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
628 check desc path = testCase desc $ do
629 (expected, actual) <- pickle_unpickle pickle_message path
634 -- | Make sure we can actually unpickle these things.
636 test_unpickle_succeeds :: TestTree
637 test_unpickle_succeeds = testGroup "unpickle tests"
638 [ check "unpickling succeeds"
639 "test/xml/AutoRacingResultsXML.xml",
641 check "unpickling succeeds (fractional KPH)"
642 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
644 check "unpickling succeeds (no Most_Laps_Leading)"
645 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
647 check desc path = testCase desc $ do
648 actual <- unpickleable path pickle_message
654 -- | Make sure everything gets deleted when we delete the top-level
657 test_on_delete_cascade :: TestTree
658 test_on_delete_cascade = testGroup "cascading delete tests"
659 [ check "deleting auto_racing_results deletes its children"
660 "test/xml/AutoRacingResultsXML.xml",
662 check "deleting auto_racing_results deletes its children (fractional KPH)"
663 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
665 check ("deleting auto_racing_results deletes its children " ++
666 "(No Most_Laps_Leading)")
667 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
669 check desc path = testCase desc $ do
670 results <- unsafe_unpickle path pickle_message
671 let a = undefined :: AutoRacingResults
672 let b = undefined :: AutoRacingResultsListing
673 let c = undefined :: AutoRacingResultsRaceInformation
675 actual <- withSqliteConn ":memory:" $ runDbConn $ do
676 runMigration silentMigrationLogger $ do
680 _ <- dbimport results
682 count_a <- countAll a
683 count_b <- countAll b
684 count_c <- countAll c
685 return $ sum [count_a, count_b, count_c]