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.Time ( UTCTime(..) )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Data.Typeable ( Typeable )
  30 import Database.Groundhog (
  31   countAll,
  32   deleteAll,
  33   migrate,
  34   runMigration,
  35   silentMigrationLogger )
  36 import Database.Groundhog.Core ( DefaultKey )
  37 import Database.Groundhog.Generic ( runDbConn )
  38 import Database.Groundhog.Sqlite ( withSqliteConn )
  39 import Database.Groundhog.TH (
  40   groundhog,
  41   mkPersist )
  42 import Test.Tasty ( TestTree, testGroup )
  43 import Test.Tasty.HUnit ( (@?=), testCase )
  44 import Text.XML.HXT.Core (
  45   PU,
  46   xp11Tuple,
  47   xp13Tuple,
  48   xpAttr,
  49   xpDefault,
  50   xpElem,
  51   xpInt,
  52   xpList,
  53   xpOption,
  54   xpPair,
  55   xpPrim,
  56   xpText,
  57   xpTriple,
  58   xpWrap )
  59
  60 -- Local imports.
  61 import TSN.Codegen ( tsn_codegen_config )
  62 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  63 import TSN.Picklers (
  64   xp_earnings,
  65   xp_fracpart_only_double,
  66   xp_datetime,
  67   xp_time_stamp )
  68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  69 import Xml (
  70   Child(..),
  71   FromXml(..),
  72   FromXmlFk(..),
  73   ToDb(..),
  74   pickle_unpickle,
  75   unpickleable,
  76   unsafe_unpickle )
  77
  78
  79 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  80 --
  81 dtd :: String
  82 dtd = "AutoRacingResultsXML.dtd"
  83
  84 --
  85 -- DB/XML data types
  86 --
  87
  88 -- * AutoRacingResults/Message
  89
  90 -- | Database representation of a 'Message'. Comparatively, it lacks
  91 --   the listings and race information since they are linked via a
  92 --   foreign key.
  93 --
  94 data AutoRacingResults =
  95   AutoRacingResults {
  96     db_xml_file_id :: Int,
  97     db_heading :: String,
  98     db_category :: String,
  99     db_sport :: String,
 100     db_race_id :: Int,
 101     db_race_date :: UTCTime,
 102     db_title :: String,
 103     db_track_location :: String,
 104     db_laps_remaining :: Int,
 105     db_checkered_flag :: Bool,
 106     db_time_stamp :: UTCTime }
 107   deriving (Eq, Show)
 108
 109
 110
 111 -- | XML Representation of an 'AutoRacingResults'. It has the same
 112 --   fields, but in addition contains the 'xml_listings' and
 113 --   'xml_race_information'.
 114 --
 115 data Message =
 116   Message {
 117     xml_xml_file_id :: Int,
 118     xml_heading :: String,
 119     xml_category :: String,
 120     xml_sport :: String,
 121     xml_race_id :: Int,
 122     xml_race_date :: UTCTime,
 123     xml_title :: String,
 124     xml_track_location :: String,
 125     xml_laps_remaining :: Int,
 126     xml_checkered_flag :: Bool,
 127     xml_listings :: [AutoRacingResultsListingXml],
 128     xml_race_information :: AutoRacingResultsRaceInformationXml,
 129     xml_time_stamp :: UTCTime }
 130   deriving (Eq, Show)
 131
 132
 133 instance ToDb Message where
 134   -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
 135   --
 136   type Db Message = AutoRacingResults
 137
 138
 139 -- | The 'FromXml' instance for 'Message' is required for the
 140 --   'XmlImport' instance.
 141 --
 142 instance FromXml Message where
 143   -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
 144   --   the 'xml_listings' and 'xml_race_information'.
 145   --
 146   from_xml Message{..} =
 147     AutoRacingResults {
 148       db_xml_file_id = xml_xml_file_id,
 149       db_heading = xml_heading,
 150       db_category = xml_category,
 151       db_sport = xml_sport,
 152       db_race_id = xml_race_id,
 153       db_race_date = xml_race_date,
 154       db_title = xml_title,
 155       db_track_location = xml_track_location,
 156       db_laps_remaining = xml_laps_remaining,
 157       db_checkered_flag = xml_checkered_flag,
 158       db_time_stamp = xml_time_stamp }
 159
 160
 161 -- | This allows us to insert the XML representation 'Message'
 162 --   directly.
 163 --
 164 instance XmlImport Message
 165
 166
 167 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
 168
 169 -- | Database representation of a \<Listing\> contained within a
 170 --   \<message\>.
 171 --
 172 data AutoRacingResultsListing =
 173   AutoRacingResultsListing {
 174     db_auto_racing_results_id :: DefaultKey AutoRacingResults,
 175     db_finish_position :: Int,
 176     db_starting_position :: Int,
 177     db_car_number :: Int,
 178     db_driver_id :: Int,
 179     db_driver :: String,
 180     db_car_make :: String,
 181     db_points :: Int,
 182     db_laps_completed :: Int,
 183     db_laps_leading :: Int,
 184     db_status :: Maybe String,
 185     db_dnf :: Maybe Bool,
 186     db_nc :: Maybe Bool,
 187     db_earnings :: Maybe Int }
 188
 189
 190 -- | XML representation of a \<Listing\> contained within a
 191 --   \<message\>.
 192 --
 193 data AutoRacingResultsListingXml =
 194   AutoRacingResultsListingXml {
 195     xml_finish_position :: Int,
 196     xml_starting_position :: Int,
 197     xml_car_number :: Int,
 198     xml_driver_id :: Int,
 199     xml_driver :: String,
 200     xml_car_make :: String,
 201     xml_points :: Int,
 202     xml_laps_completed :: Int,
 203     xml_laps_leading :: Int,
 204     xml_status :: Maybe String,
 205     xml_dnf :: Maybe Bool,
 206     xml_nc :: Maybe Bool,
 207     xml_earnings :: Maybe Int }
 208   deriving (Eq, Show)
 209
 210
 211 instance ToDb AutoRacingResultsListingXml where
 212   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 213   --   an 'AutoRacingResultsListing'.
 214   --
 215   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 216
 217
 218 instance Child AutoRacingResultsListingXml where
 219   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 220   --   foreign key to) a 'AutoRacingResults'.
 221   --
 222   type Parent AutoRacingResultsListingXml = AutoRacingResults
 223
 224
 225 instance FromXmlFk AutoRacingResultsListingXml where
 226   -- | To convert an 'AutoRacingResultsListingXml' to an
 227   --   'AutoRacingResultsListing', we add the foreign key and copy
 228   --   everything else verbatim.
 229   --
 230   from_xml_fk fk AutoRacingResultsListingXml{..} =
 231     AutoRacingResultsListing {
 232       db_auto_racing_results_id = fk,
 233       db_finish_position = xml_finish_position,
 234       db_starting_position = xml_starting_position,
 235       db_car_number = xml_car_number,
 236       db_driver_id = xml_driver_id,
 237       db_driver = xml_driver,
 238       db_car_make = xml_car_make,
 239       db_points = xml_points,
 240       db_laps_completed = xml_laps_completed,
 241       db_laps_leading = xml_laps_leading,
 242       db_status = xml_status,
 243       db_dnf = xml_dnf,
 244       db_nc = xml_nc,
 245       db_earnings = xml_earnings }
 246
 247
 248 -- | This allows us to insert the XML representation
 249 --   'AutoRacingResultsListingXml' directly.
 250 --
 251 instance XmlImportFk AutoRacingResultsListingXml
 252
 253
 254
 255 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
 256
 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.
 262 --
 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.
 267 --
 268 data MostLapsLeading =
 269   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)
 274
 275
 276 -- | Database representation of a \<Race_Information\> contained
 277 --   within a \<message\>.
 278 --
 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
 282 --   fields.
 283 --
 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,
 292     db_laps :: Int,
 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 }
 302
 303
 304 -- | XML representation of a \<Listing\> contained within a
 305 --   \<message\>.
 306 --
 307 data AutoRacingResultsRaceInformationXml =
 308   AutoRacingResultsRaceInformationXml {
 309     xml_track_length :: String,
 310     xml_track_length_kph :: Double,
 311     xml_laps :: Int,
 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 }
 321   deriving (Eq,Show)
 322
 323
 324 instance ToDb AutoRacingResultsRaceInformationXml where
 325   -- | The database analogue of an
 326   --   'AutoRacingResultsRaceInformationXml' is an
 327   --   'AutoRacingResultsRaceInformation'.
 328   --
 329   type Db AutoRacingResultsRaceInformationXml =
 330     AutoRacingResultsRaceInformation
 331
 332
 333 instance Child AutoRacingResultsRaceInformationXml where
 334   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 335   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 336   --
 337   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 338
 339
 340 instance FromXmlFk AutoRacingResultsRaceInformationXml where
 341   -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
 342   --   'AutoRacingResultsRaceInformartion', we add the foreign key and
 343   --   copy everything else verbatim.
 344   --
 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,
 350       db_laps = xml_laps,
 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 }
 360     where
 361       -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
 362       -- the database with an (embedded) 'MostLapsLeading' with three
 363       -- missing fields.
 364       most_laps_leading =
 365         case xml_most_laps_leading of
 366           Just mll -> mll
 367           Nothing  -> MostLapsLeading Nothing Nothing Nothing
 368
 369 -- | This allows us to insert the XML representation
 370 --   'AutoRacingResultsRaceInformationXml' directly.
 371 --
 372 instance XmlImportFk AutoRacingResultsRaceInformationXml
 373
 374
 375
 376 --
 377 -- * Database stuff.
 378 --
 379
 380 instance DbImport Message where
 381   dbmigrate _ =
 382     run_dbmigrate $ do
 383       migrate (undefined :: AutoRacingResults)
 384       migrate (undefined :: AutoRacingResultsListing)
 385       migrate (undefined :: AutoRacingResultsRaceInformation)
 386
 387   -- | We insert the message, then use its ID to insert the listings
 388   --   and race information.
 389   dbimport m = do
 390     msg_id <- insert_xml m
 391
 392     insert_xml_fk_ msg_id (xml_race_information m)
 393
 394     forM_ (xml_listings m) $ insert_xml_fk_ msg_id
 395
 396     return ImportSucceeded
 397
 398
 399
 400 mkPersist tsn_codegen_config [groundhog|
 401 - entity: AutoRacingResults
 402   dbName: auto_racing_results
 403   constructors:
 404     - name: AutoRacingResults
 405       uniques:
 406         - name: unique_auto_racing_results
 407           type: constraint
 408           # Prevent multiple imports of the same message.
 409           fields: [db_xml_file_id]
 410
 411
 412 - entity: AutoRacingResultsListing
 413   dbName: auto_racing_results_listings
 414   constructors:
 415     - name: AutoRacingResultsListing
 416       fields:
 417         - name: db_auto_racing_results_id
 418           reference:
 419             onDelete: cascade
 420
 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
 426   constructors:
 427     - name: AutoRacingResultsRaceInformation
 428       fields:
 429         - name: db_auto_racing_results_id'
 430           dbName: auto_racing_results_id
 431           reference:
 432             onDelete: cascade
 433         - name: db_most_laps_leading
 434           embeddedType:
 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}
 439
 440 - embedded: MostLapsLeading
 441   fields:
 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
 448 |]
 449
 450
 451 ---
 452 --- Pickling
 453 ---
 454
 455 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 456 --
 457 pickle_listing :: PU AutoRacingResultsListingXml
 458 pickle_listing =
 459   xpElem "Listing" $
 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)
 474   where
 475     from_tuple = uncurryN AutoRacingResultsListingXml
 476     to_tuple m = (xml_finish_position m,
 477                   xml_starting_position m,
 478                   xml_car_number m,
 479                   xml_driver_id m,
 480                   xml_driver m,
 481                   xml_car_make m,
 482                   xml_points m,
 483                   xml_laps_completed m,
 484                   xml_laps_leading m,
 485                   xml_status m,
 486                   xml_dnf m,
 487                   xml_nc m,
 488                   xml_earnings m)
 489
 490
 491 -- | Pickler for the top-level 'Message'.
 492 --
 493 pickle_message :: PU Message
 494 pickle_message =
 495   xpElem "message" $
 496     xpWrap (from_tuple, to_tuple) $
 497     xp13Tuple (xpElem "XML_File_ID" xpInt)
 498               (xpElem "heading" xpText)
 499               (xpElem "category" xpText)
 500               (xpElem "sport" xpText)
 501               (xpElem "RaceID" xpInt)
 502               (xpElem "RaceDate" xp_datetime)
 503               (xpElem "Title" xpText)
 504               (xpElem "Track_Location" xpText)
 505               (xpElem "Laps_Remaining" xpInt)
 506               (xpElem "Checkered_Flag" xpPrim)
 507               (xpList pickle_listing)
 508               pickle_race_information
 509               (xpElem "time_stamp" xp_time_stamp)
 510   where
 511     from_tuple = uncurryN Message
 512     to_tuple m = (xml_xml_file_id m,
 513                   xml_heading m,
 514                   xml_category m,
 515                   xml_sport m,
 516                   xml_race_id m,
 517                   xml_race_date m,
 518                   xml_title m,
 519                   xml_track_location m,
 520                   xml_laps_remaining m,
 521                   xml_checkered_flag m,
 522                   xml_listings m,
 523                   xml_race_information m,
 524                   xml_time_stamp m)
 525
 526
 527 -- | Pickler for the \<Most_Laps_Leading\> child of a
 528 --   \<Race_Information\>. This is complicated by the fact that the
 529 --   three fields we're trying to parse are not actually optional;
 530 --   only the entire \<Most_Laps_Leading\> is. So we always wrap what
 531 --   we parse in a 'Just', and when converting from the DB to XML,
 532 --   we'll drop the entire element if any of its fields are missing
 533 --   (which they never should be).
 534 --
 535 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
 536 pickle_most_laps_leading =
 537   xpElem "Most_Laps_Leading" $
 538     xpWrap (from_tuple, to_tuple) $
 539     xpTriple (xpOption $ xpElem "DriverID" xpInt)
 540              (xpOption $ xpElem "Driver" xpText)
 541              (xpOption $ xpElem "NumberOfLaps" xpInt)
 542   where
 543     from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
 544     from_tuple (Just x, Just y, Just z) =
 545       Just $ MostLapsLeading (Just x) (Just y) (Just z)
 546     from_tuple _ = Nothing
 547
 548     -- Sure had to go out of my way to avoid the warnings about unused
 549     -- db_most_laps_foo fields here.
 550     to_tuple :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
 551     to_tuple Nothing = (Nothing, Nothing, Nothing)
 552     to_tuple (Just (MostLapsLeading 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 m) = (db_most_laps_leading_driver_id m,
 556                          db_most_laps_leading_driver m,
 557                          db_most_laps_leading_number_of_laps m)
 558
 559
 560 -- | Pickler for the \<Race_Information\> child of \<message\>.
 561 --
 562 --   There's so much voodoo going on here. We have a double-layered
 563 --   Maybe on top of the MostLapsLeading. When unpickling, we return a
 564 --   Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
 565 --   missing. But if the entire element is missing, unpickling
 566 --   fails. 'xpOption' doesn't fix this because it would give us a
 567 --   Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
 568 --   default of (Nothing :: Maybe MostLapsLeading) to stick one in
 569 --   there if unpicking a (Maybe MostLapsLeading) fails because
 570 --   \<Most_Laps_Leading\> is missing.
 571 --
 572 --   Clear as mud, I know.
 573 --
 574 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
 575 pickle_race_information =
 576   xpElem "Race_Information" $
 577     xpWrap (from_tuple, to_tuple) $
 578     xp11Tuple (-- I can't think of another way to get both the
 579                -- TrackLength and its KPH attribute. So we shove them
 580                -- both in a 2-tuple. This should probably be an embedded type!
 581                  xpElem "TrackLength" $
 582                    xpPair xpText
 583                           (xpAttr "KPH" xp_fracpart_only_double) )
 584               (xpElem "Laps" xpInt)
 585               (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
 586               (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
 587               (xpOption $ xpElem "AverageSpeed" xpPrim)
 588               (xpOption $ xpElem "TimeOfRace" xpText)
 589               (xpOption $ xpElem "MarginOfVictory" xpText)
 590               (xpOption $ xpElem "Cautions" xpText)
 591               (xpOption $ xpElem "LeadChanges" xpText)
 592               (xpOption $ xpElem "LapLeaders" xpText)
 593               (xpDefault Nothing pickle_most_laps_leading)
 594   where
 595     -- Derp. Since the first two are paired, we have to
 596     -- manually unpack the bazillion arguments.
 597     from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
 598         AutoRacingResultsRaceInformationXml
 599           x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
 600
 601     -- And here we have to re-pair the first two.
 602     to_tuple m = ((xml_track_length m, xml_track_length_kph m),
 603                   xml_laps m,
 604                   xml_average_speed_mph m,
 605                   xml_average_speed_kph m,
 606                   xml_average_speed m,
 607                   xml_time_of_race m,
 608                   xml_margin_of_victory m,
 609                   xml_cautions m,
 610                   xml_lead_changes m,
 611                   xml_lap_leaders m,
 612                   xml_most_laps_leading m)
 613
 614 --
 615 -- * Tasty Tests
 616 --
 617
 618 -- | A list of all tests for this module.
 619 --
 620 auto_racing_results_tests :: TestTree
 621 auto_racing_results_tests =
 622   testGroup
 623     "AutoRacingResults tests"
 624     [ test_on_delete_cascade,
 625       test_pickle_of_unpickle_is_identity,
 626       test_unpickle_succeeds ]
 627
 628 -- | If we unpickle something and then pickle it, we should wind up
 629 --   with the same thing we started with. WARNING: success of this
 630 --   test does not mean that unpickling succeeded.
 631 --
 632 test_pickle_of_unpickle_is_identity :: TestTree
 633 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 634   [ check "pickle composed with unpickle is the identity"
 635           "test/xml/AutoRacingResultsXML.xml",
 636
 637     check "pickle composed with unpickle is the identity (fractional KPH)"
 638           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 639
 640     check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
 641           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
 642   where
 643     check desc path = testCase desc $ do
 644       (expected, actual) <- pickle_unpickle pickle_message path
 645       actual @?= expected
 646
 647
 648
 649 -- | Make sure we can actually unpickle these things.
 650 --
 651 test_unpickle_succeeds :: TestTree
 652 test_unpickle_succeeds = testGroup "unpickle tests"
 653   [ check "unpickling succeeds"
 654           "test/xml/AutoRacingResultsXML.xml",
 655
 656     check "unpickling succeeds (fractional KPH)"
 657           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 658
 659     check "unpickling succeeds (no Most_Laps_Leading)"
 660           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 661   where
 662     check desc path = testCase desc $ do
 663       actual <- unpickleable path pickle_message
 664       let expected = True
 665       actual @?= expected
 666
 667
 668
 669 -- | Make sure everything gets deleted when we delete the top-level
 670 --   record.
 671 --
 672 test_on_delete_cascade :: TestTree
 673 test_on_delete_cascade = testGroup "cascading delete tests"
 674   [ check "deleting auto_racing_results deletes its children"
 675           "test/xml/AutoRacingResultsXML.xml",
 676
 677     check "deleting auto_racing_results deletes its children (fractional KPH)"
 678           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 679
 680     check ("deleting auto_racing_results deletes its children " ++
 681            "(No Most_Laps_Leading)")
 682           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 683   where
 684     check desc path = testCase desc $ do
 685       results <- unsafe_unpickle path pickle_message
 686       let a = undefined :: AutoRacingResults
 687       let b = undefined :: AutoRacingResultsListing
 688       let c = undefined :: AutoRacingResultsRaceInformation
 689
 690       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 691                   runMigration silentMigrationLogger $ do
 692                     migrate a
 693                     migrate b
 694                     migrate c
 695                   _ <- dbimport results
 696                   deleteAll a
 697                   count_a <- countAll a
 698                   count_b <- countAll b
 699                   count_c <- countAll c
 700                   return $ sum [count_a, count_b, count_c]
 701       let expected = 0
 702       actual @?= expected