2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE QuasiQuotes #-}
7 {-# LANGUAGE RecordWildCards #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 {-# LANGUAGE TypeFamilies #-}
11 -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each
12 -- \<message\> element contains a \<Race_Information\> and a bunch of
15 module TSN.XML.AutoRacingResults (
19 auto_racing_results_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 AutoRacingResultsConstructor(..),
22 AutoRacingResultsListingConstructor(..),
23 AutoRacingResultsRaceInformationConstructor(..) )
27 import Control.Monad ( forM_ )
28 import Data.Data ( Data )
29 import Data.Maybe ( fromMaybe )
30 import Data.Time ( UTCTime(..) )
31 import Data.Tuple.Curry ( uncurryN )
32 import Data.Typeable ( Typeable )
33 import Database.Groundhog (
38 silentMigrationLogger )
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.Sqlite ( withSqliteConn )
42 import Database.Groundhog.TH (
45 import qualified GHC.Generics as GHC ( Generic )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
65 import Generics ( Generic(..), prepend, to_tuple )
66 import TSN.Codegen ( tsn_codegen_config )
67 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
70 xp_fracpart_only_double,
73 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
84 -- | The DTD to which this module corresponds. Used to invoke dbimport.
87 dtd = "AutoRacingResultsXML.dtd"
93 -- * AutoRacingResults/Message
95 -- | Database representation of a 'Message'. Comparatively, it lacks
96 -- the listings and race information since they are linked via a
99 data AutoRacingResults =
101 db_xml_file_id :: Int,
102 db_heading :: String,
103 db_category :: String,
106 db_race_date :: UTCTime,
108 db_track_location :: String,
109 db_laps_remaining :: Int,
110 db_checkered_flag :: Bool,
111 db_time_stamp :: UTCTime }
116 -- | XML Representation of an 'AutoRacingResults'. It has the same
117 -- fields, but in addition contains the 'xml_listings' and
118 -- 'xml_race_information'.
122 xml_xml_file_id :: Int,
123 xml_heading :: String,
124 xml_category :: String,
127 xml_race_date :: UTCTime,
129 xml_track_location :: String,
130 xml_laps_remaining :: Int,
131 xml_checkered_flag :: Bool,
132 xml_listings :: [AutoRacingResultsListingXml],
133 xml_race_information :: AutoRacingResultsRaceInformationXml,
134 xml_time_stamp :: UTCTime }
135 deriving (Eq, GHC.Generic, Show)
137 -- | For 'Generics.to_tuple'.
139 instance Generic Message
142 instance ToDb Message where
143 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
145 type Db Message = AutoRacingResults
148 -- | The 'FromXml' instance for 'Message' is required for the
149 -- 'XmlImport' instance.
151 instance FromXml Message where
152 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
153 -- the 'xml_listings' and 'xml_race_information'.
155 from_xml Message{..} =
157 db_xml_file_id = xml_xml_file_id,
158 db_heading = xml_heading,
159 db_category = xml_category,
160 db_sport = xml_sport,
161 db_race_id = xml_race_id,
162 db_race_date = xml_race_date,
163 db_title = xml_title,
164 db_track_location = xml_track_location,
165 db_laps_remaining = xml_laps_remaining,
166 db_checkered_flag = xml_checkered_flag,
167 db_time_stamp = xml_time_stamp }
170 -- | This allows us to insert the XML representation 'Message'
173 instance XmlImport Message
176 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
178 -- | Database representation of a \<Listing\> contained within a
179 -- \<message\>. The leading underscores prevent unused field
182 data AutoRacingResultsListing =
183 AutoRacingResultsListing {
184 _db_auto_racing_results_id :: DefaultKey AutoRacingResults,
185 _db_finish_position :: Int,
186 _db_starting_position :: Int,
187 _db_car_number :: Int,
188 _db_driver_id :: Int,
189 _db_driver :: String,
190 _db_car_make :: String,
192 _db_laps_completed :: Int,
193 _db_laps_leading :: Int,
194 _db_status :: Maybe String,
195 _db_dnf :: Maybe Bool,
196 _db_nc :: Maybe Bool,
197 _db_earnings :: Maybe Int }
198 deriving ( GHC.Generic )
200 -- | For 'Generics.prepend'.
202 instance Generic AutoRacingResultsListing
204 -- | XML representation of a \<Listing\> contained within a
205 -- \<message\>. The leading underscores prevent unused field
208 data AutoRacingResultsListingXml =
209 AutoRacingResultsListingXml {
210 _xml_finish_position :: Int,
211 _xml_starting_position :: Int,
212 _xml_car_number :: Int,
213 _xml_driver_id :: Int,
214 _xml_driver :: String,
215 _xml_car_make :: String,
217 _xml_laps_completed :: Int,
218 _xml_laps_leading :: Int,
219 _xml_status :: Maybe String,
220 _xml_dnf :: Maybe Bool,
221 _xml_nc :: Maybe Bool,
222 _xml_earnings :: Maybe Int }
223 deriving (Eq, GHC.Generic, Show)
225 -- | For 'Generics.to_tuple'.
227 instance Generic AutoRacingResultsListingXml
229 instance ToDb AutoRacingResultsListingXml where
230 -- | The database analogue of an 'AutoRacingResultsListingXml' is
231 -- an 'AutoRacingResultsListing'.
233 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
236 instance Child AutoRacingResultsListingXml where
237 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
238 -- foreign key to) a 'AutoRacingResults'.
240 type Parent AutoRacingResultsListingXml = AutoRacingResults
243 instance FromXmlFk AutoRacingResultsListingXml where
244 -- | To convert an 'AutoRacingResultsListingXml' to an
245 -- 'AutoRacingResultsListing', we add the foreign key and copy
246 -- everything else verbatim.
248 from_xml_fk = prepend
251 -- | This allows us to insert the XML representation
252 -- 'AutoRacingResultsListingXml' directly.
254 instance XmlImportFk AutoRacingResultsListingXml
258 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
260 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
261 -- contains exactly three fields, so we just embed those three into
262 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
263 -- the \"db_\" prefix since our field namer is going to strip of
264 -- everything before the first underscore.
266 -- We make the three fields optional because the entire
267 -- \<Most_Laps_Leading\> is apparently optional (although it is
268 -- usually present). A 'Nothing' in the XML should get turned into
269 -- three 'Nothing's in the DB.
271 data MostLapsLeading =
273 db_most_laps_leading_driver_id :: Maybe Int,
274 db_most_laps_leading_driver :: Maybe String,
275 db_most_laps_leading_number_of_laps :: Maybe Int }
276 deriving (Data, Eq, Show, Typeable)
279 -- | Database representation of a \<Race_Information\> contained
280 -- within a \<message\>.
282 -- The 'db_most_laps_leading' field is not optional because when we
283 -- convert from our XML representation, a missing 'MostLapsLeading'
284 -- will be replaced with a 'MostLapsLeading' with three missing
287 data AutoRacingResultsRaceInformation =
288 AutoRacingResultsRaceInformation {
289 -- Note the apostrophe to disambiguate it from the
290 -- AutoRacingResultsListing field.
291 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
292 db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
293 -- like \"1.25 miles\".
294 db_track_length_kph :: Double,
296 db_average_speed_mph :: Maybe Double,
297 db_average_speed_kph :: Maybe Double,
298 db_average_speed :: Maybe Double,
299 db_time_of_race :: Maybe String,
300 db_margin_of_victory :: Maybe String,
301 db_cautions :: Maybe String,
302 db_lead_changes :: Maybe String,
303 db_lap_leaders :: Maybe String,
304 db_most_laps_leading :: MostLapsLeading }
307 -- | XML representation of a \<Listing\> contained within a
310 data AutoRacingResultsRaceInformationXml =
311 AutoRacingResultsRaceInformationXml {
312 xml_track_length :: String,
313 xml_track_length_kph :: Double,
315 xml_average_speed_mph :: Maybe Double,
316 xml_average_speed_kph :: Maybe Double,
317 xml_average_speed :: Maybe Double,
318 xml_time_of_race :: Maybe String,
319 xml_margin_of_victory :: Maybe String,
320 xml_cautions :: Maybe String,
321 xml_lead_changes :: Maybe String,
322 xml_lap_leaders :: Maybe String,
323 xml_most_laps_leading :: Maybe MostLapsLeading }
327 instance ToDb AutoRacingResultsRaceInformationXml where
328 -- | The database analogue of an
329 -- 'AutoRacingResultsRaceInformationXml' is an
330 -- 'AutoRacingResultsRaceInformation'.
332 type Db AutoRacingResultsRaceInformationXml =
333 AutoRacingResultsRaceInformation
336 instance Child AutoRacingResultsRaceInformationXml where
337 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
338 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
340 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
343 instance FromXmlFk AutoRacingResultsRaceInformationXml where
344 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
345 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
346 -- massage the 'MostLapsLeading' embedded type,
348 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
349 AutoRacingResultsRaceInformation {
350 db_auto_racing_results_id' = fk,
351 db_track_length = xml_track_length,
352 db_track_length_kph = xml_track_length_kph,
354 db_average_speed_mph = xml_average_speed_mph,
355 db_average_speed_kph = xml_average_speed_kph,
356 db_average_speed = xml_average_speed,
357 db_time_of_race = xml_time_of_race,
358 db_margin_of_victory = xml_margin_of_victory,
359 db_cautions = xml_cautions,
360 db_lead_changes = xml_lead_changes,
361 db_lap_leaders = xml_lap_leaders,
362 db_most_laps_leading = most_laps_leading }
364 -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
365 -- the database with an (embedded) 'MostLapsLeading' with three
368 fromMaybe (MostLapsLeading Nothing Nothing Nothing)
369 xml_most_laps_leading
372 -- | This allows us to insert the XML representation
373 -- 'AutoRacingResultsRaceInformationXml' directly.
375 instance XmlImportFk AutoRacingResultsRaceInformationXml
383 instance DbImport Message where
386 migrate (undefined :: AutoRacingResults)
387 migrate (undefined :: AutoRacingResultsListing)
388 migrate (undefined :: AutoRacingResultsRaceInformation)
390 -- | We insert the message, then use its ID to insert the listings
391 -- and race information.
393 msg_id <- insert_xml m
395 insert_xml_fk_ msg_id (xml_race_information m)
397 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
399 return ImportSucceeded
403 mkPersist tsn_codegen_config [groundhog|
404 - entity: AutoRacingResults
405 dbName: auto_racing_results
407 - name: AutoRacingResults
409 - name: unique_auto_racing_results
411 # Prevent multiple imports of the same message.
412 fields: [db_xml_file_id]
415 - entity: AutoRacingResultsListing
416 dbName: auto_racing_results_listings
418 - name: AutoRacingResultsListing
420 - name: _db_auto_racing_results_id
424 # Note the apostrophe in the foreign key. This is to disambiguate
425 # it from the AutoRacingResultsListing foreign key of the same name.
426 # We strip it out of the dbName.
427 - entity: AutoRacingResultsRaceInformation
428 dbName: auto_racing_results_race_information
430 - name: AutoRacingResultsRaceInformation
432 - name: db_auto_racing_results_id'
433 dbName: auto_racing_results_id
436 - name: db_most_laps_leading
438 - {name: most_laps_leading_driver_id,
439 dbName: most_laps_leading_driver_id}
440 - {name: most_laps_leading_driver,
441 dbName: most_laps_leading_driver}
443 - embedded: MostLapsLeading
445 - name: db_most_laps_leading_driver_id
446 dbName: most_laps_leading_driver_id
447 - name: db_most_laps_leading_driver
448 dbName: most_laps_leading_driver
449 - name: db_most_laps_leading_number_of_laps
450 dbName: most_laps_leading_number_of_laps
458 -- | Pickler for the \<Listing\>s contained within \<message\>s.
460 pickle_listing :: PU AutoRacingResultsListingXml
463 xpWrap (from_tuple, to_tuple) $
464 xp13Tuple (xpElem "FinishPosition" xpInt)
465 (xpElem "StartingPosition" xpInt)
466 (xpElem "CarNumber" xpInt)
467 (xpElem "DriverID" xpInt)
468 (xpElem "Driver" xpText)
469 (xpElem "CarMake" xpText)
470 (xpElem "Points" xpInt)
471 (xpElem "Laps_Completed" xpInt)
472 (xpElem "Laps_Leading" xpInt)
473 (xpElem "Status" $ xpOption xpText)
474 (xpOption $ xpElem "DNF" xpPrim)
475 (xpOption $ xpElem "NC" xpPrim)
476 (xpElem "Earnings" xp_earnings)
478 from_tuple = uncurryN AutoRacingResultsListingXml
481 -- | Pickler for the top-level 'Message'.
483 pickle_message :: PU Message
486 xpWrap (from_tuple, to_tuple) $
487 xp13Tuple (xpElem "XML_File_ID" xpInt)
488 (xpElem "heading" xpText)
489 (xpElem "category" xpText)
490 (xpElem "sport" xpText)
491 (xpElem "RaceID" xpInt)
492 (xpElem "RaceDate" xp_datetime)
493 (xpElem "Title" xpText)
494 (xpElem "Track_Location" xpText)
495 (xpElem "Laps_Remaining" xpInt)
496 (xpElem "Checkered_Flag" xpPrim)
497 (xpList pickle_listing)
498 pickle_race_information
499 (xpElem "time_stamp" xp_time_stamp)
501 from_tuple = uncurryN Message
504 -- | Pickler for the \<Most_Laps_Leading\> child of a
505 -- \<Race_Information\>. This is complicated by the fact that the
506 -- three fields we're trying to parse are not actually optional;
507 -- only the entire \<Most_Laps_Leading\> is. So we always wrap what
508 -- we parse in a 'Just', and when converting from the DB to XML,
509 -- we'll drop the entire element if any of its fields are missing
510 -- (which they never should be).
512 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
513 pickle_most_laps_leading =
514 xpElem "Most_Laps_Leading" $
515 xpWrap (from_tuple, to_tuple') $
516 xpTriple (xpOption $ xpElem "DriverID" xpInt)
517 (xpOption $ xpElem "Driver" xpText)
518 (xpOption $ xpElem "NumberOfLaps" xpInt)
520 from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
521 from_tuple (Just x, Just y, Just z) =
522 Just $ MostLapsLeading (Just x) (Just y) (Just z)
523 from_tuple _ = Nothing
525 -- Sure had to go out of my way to avoid the warnings about unused
526 -- db_most_laps_foo fields here.
527 to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
528 to_tuple' Nothing = (Nothing, Nothing, Nothing)
529 to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
530 to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
531 to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
532 to_tuple' (Just m) = (db_most_laps_leading_driver_id m,
533 db_most_laps_leading_driver m,
534 db_most_laps_leading_number_of_laps m)
537 -- | Pickler for the \<Race_Information\> child of \<message\>.
539 -- There's so much voodoo going on here. We have a double-layered
540 -- Maybe on top of the MostLapsLeading. When unpickling, we return a
541 -- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
542 -- missing. But if the entire element is missing, unpickling
543 -- fails. 'xpOption' doesn't fix this because it would give us a
544 -- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
545 -- default of (Nothing :: Maybe MostLapsLeading) to stick one in
546 -- there if unpicking a (Maybe MostLapsLeading) fails because
547 -- \<Most_Laps_Leading\> is missing.
549 -- Clear as mud, I know.
551 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
552 pickle_race_information =
553 xpElem "Race_Information" $
554 xpWrap (from_tuple, to_tuple') $
555 xp11Tuple (-- I can't think of another way to get both the
556 -- TrackLength and its KPH attribute. So we shove them
557 -- both in a 2-tuple. This should probably be an embedded type!
558 xpElem "TrackLength" $
560 (xpAttr "KPH" xp_fracpart_only_double) )
561 (xpElem "Laps" xpInt)
562 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
563 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
564 (xpOption $ xpElem "AverageSpeed" xpPrim)
565 (xpOption $ xpElem "TimeOfRace" xpText)
566 (xpOption $ xpElem "MarginOfVictory" xpText)
567 (xpOption $ xpElem "Cautions" xpText)
568 (xpOption $ xpElem "LeadChanges" xpText)
569 (xpOption $ xpElem "LapLeaders" xpText)
570 (xpDefault Nothing pickle_most_laps_leading)
572 -- Derp. Since the first two are paired, we have to
573 -- manually unpack the bazillion arguments.
574 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
575 AutoRacingResultsRaceInformationXml
576 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
578 -- And here we have to re-pair the first two.
579 to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
581 xml_average_speed_mph m,
582 xml_average_speed_kph m,
585 xml_margin_of_victory m,
589 xml_most_laps_leading m)
595 -- | A list of all tests for this module.
597 auto_racing_results_tests :: TestTree
598 auto_racing_results_tests =
600 "AutoRacingResults tests"
601 [ test_on_delete_cascade,
602 test_pickle_of_unpickle_is_identity,
603 test_unpickle_succeeds ]
605 -- | If we unpickle something and then pickle it, we should wind up
606 -- with the same thing we started with. WARNING: success of this
607 -- test does not mean that unpickling succeeded.
609 test_pickle_of_unpickle_is_identity :: TestTree
610 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
611 [ check "pickle composed with unpickle is the identity"
612 "test/xml/AutoRacingResultsXML.xml",
614 check "pickle composed with unpickle is the identity (fractional KPH)"
615 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
617 check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
618 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
620 check desc path = testCase desc $ do
621 (expected, actual) <- pickle_unpickle pickle_message path
626 -- | Make sure we can actually unpickle these things.
628 test_unpickle_succeeds :: TestTree
629 test_unpickle_succeeds = testGroup "unpickle tests"
630 [ check "unpickling succeeds"
631 "test/xml/AutoRacingResultsXML.xml",
633 check "unpickling succeeds (fractional KPH)"
634 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
636 check "unpickling succeeds (no Most_Laps_Leading)"
637 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
639 check desc path = testCase desc $ do
640 actual <- unpickleable path pickle_message
646 -- | Make sure everything gets deleted when we delete the top-level
649 test_on_delete_cascade :: TestTree
650 test_on_delete_cascade = testGroup "cascading delete tests"
651 [ check "deleting auto_racing_results deletes its children"
652 "test/xml/AutoRacingResultsXML.xml",
654 check "deleting auto_racing_results deletes its children (fractional KPH)"
655 "test/xml/AutoRacingResultsXML-fractional-kph.xml",
657 check ("deleting auto_racing_results deletes its children " ++
658 "(No Most_Laps_Leading)")
659 "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
661 check desc path = testCase desc $ do
662 results <- unsafe_unpickle path pickle_message
663 let a = undefined :: AutoRacingResults
664 let b = undefined :: AutoRacingResultsListing
665 let c = undefined :: AutoRacingResultsRaceInformation
667 actual <- withSqliteConn ":memory:" $ runDbConn $ do
668 runMigration silentMigrationLogger $ do
672 _ <- dbimport results
674 count_a <- countAll a
675 count_b <- countAll b
676 count_c <- countAll c
677 return $ sum [count_a, count_b, count_c]