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 qualified Data.Vector.HFixed as H ( HVector, cons, convert )
33 import Database.Groundhog (
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
43 import qualified GHC.Generics as GHC ( Generic )
44 import Test.Tasty ( TestTree, testGroup )
45 import Test.Tasty.HUnit ( (@?=), testCase )
46 import Text.XML.HXT.Core (
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 xp_fracpart_only_double,
70 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
81 -- | The DTD to which this module corresponds. Used to invoke dbimport.
84 dtd = "AutoRacingResultsXML.dtd"
90 -- * AutoRacingResults/Message
92 -- | Database representation of a 'Message'. Comparatively, it lacks
93 -- the listings and race information since they are linked via a
96 data AutoRacingResults =
98 db_xml_file_id :: Int,
100 db_category :: String,
103 db_race_date :: UTCTime,
105 db_track_location :: String,
106 db_laps_remaining :: Int,
107 db_checkered_flag :: Bool,
108 db_time_stamp :: UTCTime }
113 -- | XML Representation of an 'AutoRacingResults'. It has the same
114 -- fields, but in addition contains the 'xml_listings' and
115 -- 'xml_race_information'.
119 xml_xml_file_id :: Int,
120 xml_heading :: String,
121 xml_category :: String,
124 xml_race_date :: UTCTime,
126 xml_track_location :: String,
127 xml_laps_remaining :: Int,
128 xml_checkered_flag :: Bool,
129 xml_listings :: [AutoRacingResultsListingXml],
130 xml_race_information :: AutoRacingResultsRaceInformationXml,
131 xml_time_stamp :: UTCTime }
132 deriving (Eq, GHC.Generic, Show)
134 -- | For 'H.convert'.
136 instance H.HVector Message
139 instance ToDb Message where
140 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
142 type Db Message = AutoRacingResults
145 -- | The 'FromXml' instance for 'Message' is required for the
146 -- 'XmlImport' instance.
148 instance FromXml Message where
149 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
150 -- the 'xml_listings' and 'xml_race_information'.
152 from_xml Message{..} =
154 db_xml_file_id = xml_xml_file_id,
155 db_heading = xml_heading,
156 db_category = xml_category,
157 db_sport = xml_sport,
158 db_race_id = xml_race_id,
159 db_race_date = xml_race_date,
160 db_title = xml_title,
161 db_track_location = xml_track_location,
162 db_laps_remaining = xml_laps_remaining,
163 db_checkered_flag = xml_checkered_flag,
164 db_time_stamp = xml_time_stamp }
167 -- | This allows us to insert the XML representation 'Message'
170 instance XmlImport Message
173 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
175 -- | Database representation of a \<Listing\> contained within a
176 -- \<message\>. The leading underscores prevent unused field
179 data AutoRacingResultsListing =
180 AutoRacingResultsListing {
181 _db_auto_racing_results_id :: DefaultKey AutoRacingResults,
182 _db_finish_position :: Int,
183 _db_starting_position :: Int,
184 _db_car_number :: Int,
185 _db_driver_id :: Int,
186 _db_driver :: String,
187 _db_car_make :: String,
189 _db_laps_completed :: Int,
190 _db_laps_leading :: Int,
191 _db_status :: Maybe String,
192 _db_dnf :: Maybe Bool,
193 _db_nc :: Maybe Bool,
194 _db_earnings :: Maybe Int }
195 deriving ( GHC.Generic )
197 -- | For 'H.convert' and 'H.cons'.
199 instance H.HVector AutoRacingResultsListing
201 -- | XML representation of a \<Listing\> contained within a
202 -- \<message\>. The leading underscores prevent unused field
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 'H.convert'.
224 instance H.HVector 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.
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, H.convert) $
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, H.convert) $
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 runMigrationSilent $ 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]