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(..), prepend, 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 }
196 deriving ( GHC.Generic )
198 -- | For 'Generics.prepend'.
200 instance Generic AutoRacingResultsListing
202 -- | XML representation of a \<Listing\> contained within a
205 data AutoRacingResultsListingXml =
206 AutoRacingResultsListingXml {
207 xml_finish_position :: Int,
208 xml_starting_position :: Int,
209 xml_car_number :: Int,
210 xml_driver_id :: Int,
211 xml_driver :: String,
212 xml_car_make :: String,
214 xml_laps_completed :: Int,
215 xml_laps_leading :: Int,
216 xml_status :: Maybe String,
217 xml_dnf :: Maybe Bool,
218 xml_nc :: Maybe Bool,
219 xml_earnings :: Maybe Int }
220 deriving (Eq, GHC.Generic, Show)
222 -- | For 'Generics.to_tuple'.
224 instance Generic AutoRacingResultsListingXml
226 instance ToDb AutoRacingResultsListingXml where
227 -- | The database analogue of an 'AutoRacingResultsListingXml' is
228 -- an 'AutoRacingResultsListing'.
230 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
233 instance Child AutoRacingResultsListingXml where
234 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
235 -- foreign key to) a 'AutoRacingResults'.
237 type Parent AutoRacingResultsListingXml = AutoRacingResults
240 instance FromXmlFk AutoRacingResultsListingXml where
241 -- | To convert an 'AutoRacingResultsListingXml' to an
242 -- 'AutoRacingResultsListing', we add the foreign key and copy
243 -- everything else verbatim.
245 from_xml_fk = prepend
248 -- | This allows us to insert the XML representation
249 -- 'AutoRacingResultsListingXml' directly.
251 instance XmlImportFk AutoRacingResultsListingXml
255 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
257 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
258 -- contains exactly three fields, so we just embed those three into
259 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
260 -- the \"db_\" prefix since our field namer is going to strip of
261 -- everything before the first underscore.
263 -- We make the three fields optional because the entire
264 -- \<Most_Laps_Leading\> is apparently optional (although it is
265 -- usually present). A 'Nothing' in the XML should get turned into
266 -- three 'Nothing's in the DB.
268 data MostLapsLeading =
270 db_most_laps_leading_driver_id :: Maybe Int,
271 db_most_laps_leading_driver :: Maybe String,
272 db_most_laps_leading_number_of_laps :: Maybe Int }
273 deriving (Data, Eq, Show, Typeable)
276 -- | Database representation of a \<Race_Information\> contained
277 -- within a \<message\>.
279 -- The 'db_most_laps_leading' field is not optional because when we
280 -- convert from our XML representation, a missing 'MostLapsLeading'
281 -- will be replaced with a 'MostLapsLeading' with three missing
284 data AutoRacingResultsRaceInformation =
285 AutoRacingResultsRaceInformation {
286 -- Note the apostrophe to disambiguate it from the
287 -- AutoRacingResultsListing field.
288 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
289 db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
290 -- like \"1.25 miles\".
291 db_track_length_kph :: Double,
293 db_average_speed_mph :: Maybe Double,
294 db_average_speed_kph :: Maybe Double,
295 db_average_speed :: Maybe Double,
296 db_time_of_race :: Maybe String,
297 db_margin_of_victory :: Maybe String,
298 db_cautions :: Maybe String,
299 db_lead_changes :: Maybe String,
300 db_lap_leaders :: Maybe String,
301 db_most_laps_leading :: MostLapsLeading }
304 -- | XML representation of a \<Listing\> contained within a
307 data AutoRacingResultsRaceInformationXml =
308 AutoRacingResultsRaceInformationXml {
309 xml_track_length :: String,
310 xml_track_length_kph :: Double,
312 xml_average_speed_mph :: Maybe Double,
313 xml_average_speed_kph :: Maybe Double,
314 xml_average_speed :: Maybe Double,
315 xml_time_of_race :: Maybe String,
316 xml_margin_of_victory :: Maybe String,
317 xml_cautions :: Maybe String,
318 xml_lead_changes :: Maybe String,
319 xml_lap_leaders :: Maybe String,
320 xml_most_laps_leading :: Maybe MostLapsLeading }
324 instance ToDb AutoRacingResultsRaceInformationXml where
325 -- | The database analogue of an
326 -- 'AutoRacingResultsRaceInformationXml' is an
327 -- 'AutoRacingResultsRaceInformation'.
329 type Db AutoRacingResultsRaceInformationXml =
330 AutoRacingResultsRaceInformation
333 instance Child AutoRacingResultsRaceInformationXml where
334 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
335 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
337 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
340 instance FromXmlFk AutoRacingResultsRaceInformationXml where
341 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
342 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
343 -- massage the 'MostLapsLeading' embedded type,
345 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
346 AutoRacingResultsRaceInformation {
347 db_auto_racing_results_id' = fk,
348 db_track_length = xml_track_length,
349 db_track_length_kph = xml_track_length_kph,
351 db_average_speed_mph = xml_average_speed_mph,
352 db_average_speed_kph = xml_average_speed_kph,
353 db_average_speed = xml_average_speed,
354 db_time_of_race = xml_time_of_race,
355 db_margin_of_victory = xml_margin_of_victory,
356 db_cautions = xml_cautions,
357 db_lead_changes = xml_lead_changes,
358 db_lap_leaders = xml_lap_leaders,
359 db_most_laps_leading = most_laps_leading }
361 -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
362 -- the database with an (embedded) 'MostLapsLeading' with three
365 fromMaybe (MostLapsLeading Nothing Nothing Nothing)
366 xml_most_laps_leading
369 -- | This allows us to insert the XML representation
370 -- 'AutoRacingResultsRaceInformationXml' directly.
372 instance XmlImportFk AutoRacingResultsRaceInformationXml
380 instance DbImport Message where
383 migrate (undefined :: AutoRacingResults)
384 migrate (undefined :: AutoRacingResultsListing)
385 migrate (undefined :: AutoRacingResultsRaceInformation)
387 -- | We insert the message, then use its ID to insert the listings
388 -- and race information.
390 msg_id <- insert_xml m
392 insert_xml_fk_ msg_id (xml_race_information m)
394 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
396 return ImportSucceeded
400 mkPersist tsn_codegen_config [groundhog|
401 - entity: AutoRacingResults
402 dbName: auto_racing_results
404 - name: AutoRacingResults
406 - name: unique_auto_racing_results
408 # Prevent multiple imports of the same message.
409 fields: [db_xml_file_id]
412 - entity: AutoRacingResultsListing
413 dbName: auto_racing_results_listings
415 - name: AutoRacingResultsListing
417 - name: db_auto_racing_results_id
421 # Note the apostrophe in the foreign key. This is to disambiguate
422 # it from the AutoRacingResultsListing foreign key of the same name.
423 # We strip it out of the dbName.
424 - entity: AutoRacingResultsRaceInformation
425 dbName: auto_racing_results_race_information
427 - name: AutoRacingResultsRaceInformation
429 - name: db_auto_racing_results_id'
430 dbName: auto_racing_results_id
433 - name: db_most_laps_leading
435 - {name: most_laps_leading_driver_id,
436 dbName: most_laps_leading_driver_id}
437 - {name: most_laps_leading_driver,
438 dbName: most_laps_leading_driver}
440 - embedded: MostLapsLeading
442 - name: db_most_laps_leading_driver_id
443 dbName: most_laps_leading_driver_id
444 - name: db_most_laps_leading_driver
445 dbName: most_laps_leading_driver
446 - name: db_most_laps_leading_number_of_laps
447 dbName: most_laps_leading_number_of_laps
455 -- | Pickler for the \<Listing\>s contained within \<message\>s.
457 pickle_listing :: PU AutoRacingResultsListingXml
460 xpWrap (from_tuple, to_tuple) $
461 xp13Tuple (xpElem "FinishPosition" xpInt)
462 (xpElem "StartingPosition" xpInt)
463 (xpElem "CarNumber" xpInt)
464 (xpElem "DriverID" xpInt)
465 (xpElem "Driver" xpText)
466 (xpElem "CarMake" xpText)
467 (xpElem "Points" xpInt)
468 (xpElem "Laps_Completed" xpInt)
469 (xpElem "Laps_Leading" xpInt)
470 (xpElem "Status" $ xpOption xpText)
471 (xpOption $ xpElem "DNF" xpPrim)
472 (xpOption $ xpElem "NC" xpPrim)
473 (xpElem "Earnings" xp_earnings)
475 from_tuple = uncurryN AutoRacingResultsListingXml
478 -- | Pickler for the top-level 'Message'.
480 pickle_message :: PU Message
483 xpWrap (from_tuple, to_tuple) $
484 xp13Tuple (xpElem "XML_File_ID" xpInt)
485 (xpElem "heading" xpText)
486 (xpElem "category" xpText)
487 (xpElem "sport" xpText)
488 (xpElem "RaceID" xpInt)
489 (xpElem "RaceDate" xp_datetime)
490 (xpElem "Title" xpText)
491 (xpElem "Track_Location" xpText)
492 (xpElem "Laps_Remaining" xpInt)
493 (xpElem "Checkered_Flag" xpPrim)
494 (xpList pickle_listing)
495 pickle_race_information
496 (xpElem "time_stamp" xp_time_stamp)
498 from_tuple = uncurryN Message
501 -- | Pickler for the \<Most_Laps_Leading\> child of a
502 -- \<Race_Information\>. This is complicated by the fact that the
503 -- three fields we're trying to parse are not actually optional;
504 -- only the entire \<Most_Laps_Leading\> is. So we always wrap what
505 -- we parse in a 'Just', and when converting from the DB to XML,
506 -- we'll drop the entire element if any of its fields are missing
507 -- (which they never should be).
509 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
510 pickle_most_laps_leading =
511 xpElem "Most_Laps_Leading" $
512 xpWrap (from_tuple, to_tuple') $
513 xpTriple (xpOption $ xpElem "DriverID" xpInt)
514 (xpOption $ xpElem "Driver" xpText)
515 (xpOption $ xpElem "NumberOfLaps" xpInt)
517 from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
518 from_tuple (Just x, Just y, Just z) =
519 Just $ MostLapsLeading (Just x) (Just y) (Just z)
520 from_tuple _ = Nothing
522 -- Sure had to go out of my way to avoid the warnings about unused
523 -- db_most_laps_foo fields here.
524 to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
525 to_tuple' Nothing = (Nothing, Nothing, Nothing)
526 to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
527 to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
528 to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
529 to_tuple' (Just m) = (db_most_laps_leading_driver_id m,
530 db_most_laps_leading_driver m,
531 db_most_laps_leading_number_of_laps m)
534 -- | Pickler for the \<Race_Information\> child of \<message\>.
536 -- There's so much voodoo going on here. We have a double-layered
537 -- Maybe on top of the MostLapsLeading. When unpickling, we return a
538 -- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
539 -- missing. But if the entire element is missing, unpickling
540 -- fails. 'xpOption' doesn't fix this because it would give us a
541 -- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
542 -- default of (Nothing :: Maybe MostLapsLeading) to stick one in
543 -- there if unpicking a (Maybe MostLapsLeading) fails because
544 -- \<Most_Laps_Leading\> is missing.
546 -- Clear as mud, I know.
548 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
549 pickle_race_information =
550 xpElem "Race_Information" $
551 xpWrap (from_tuple, to_tuple') $
552 xp11Tuple (-- I can't think of another way to get both the
553 -- TrackLength and its KPH attribute. So we shove them
554 -- both in a 2-tuple. This should probably be an embedded type!
555 xpElem "TrackLength" $
557 (xpAttr "KPH" xp_fracpart_only_double) )
558 (xpElem "Laps" xpInt)
559 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
560 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
561 (xpOption $ xpElem "AverageSpeed" xpPrim)
562 (xpOption $ xpElem "TimeOfRace" xpText)
563 (xpOption $ xpElem "MarginOfVictory" xpText)
564 (xpOption $ xpElem "Cautions" xpText)
565 (xpOption $ xpElem "LeadChanges" xpText)
566 (xpOption $ xpElem "LapLeaders" xpText)
567 (xpDefault Nothing pickle_most_laps_leading)
569 -- Derp. Since the first two are paired, we have to
570 -- manually unpack the bazillion arguments.
571 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
572 AutoRacingResultsRaceInformationXml
573 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
575 -- And here we have to re-pair the first two.
576 to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
578 xml_average_speed_mph m,
579 xml_average_speed_kph m,
582 xml_margin_of_victory m,
586 xml_most_laps_leading m)
592 -- | A list of all tests for this module.
594 auto_racing_results_tests :: TestTree
595 auto_racing_results_tests =
597 "AutoRacingResults tests"
598 [ test_on_delete_cascade,
599 test_pickle_of_unpickle_is_identity,
600 test_unpickle_succeeds ]
602 -- | If we unpickle something and then pickle it, we should wind up
603 -- with the same thing we started with. WARNING: success of this
604 -- test does not mean that unpickling succeeded.
606 test_pickle_of_unpickle_is_identity :: TestTree
607 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
608 [ check "pickle composed with unpickle is the identity"
609 "test/xml/AutoRacingResultsXML.xml",
611 check "pickle composed with unpickle is the identity (fractional KPH)"
612 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
614 check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
615 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
617 check desc path = testCase desc $ do
618 (expected, actual) <- pickle_unpickle pickle_message path
623 -- | Make sure we can actually unpickle these things.
625 test_unpickle_succeeds :: TestTree
626 test_unpickle_succeeds = testGroup "unpickle tests"
627 [ check "unpickling succeeds"
628 "test/xml/AutoRacingResultsXML.xml",
630 check "unpickling succeeds (fractional KPH)"
631 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
633 check "unpickling succeeds (no Most_Laps_Leading)"
634 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
636 check desc path = testCase desc $ do
637 actual <- unpickleable path pickle_message
643 -- | Make sure everything gets deleted when we delete the top-level
646 test_on_delete_cascade :: TestTree
647 test_on_delete_cascade = testGroup "cascading delete tests"
648 [ check "deleting auto_racing_results deletes its children"
649 "test/xml/AutoRacingResultsXML.xml",
651 check "deleting auto_racing_results deletes its children (fractional KPH)"
652 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
654 check ("deleting auto_racing_results deletes its children " ++
655 "(No Most_Laps_Leading)")
656 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
658 check desc path = testCase desc $ do
659 results <- unsafe_unpickle path pickle_message
660 let a = undefined :: AutoRacingResults
661 let b = undefined :: AutoRacingResultsListing
662 let c = undefined :: AutoRacingResultsRaceInformation
664 actual <- withSqliteConn ":memory:" $ runDbConn $ do
665 runMigration silentMigrationLogger $ do
669 _ <- dbimport results
671 count_a <- countAll a
672 count_b <- countAll b
673 count_c <- countAll c
674 return $ sum [count_a, count_b, count_c]