src/TSN/XML/AutoRacingResults.hs

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