src/TSN/XML/AutoRacingResults.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each
  10 --   \<message\> element contains a \<Race_Information\> and a bunch of
  11 --   \<Listing\>s.
  12 --
  13 module TSN.XML.AutoRacingResults (
  14   dtd,
  15   pickle_message,
  16   -- * Tests
  17   auto_racing_results_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   AutoRacingResultsConstructor(..),
  20   AutoRacingResultsListingConstructor(..),
  21   AutoRacingResultsRaceInformationConstructor(..) )
  22 where
  23
  24 -- System imports.
  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 (
  32   countAll,
  33   deleteAll,
  34   migrate,
  35   runMigration,
  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 (
  41   groundhog,
  42   mkPersist )
  43 import Test.Tasty ( TestTree, testGroup )
  44 import Test.Tasty.HUnit ( (@?=), testCase )
  45 import Text.XML.HXT.Core (
  46   PU,
  47   xp11Tuple,
  48   xp13Tuple,
  49   xpAttr,
  50   xpDefault,
  51   xpElem,
  52   xpInt,
  53   xpList,
  54   xpOption,
  55   xpPair,
  56   xpPrim,
  57   xpText,
  58   xpTriple,
  59   xpWrap )
  60
  61 -- Local imports.
  62 import TSN.Codegen ( tsn_codegen_config )
  63 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  64 import TSN.Picklers (
  65   xp_earnings,
  66   xp_fracpart_only_double,
  67   xp_datetime,
  68   xp_time_stamp )
  69 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  70 import Xml (
  71   Child(..),
  72   FromXml(..),
  73   FromXmlFk(..),
  74   ToDb(..),
  75   pickle_unpickle,
  76   unpickleable,
  77   unsafe_unpickle )
  78
  79
  80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  81 --
  82 dtd :: String
  83 dtd = "AutoRacingResultsXML.dtd"
  84
  85 --
  86 -- DB/XML data types
  87 --
  88
  89 -- * AutoRacingResults/Message
  90
  91 -- | Database representation of a 'Message'. Comparatively, it lacks
  92 --   the listings and race information since they are linked via a
  93 --   foreign key.
  94 --
  95 data AutoRacingResults =
  96   AutoRacingResults {
  97     db_xml_file_id :: Int,
  98     db_heading :: String,
  99     db_category :: String,
 100     db_sport :: String,
 101     db_race_id :: Int,
 102     db_race_date :: UTCTime,
 103     db_title :: String,
 104     db_track_location :: String,
 105     db_laps_remaining :: Int,
 106     db_checkered_flag :: Bool,
 107     db_time_stamp :: UTCTime }
 108   deriving (Eq, Show)
 109
 110
 111
 112 -- | XML Representation of an 'AutoRacingResults'. It has the same
 113 --   fields, but in addition contains the 'xml_listings' and
 114 --   'xml_race_information'.
 115 --
 116 data Message =
 117   Message {
 118     xml_xml_file_id :: Int,
 119     xml_heading :: String,
 120     xml_category :: String,
 121     xml_sport :: String,
 122     xml_race_id :: Int,
 123     xml_race_date :: UTCTime,
 124     xml_title :: String,
 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 }
 131   deriving (Eq, Show)
 132
 133
 134 instance ToDb Message where
 135   -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
 136   --
 137   type Db Message = AutoRacingResults
 138
 139
 140 -- | The 'FromXml' instance for 'Message' is required for the
 141 --   'XmlImport' instance.
 142 --
 143 instance FromXml Message where
 144   -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
 145   --   the 'xml_listings' and 'xml_race_information'.
 146   --
 147   from_xml Message{..} =
 148     AutoRacingResults {
 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 }
 160
 161
 162 -- | This allows us to insert the XML representation 'Message'
 163 --   directly.
 164 --
 165 instance XmlImport Message
 166
 167
 168 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
 169
 170 -- | Database representation of a \<Listing\> contained within a
 171 --   \<message\>.
 172 --
 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,
 179     db_driver_id :: Int,
 180     db_driver :: String,
 181     db_car_make :: String,
 182     db_points :: Int,
 183     db_laps_completed :: Int,
 184     db_laps_leading :: Int,
 185     db_status :: Maybe String,
 186     db_dnf :: Maybe Bool,
 187     db_nc :: Maybe Bool,
 188     db_earnings :: Maybe Int }
 189
 190
 191 -- | XML representation of a \<Listing\> contained within a
 192 --   \<message\>.
 193 --
 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,
 202     xml_points :: Int,
 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 }
 209   deriving (Eq, Show)
 210
 211
 212 instance ToDb AutoRacingResultsListingXml where
 213   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 214   --   an 'AutoRacingResultsListing'.
 215   --
 216   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 217
 218
 219 instance Child AutoRacingResultsListingXml where
 220   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 221   --   foreign key to) a 'AutoRacingResults'.
 222   --
 223   type Parent AutoRacingResultsListingXml = AutoRacingResults
 224
 225
 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.
 230   --
 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,
 244       db_dnf = xml_dnf,
 245       db_nc = xml_nc,
 246       db_earnings = xml_earnings }
 247
 248
 249 -- | This allows us to insert the XML representation
 250 --   'AutoRacingResultsListingXml' directly.
 251 --
 252 instance XmlImportFk AutoRacingResultsListingXml
 253
 254
 255
 256 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
 257
 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.
 263 --
 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.
 268 --
 269 data MostLapsLeading =
 270   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)
 275
 276
 277 -- | Database representation of a \<Race_Information\> contained
 278 --   within a \<message\>.
 279 --
 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
 283 --   fields.
 284 --
 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,
 293     db_laps :: Int,
 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 }
 303
 304
 305 -- | XML representation of a \<Listing\> contained within a
 306 --   \<message\>.
 307 --
 308 data AutoRacingResultsRaceInformationXml =
 309   AutoRacingResultsRaceInformationXml {
 310     xml_track_length :: String,
 311     xml_track_length_kph :: Double,
 312     xml_laps :: Int,
 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 }
 322   deriving (Eq,Show)
 323
 324
 325 instance ToDb AutoRacingResultsRaceInformationXml where
 326   -- | The database analogue of an
 327   --   'AutoRacingResultsRaceInformationXml' is an
 328   --   'AutoRacingResultsRaceInformation'.
 329   --
 330   type Db AutoRacingResultsRaceInformationXml =
 331     AutoRacingResultsRaceInformation
 332
 333
 334 instance Child AutoRacingResultsRaceInformationXml where
 335   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 336   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 337   --
 338   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 339
 340
 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.
 345   --
 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,
 351       db_laps = xml_laps,
 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 }
 361     where
 362       -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
 363       -- the database with an (embedded) 'MostLapsLeading' with three
 364       -- missing fields.
 365       most_laps_leading =
 366         fromMaybe (MostLapsLeading Nothing Nothing Nothing)
 367                   xml_most_laps_leading
 368
 369
 370 -- | This allows us to insert the XML representation
 371 --   'AutoRacingResultsRaceInformationXml' directly.
 372 --
 373 instance XmlImportFk AutoRacingResultsRaceInformationXml
 374
 375
 376
 377 --
 378 -- * Database stuff.
 379 --
 380
 381 instance DbImport Message where
 382   dbmigrate _ =
 383     run_dbmigrate $ do
 384       migrate (undefined :: AutoRacingResults)
 385       migrate (undefined :: AutoRacingResultsListing)
 386       migrate (undefined :: AutoRacingResultsRaceInformation)
 387
 388   -- | We insert the message, then use its ID to insert the listings
 389   --   and race information.
 390   dbimport m = do
 391     msg_id <- insert_xml m
 392
 393     insert_xml_fk_ msg_id (xml_race_information m)
 394
 395     forM_ (xml_listings m) $ insert_xml_fk_ msg_id
 396
 397     return ImportSucceeded
 398
 399
 400
 401 mkPersist tsn_codegen_config [groundhog|
 402 - entity: AutoRacingResults
 403   dbName: auto_racing_results
 404   constructors:
 405     - name: AutoRacingResults
 406       uniques:
 407         - name: unique_auto_racing_results
 408           type: constraint
 409           # Prevent multiple imports of the same message.
 410           fields: [db_xml_file_id]
 411
 412
 413 - entity: AutoRacingResultsListing
 414   dbName: auto_racing_results_listings
 415   constructors:
 416     - name: AutoRacingResultsListing
 417       fields:
 418         - name: db_auto_racing_results_id
 419           reference:
 420             onDelete: cascade
 421
 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
 427   constructors:
 428     - name: AutoRacingResultsRaceInformation
 429       fields:
 430         - name: db_auto_racing_results_id'
 431           dbName: auto_racing_results_id
 432           reference:
 433             onDelete: cascade
 434         - name: db_most_laps_leading
 435           embeddedType:
 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}
 440
 441 - embedded: MostLapsLeading
 442   fields:
 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
 449 |]
 450
 451
 452 ---
 453 --- Pickling
 454 ---
 455
 456 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 457 --
 458 pickle_listing :: PU AutoRacingResultsListingXml
 459 pickle_listing =
 460   xpElem "Listing" $
 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)
 475   where
 476     from_tuple = uncurryN AutoRacingResultsListingXml
 477     to_tuple m = (xml_finish_position m,
 478                   xml_starting_position m,
 479                   xml_car_number m,
 480                   xml_driver_id m,
 481                   xml_driver m,
 482                   xml_car_make m,
 483                   xml_points m,
 484                   xml_laps_completed m,
 485                   xml_laps_leading m,
 486                   xml_status m,
 487                   xml_dnf m,
 488                   xml_nc m,
 489                   xml_earnings m)
 490
 491
 492 -- | Pickler for the top-level 'Message'.
 493 --
 494 pickle_message :: PU Message
 495 pickle_message =
 496   xpElem "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)
 511   where
 512     from_tuple = uncurryN Message
 513     to_tuple m = (xml_xml_file_id m,
 514                   xml_heading m,
 515                   xml_category m,
 516                   xml_sport m,
 517                   xml_race_id m,
 518                   xml_race_date m,
 519                   xml_title m,
 520                   xml_track_location m,
 521                   xml_laps_remaining m,
 522                   xml_checkered_flag m,
 523                   xml_listings m,
 524                   xml_race_information m,
 525                   xml_time_stamp m)
 526
 527
 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).
 535 --
 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)
 543   where
 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
 548
 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)
 559
 560
 561 -- | Pickler for the \<Race_Information\> child of \<message\>.
 562 --
 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.
 572 --
 573 --   Clear as mud, I know.
 574 --
 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" $
 583                    xpPair xpText
 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)
 595   where
 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
 601
 602     -- And here we have to re-pair the first two.
 603     to_tuple m = ((xml_track_length m, xml_track_length_kph m),
 604                   xml_laps m,
 605                   xml_average_speed_mph m,
 606                   xml_average_speed_kph m,
 607                   xml_average_speed m,
 608                   xml_time_of_race m,
 609                   xml_margin_of_victory m,
 610                   xml_cautions m,
 611                   xml_lead_changes m,
 612                   xml_lap_leaders m,
 613                   xml_most_laps_leading m)
 614
 615 --
 616 -- * Tasty Tests
 617 --
 618
 619 -- | A list of all tests for this module.
 620 --
 621 auto_racing_results_tests :: TestTree
 622 auto_racing_results_tests =
 623   testGroup
 624     "AutoRacingResults tests"
 625     [ test_on_delete_cascade,
 626       test_pickle_of_unpickle_is_identity,
 627       test_unpickle_succeeds ]
 628
 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.
 632 --
 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",
 637
 638     check "pickle composed with unpickle is the identity (fractional KPH)"
 639           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 640
 641     check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
 642           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
 643   where
 644     check desc path = testCase desc $ do
 645       (expected, actual) <- pickle_unpickle pickle_message path
 646       actual @?= expected
 647
 648
 649
 650 -- | Make sure we can actually unpickle these things.
 651 --
 652 test_unpickle_succeeds :: TestTree
 653 test_unpickle_succeeds = testGroup "unpickle tests"
 654   [ check "unpickling succeeds"
 655           "test/xml/AutoRacingResultsXML.xml",
 656
 657     check "unpickling succeeds (fractional KPH)"
 658           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 659
 660     check "unpickling succeeds (no Most_Laps_Leading)"
 661           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 662   where
 663     check desc path = testCase desc $ do
 664       actual <- unpickleable path pickle_message
 665       let expected = True
 666       actual @?= expected
 667
 668
 669
 670 -- | Make sure everything gets deleted when we delete the top-level
 671 --   record.
 672 --
 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",
 677
 678     check "deleting auto_racing_results deletes its children (fractional KPH)"
 679           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 680
 681     check ("deleting auto_racing_results deletes its children " ++
 682            "(No Most_Laps_Leading)")
 683           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 684   where
 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
 690
 691       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 692                   runMigration silentMigrationLogger $ do
 693                     migrate a
 694                     migrate b
 695                     migrate c
 696                   _ <- dbimport results
 697                   deleteAll a
 698                   count_a <- countAll a
 699                   count_b <- countAll b
 700                   count_c <- countAll c
 701                   return $ sum [count_a, count_b, count_c]
 702       let expected = 0
 703       actual @?= expected