src/TSN/XML/AutoRacingResults.hs

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