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 qualified Data.Vector.HFixed as H ( HVector, cons, convert )
  33 import Database.Groundhog (
  34   countAll,
  35   deleteAll,
  36   migrate )
  37 import Database.Groundhog.Core ( DefaultKey )
  38 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
  39 import Database.Groundhog.Sqlite ( withSqliteConn )
  40 import Database.Groundhog.TH (
  41   groundhog,
  42   mkPersist )
  43 import qualified GHC.Generics as GHC ( Generic )
  44 import Test.Tasty ( TestTree, testGroup )
  45 import Test.Tasty.HUnit ( (@?=), testCase )
  46 import Text.XML.HXT.Core (
  47   PU,
  48   xp11Tuple,
  49   xp13Tuple,
  50   xpAttr,
  51   xpDefault,
  52   xpElem,
  53   xpInt,
  54   xpList,
  55   xpOption,
  56   xpPair,
  57   xpPrim,
  58   xpText,
  59   xpTriple,
  60   xpWrap )
  61
  62 -- Local imports.
  63 import TSN.Codegen ( tsn_codegen_config )
  64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  65 import TSN.Picklers (
  66   xp_earnings,
  67   xp_fracpart_only_double,
  68   xp_datetime,
  69   xp_time_stamp )
  70 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  71 import Xml (
  72   Child(..),
  73   FromXml(..),
  74   FromXmlFk(..),
  75   ToDb(..),
  76   pickle_unpickle,
  77   unpickleable,
  78   unsafe_unpickle )
  79
  80
  81 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  82 --
  83 dtd :: String
  84 dtd = "AutoRacingResultsXML.dtd"
  85
  86 --
  87 -- DB/XML data types
  88 --
  89
  90 -- * AutoRacingResults/Message
  91
  92 -- | Database representation of a 'Message'. Comparatively, it lacks
  93 --   the listings and race information since they are linked via a
  94 --   foreign key.
  95 --
  96 data AutoRacingResults =
  97   AutoRacingResults {
  98     db_xml_file_id :: Int,
  99     db_heading :: String,
 100     db_category :: String,
 101     db_sport :: String,
 102     db_race_id :: Int,
 103     db_race_date :: UTCTime,
 104     db_title :: String,
 105     db_track_location :: String,
 106     db_laps_remaining :: Int,
 107     db_checkered_flag :: Bool,
 108     db_time_stamp :: UTCTime }
 109   deriving (Eq, Show)
 110
 111
 112
 113 -- | XML Representation of an 'AutoRacingResults'. It has the same
 114 --   fields, but in addition contains the 'xml_listings' and
 115 --   'xml_race_information'.
 116 --
 117 data Message =
 118   Message {
 119     xml_xml_file_id :: Int,
 120     xml_heading :: String,
 121     xml_category :: String,
 122     xml_sport :: String,
 123     xml_race_id :: Int,
 124     xml_race_date :: UTCTime,
 125     xml_title :: String,
 126     xml_track_location :: String,
 127     xml_laps_remaining :: Int,
 128     xml_checkered_flag :: Bool,
 129     xml_listings :: [AutoRacingResultsListingXml],
 130     xml_race_information :: AutoRacingResultsRaceInformationXml,
 131     xml_time_stamp :: UTCTime }
 132   deriving (Eq, GHC.Generic, Show)
 133
 134 -- | For 'H.convert'.
 135 --
 136 instance H.HVector Message
 137
 138
 139 instance ToDb Message where
 140   -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
 141   --
 142   type Db Message = AutoRacingResults
 143
 144
 145 -- | The 'FromXml' instance for 'Message' is required for the
 146 --   'XmlImport' instance.
 147 --
 148 instance FromXml Message where
 149   -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
 150   --   the 'xml_listings' and 'xml_race_information'.
 151   --
 152   from_xml Message{..} =
 153     AutoRacingResults {
 154       db_xml_file_id = xml_xml_file_id,
 155       db_heading = xml_heading,
 156       db_category = xml_category,
 157       db_sport = xml_sport,
 158       db_race_id = xml_race_id,
 159       db_race_date = xml_race_date,
 160       db_title = xml_title,
 161       db_track_location = xml_track_location,
 162       db_laps_remaining = xml_laps_remaining,
 163       db_checkered_flag = xml_checkered_flag,
 164       db_time_stamp = xml_time_stamp }
 165
 166
 167 -- | This allows us to insert the XML representation 'Message'
 168 --   directly.
 169 --
 170 instance XmlImport Message
 171
 172
 173 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
 174
 175 -- | Database representation of a \<Listing\> contained within a
 176 --   \<message\>. The leading underscores prevent unused field
 177 --   warnings.
 178 --
 179 data AutoRacingResultsListing =
 180   AutoRacingResultsListing {
 181     _db_auto_racing_results_id :: DefaultKey AutoRacingResults,
 182     _db_finish_position :: Int,
 183     _db_starting_position :: Int,
 184     _db_car_number :: Int,
 185     _db_driver_id :: Int,
 186     _db_driver :: String,
 187     _db_car_make :: String,
 188     _db_points :: Int,
 189     _db_laps_completed :: Int,
 190     _db_laps_leading :: Int,
 191     _db_status :: Maybe String,
 192     _db_dnf :: Maybe Bool,
 193     _db_nc :: Maybe Bool,
 194     _db_earnings :: Maybe Int }
 195   deriving ( GHC.Generic )
 196
 197 -- | For 'H.convert' and 'H.cons'.
 198 --
 199 instance H.HVector AutoRacingResultsListing
 200
 201 -- | XML representation of a \<Listing\> contained within a
 202 --   \<message\>. The leading underscores prevent unused field
 203 --   warnings.
 204 --
 205 data AutoRacingResultsListingXml =
 206   AutoRacingResultsListingXml {
 207     _xml_finish_position :: Int,
 208     _xml_starting_position :: Int,
 209     _xml_car_number :: Int,
 210     _xml_driver_id :: Int,
 211     _xml_driver :: String,
 212     _xml_car_make :: String,
 213     _xml_points :: Int,
 214     _xml_laps_completed :: Int,
 215     _xml_laps_leading :: Int,
 216     _xml_status :: Maybe String,
 217     _xml_dnf :: Maybe Bool,
 218     _xml_nc :: Maybe Bool,
 219     _xml_earnings :: Maybe Int }
 220   deriving (Eq, GHC.Generic, Show)
 221
 222 -- | For 'H.convert'.
 223 --
 224 instance H.HVector AutoRacingResultsListingXml
 225
 226 instance ToDb AutoRacingResultsListingXml where
 227   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 228   --   an 'AutoRacingResultsListing'.
 229   --
 230   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 231
 232
 233 instance Child AutoRacingResultsListingXml where
 234   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 235   --   foreign key to) a 'AutoRacingResults'.
 236   --
 237   type Parent AutoRacingResultsListingXml = AutoRacingResults
 238
 239
 240 instance FromXmlFk AutoRacingResultsListingXml where
 241   -- | To convert an 'AutoRacingResultsListingXml' to an
 242   --   'AutoRacingResultsListing', we add the foreign key and copy
 243   --   everything else verbatim.
 244   --
 245   from_xml_fk = H.cons
 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   --   massage the 'MostLapsLeading' embedded type,
 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         fromMaybe (MostLapsLeading Nothing Nothing Nothing)
 366                   xml_most_laps_leading
 367
 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, H.convert) $
 461     xp13Tuple (xpElem "FinishPosition" xpInt)
 462               (xpElem "StartingPosition" xpInt)
 463               (xpElem "CarNumber" xpInt)
 464               (xpElem "DriverID" xpInt)
 465               (xpElem "Driver" xpText)
 466               (xpElem "CarMake" xpText)
 467               (xpElem "Points" xpInt)
 468               (xpElem "Laps_Completed" xpInt)
 469               (xpElem "Laps_Leading" xpInt)
 470               (xpElem "Status" $ xpOption xpText)
 471               (xpOption $ xpElem "DNF" xpPrim)
 472               (xpOption $ xpElem "NC" xpPrim)
 473               (xpElem "Earnings" xp_earnings)
 474   where
 475     from_tuple = uncurryN AutoRacingResultsListingXml
 476
 477
 478 -- | Pickler for the top-level 'Message'.
 479 --
 480 pickle_message :: PU Message
 481 pickle_message =
 482   xpElem "message" $
 483     xpWrap (from_tuple, H.convert) $
 484     xp13Tuple (xpElem "XML_File_ID" xpInt)
 485               (xpElem "heading" xpText)
 486               (xpElem "category" xpText)
 487               (xpElem "sport" xpText)
 488               (xpElem "RaceID" xpInt)
 489               (xpElem "RaceDate" xp_datetime)
 490               (xpElem "Title" xpText)
 491               (xpElem "Track_Location" xpText)
 492               (xpElem "Laps_Remaining" xpInt)
 493               (xpElem "Checkered_Flag" xpPrim)
 494               (xpList pickle_listing)
 495               pickle_race_information
 496               (xpElem "time_stamp" xp_time_stamp)
 497   where
 498     from_tuple = uncurryN Message
 499
 500
 501 -- | Pickler for the \<Most_Laps_Leading\> child of a
 502 --   \<Race_Information\>. This is complicated by the fact that the
 503 --   three fields we're trying to parse are not actually optional;
 504 --   only the entire \<Most_Laps_Leading\> is. So we always wrap what
 505 --   we parse in a 'Just', and when converting from the DB to XML,
 506 --   we'll drop the entire element if any of its fields are missing
 507 --   (which they never should be).
 508 --
 509 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
 510 pickle_most_laps_leading =
 511   xpElem "Most_Laps_Leading" $
 512     xpWrap (from_tuple, to_tuple') $
 513     xpTriple (xpOption $ xpElem "DriverID" xpInt)
 514              (xpOption $ xpElem "Driver" xpText)
 515              (xpOption $ xpElem "NumberOfLaps" xpInt)
 516   where
 517     from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
 518     from_tuple (Just x, Just y, Just z) =
 519       Just $ MostLapsLeading (Just x) (Just y) (Just z)
 520     from_tuple _ = Nothing
 521
 522     -- Sure had to go out of my way to avoid the warnings about unused
 523     -- db_most_laps_foo fields here.
 524     to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
 525     to_tuple' Nothing = (Nothing, Nothing, Nothing)
 526     to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
 527     to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
 528     to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
 529     to_tuple' (Just m) = (db_most_laps_leading_driver_id m,
 530                           db_most_laps_leading_driver m,
 531                           db_most_laps_leading_number_of_laps m)
 532
 533
 534 -- | Pickler for the \<Race_Information\> child of \<message\>.
 535 --
 536 --   There's so much voodoo going on here. We have a double-layered
 537 --   Maybe on top of the MostLapsLeading. When unpickling, we return a
 538 --   Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
 539 --   missing. But if the entire element is missing, unpickling
 540 --   fails. 'xpOption' doesn't fix this because it would give us a
 541 --   Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
 542 --   default of (Nothing :: Maybe MostLapsLeading) to stick one in
 543 --   there if unpicking a (Maybe MostLapsLeading) fails because
 544 --   \<Most_Laps_Leading\> is missing.
 545 --
 546 --   Clear as mud, I know.
 547 --
 548 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
 549 pickle_race_information =
 550   xpElem "Race_Information" $
 551     xpWrap (from_tuple, to_tuple') $
 552     xp11Tuple (-- I can't think of another way to get both the
 553                -- TrackLength and its KPH attribute. So we shove them
 554                -- both in a 2-tuple. This should probably be an embedded type!
 555                  xpElem "TrackLength" $
 556                    xpPair xpText
 557                           (xpAttr "KPH" xp_fracpart_only_double) )
 558               (xpElem "Laps" xpInt)
 559               (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
 560               (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
 561               (xpOption $ xpElem "AverageSpeed" xpPrim)
 562               (xpOption $ xpElem "TimeOfRace" xpText)
 563               (xpOption $ xpElem "MarginOfVictory" xpText)
 564               (xpOption $ xpElem "Cautions" xpText)
 565               (xpOption $ xpElem "LeadChanges" xpText)
 566               (xpOption $ xpElem "LapLeaders" xpText)
 567               (xpDefault Nothing pickle_most_laps_leading)
 568   where
 569     -- Derp. Since the first two are paired, we have to
 570     -- manually unpack the bazillion arguments.
 571     from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
 572         AutoRacingResultsRaceInformationXml
 573           x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
 574
 575     -- And here we have to re-pair the first two.
 576     to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
 577                    xml_laps m,
 578                    xml_average_speed_mph m,
 579                    xml_average_speed_kph m,
 580                    xml_average_speed m,
 581                    xml_time_of_race m,
 582                    xml_margin_of_victory m,
 583                    xml_cautions m,
 584                    xml_lead_changes m,
 585                    xml_lap_leaders m,
 586                    xml_most_laps_leading m)
 587
 588 --
 589 -- * Tasty Tests
 590 --
 591
 592 -- | A list of all tests for this module.
 593 --
 594 auto_racing_results_tests :: TestTree
 595 auto_racing_results_tests =
 596   testGroup
 597     "AutoRacingResults tests"
 598     [ test_on_delete_cascade,
 599       test_pickle_of_unpickle_is_identity,
 600       test_unpickle_succeeds ]
 601
 602 -- | If we unpickle something and then pickle it, we should wind up
 603 --   with the same thing we started with. WARNING: success of this
 604 --   test does not mean that unpickling succeeded.
 605 --
 606 test_pickle_of_unpickle_is_identity :: TestTree
 607 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 608   [ check "pickle composed with unpickle is the identity"
 609           "test/xml/AutoRacingResultsXML.xml",
 610
 611     check "pickle composed with unpickle is the identity (fractional KPH)"
 612           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 613
 614     check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
 615           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
 616   where
 617     check desc path = testCase desc $ do
 618       (expected, actual) <- pickle_unpickle pickle_message path
 619       actual @?= expected
 620
 621
 622
 623 -- | Make sure we can actually unpickle these things.
 624 --
 625 test_unpickle_succeeds :: TestTree
 626 test_unpickle_succeeds = testGroup "unpickle tests"
 627   [ check "unpickling succeeds"
 628           "test/xml/AutoRacingResultsXML.xml",
 629
 630     check "unpickling succeeds (fractional KPH)"
 631           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 632
 633     check "unpickling succeeds (no Most_Laps_Leading)"
 634           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 635   where
 636     check desc path = testCase desc $ do
 637       actual <- unpickleable path pickle_message
 638       let expected = True
 639       actual @?= expected
 640
 641
 642
 643 -- | Make sure everything gets deleted when we delete the top-level
 644 --   record.
 645 --
 646 test_on_delete_cascade :: TestTree
 647 test_on_delete_cascade = testGroup "cascading delete tests"
 648   [ check "deleting auto_racing_results deletes its children"
 649           "test/xml/AutoRacingResultsXML.xml",
 650
 651     check "deleting auto_racing_results deletes its children (fractional KPH)"
 652           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 653
 654     check ("deleting auto_racing_results deletes its children " ++
 655            "(No Most_Laps_Leading)")
 656           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 657   where
 658     check desc path = testCase desc $ do
 659       results <- unsafe_unpickle path pickle_message
 660       let a = undefined :: AutoRacingResults
 661       let b = undefined :: AutoRacingResultsListing
 662       let c = undefined :: AutoRacingResultsRaceInformation
 663
 664       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 665                   runMigrationSilent $ do
 666                     migrate a
 667                     migrate b
 668                     migrate c
 669                   _ <- dbimport results
 670                   deleteAll a
 671                   count_a <- countAll a
 672                   count_b <- countAll b
 673                   count_c <- countAll c
 674                   return $ sum [count_a, count_b, count_c]
 675       let expected = 0
 676       actual @?= expected