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   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 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 'H.convert'.
 137 --
 138 instance H.HVector 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\>. The leading underscores prevent unused field
 179 --   warnings.
 180 --
 181 data AutoRacingResultsListing =
 182   AutoRacingResultsListing {
 183     _db_auto_racing_results_id :: DefaultKey AutoRacingResults,
 184     _db_finish_position :: Int,
 185     _db_starting_position :: Int,
 186     _db_car_number :: Int,
 187     _db_driver_id :: Int,
 188     _db_driver :: String,
 189     _db_car_make :: String,
 190     _db_points :: Int,
 191     _db_laps_completed :: Int,
 192     _db_laps_leading :: Int,
 193     _db_status :: Maybe String,
 194     _db_dnf :: Maybe Bool,
 195     _db_nc :: Maybe Bool,
 196     _db_earnings :: Maybe Int }
 197   deriving ( GHC.Generic )
 198
 199 -- | For 'H.convert' and 'H.cons'.
 200 --
 201 instance H.HVector AutoRacingResultsListing
 202
 203 -- | XML representation of a \<Listing\> contained within a
 204 --   \<message\>. The leading underscores prevent unused field
 205 --   warnings.
 206 --
 207 data AutoRacingResultsListingXml =
 208   AutoRacingResultsListingXml {
 209     _xml_finish_position :: Int,
 210     _xml_starting_position :: Int,
 211     _xml_car_number :: Int,
 212     _xml_driver_id :: Int,
 213     _xml_driver :: String,
 214     _xml_car_make :: String,
 215     _xml_points :: Int,
 216     _xml_laps_completed :: Int,
 217     _xml_laps_leading :: Int,
 218     _xml_status :: Maybe String,
 219     _xml_dnf :: Maybe Bool,
 220     _xml_nc :: Maybe Bool,
 221     _xml_earnings :: Maybe Int }
 222   deriving (Eq, GHC.Generic, Show)
 223
 224 -- | For 'H.convert'.
 225 --
 226 instance H.HVector AutoRacingResultsListingXml
 227
 228 instance ToDb AutoRacingResultsListingXml where
 229   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 230   --   an 'AutoRacingResultsListing'.
 231   --
 232   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 233
 234
 235 instance Child AutoRacingResultsListingXml where
 236   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 237   --   foreign key to) a 'AutoRacingResults'.
 238   --
 239   type Parent AutoRacingResultsListingXml = AutoRacingResults
 240
 241
 242 instance FromXmlFk AutoRacingResultsListingXml where
 243   -- | To convert an 'AutoRacingResultsListingXml' to an
 244   --   'AutoRacingResultsListing', we add the foreign key and copy
 245   --   everything else verbatim.
 246   --
 247   from_xml_fk = H.cons
 248
 249
 250 -- | This allows us to insert the XML representation
 251 --   'AutoRacingResultsListingXml' directly.
 252 --
 253 instance XmlImportFk AutoRacingResultsListingXml
 254
 255
 256
 257 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
 258
 259 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
 260 --   contains exactly three fields, so we just embed those three into
 261 --   the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
 262 --   the \"db_\" prefix since our field namer is going to strip of
 263 --   everything before the first underscore.
 264 --
 265 --   We make the three fields optional because the entire
 266 --   \<Most_Laps_Leading\> is apparently optional (although it is
 267 --   usually present). A 'Nothing' in the XML should get turned into
 268 --   three 'Nothing's in the DB.
 269 --
 270 data MostLapsLeading =
 271   MostLapsLeading {
 272     db_most_laps_leading_driver_id :: Maybe Int,
 273     db_most_laps_leading_driver :: Maybe String,
 274     db_most_laps_leading_number_of_laps :: Maybe Int }
 275   deriving (Data, Eq, Show, Typeable)
 276
 277
 278 -- | Database representation of a \<Race_Information\> contained
 279 --   within a \<message\>.
 280 --
 281 --   The 'db_most_laps_leading' field is not optional because when we
 282 --   convert from our XML representation, a missing 'MostLapsLeading'
 283 --   will be replaced with a 'MostLapsLeading' with three missing
 284 --   fields.
 285 --
 286 data AutoRacingResultsRaceInformation =
 287   AutoRacingResultsRaceInformation {
 288     -- Note the apostrophe to disambiguate it from the
 289     -- AutoRacingResultsListing field.
 290     db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
 291     db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
 292                                --   like \"1.25 miles\".
 293     db_track_length_kph :: Double,
 294     db_laps :: Int,
 295     db_average_speed_mph :: Maybe Double,
 296     db_average_speed_kph :: Maybe Double,
 297     db_average_speed :: Maybe Double,
 298     db_time_of_race :: Maybe String,
 299     db_margin_of_victory :: Maybe String,
 300     db_cautions :: Maybe String,
 301     db_lead_changes :: Maybe String,
 302     db_lap_leaders :: Maybe String,
 303     db_most_laps_leading :: MostLapsLeading }
 304
 305
 306 -- | XML representation of a \<Listing\> contained within a
 307 --   \<message\>.
 308 --
 309 data AutoRacingResultsRaceInformationXml =
 310   AutoRacingResultsRaceInformationXml {
 311     xml_track_length :: String,
 312     xml_track_length_kph :: Double,
 313     xml_laps :: Int,
 314     xml_average_speed_mph :: Maybe Double,
 315     xml_average_speed_kph :: Maybe Double,
 316     xml_average_speed :: Maybe Double,
 317     xml_time_of_race :: Maybe String,
 318     xml_margin_of_victory :: Maybe String,
 319     xml_cautions :: Maybe String,
 320     xml_lead_changes :: Maybe String,
 321     xml_lap_leaders :: Maybe String,
 322     xml_most_laps_leading :: Maybe MostLapsLeading }
 323   deriving (Eq, Show)
 324
 325
 326 instance ToDb AutoRacingResultsRaceInformationXml where
 327   -- | The database analogue of an
 328   --   'AutoRacingResultsRaceInformationXml' is an
 329   --   'AutoRacingResultsRaceInformation'.
 330   --
 331   type Db AutoRacingResultsRaceInformationXml =
 332     AutoRacingResultsRaceInformation
 333
 334
 335 instance Child AutoRacingResultsRaceInformationXml where
 336   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 337   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 338   --
 339   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 340
 341
 342 instance FromXmlFk AutoRacingResultsRaceInformationXml where
 343   -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
 344   --   'AutoRacingResultsRaceInformartion', we add the foreign key and
 345   --   massage the 'MostLapsLeading' embedded type,
 346   --
 347   from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
 348     AutoRacingResultsRaceInformation {
 349       db_auto_racing_results_id' = fk,
 350       db_track_length = xml_track_length,
 351       db_track_length_kph = xml_track_length_kph,
 352       db_laps = xml_laps,
 353       db_average_speed_mph = xml_average_speed_mph,
 354       db_average_speed_kph = xml_average_speed_kph,
 355       db_average_speed = xml_average_speed,
 356       db_time_of_race = xml_time_of_race,
 357       db_margin_of_victory = xml_margin_of_victory,
 358       db_cautions = xml_cautions,
 359       db_lead_changes = xml_lead_changes,
 360       db_lap_leaders = xml_lap_leaders,
 361       db_most_laps_leading = most_laps_leading }
 362     where
 363       -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
 364       -- the database with an (embedded) 'MostLapsLeading' with three
 365       -- missing fields.
 366       most_laps_leading =
 367         fromMaybe (MostLapsLeading Nothing Nothing Nothing)
 368                   xml_most_laps_leading
 369
 370
 371 -- | This allows us to insert the XML representation
 372 --   'AutoRacingResultsRaceInformationXml' directly.
 373 --
 374 instance XmlImportFk AutoRacingResultsRaceInformationXml
 375
 376
 377
 378 --
 379 -- * Database stuff.
 380 --
 381
 382 instance DbImport Message where
 383   dbmigrate _ =
 384     run_dbmigrate $ do
 385       migrate (undefined :: AutoRacingResults)
 386       migrate (undefined :: AutoRacingResultsListing)
 387       migrate (undefined :: AutoRacingResultsRaceInformation)
 388
 389   -- | We insert the message, then use its ID to insert the listings
 390   --   and race information.
 391   dbimport m = do
 392     msg_id <- insert_xml m
 393
 394     insert_xml_fk_ msg_id (xml_race_information m)
 395
 396     forM_ (xml_listings m) $ insert_xml_fk_ msg_id
 397
 398     return ImportSucceeded
 399
 400
 401
 402 mkPersist tsn_codegen_config [groundhog|
 403 - entity: AutoRacingResults
 404   dbName: auto_racing_results
 405   constructors:
 406     - name: AutoRacingResults
 407       uniques:
 408         - name: unique_auto_racing_results
 409           type: constraint
 410           # Prevent multiple imports of the same message.
 411           fields: [db_xml_file_id]
 412
 413
 414 - entity: AutoRacingResultsListing
 415   dbName: auto_racing_results_listings
 416   constructors:
 417     - name: AutoRacingResultsListing
 418       fields:
 419         - name: _db_auto_racing_results_id
 420           reference:
 421             onDelete: cascade
 422
 423   # Note the apostrophe in the foreign key. This is to disambiguate
 424   # it from the AutoRacingResultsListing foreign key of the same name.
 425   # We strip it out of the dbName.
 426 - entity: AutoRacingResultsRaceInformation
 427   dbName: auto_racing_results_race_information
 428   constructors:
 429     - name: AutoRacingResultsRaceInformation
 430       fields:
 431         - name: db_auto_racing_results_id'
 432           dbName: auto_racing_results_id
 433           reference:
 434             onDelete: cascade
 435         - name: db_most_laps_leading
 436           embeddedType:
 437             - {name: most_laps_leading_driver_id,
 438                dbName: most_laps_leading_driver_id}
 439             - {name: most_laps_leading_driver,
 440                dbName: most_laps_leading_driver}
 441
 442 - embedded: MostLapsLeading
 443   fields:
 444     - name: db_most_laps_leading_driver_id
 445       dbName: most_laps_leading_driver_id
 446     - name: db_most_laps_leading_driver
 447       dbName: most_laps_leading_driver
 448     - name: db_most_laps_leading_number_of_laps
 449       dbName: most_laps_leading_number_of_laps
 450 |]
 451
 452
 453 ---
 454 --- Pickling
 455 ---
 456
 457 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 458 --
 459 pickle_listing :: PU AutoRacingResultsListingXml
 460 pickle_listing =
 461   xpElem "Listing" $
 462     xpWrap (from_tuple, H.convert) $
 463     xp13Tuple (xpElem "FinishPosition" xpInt)
 464               (xpElem "StartingPosition" xpInt)
 465               (xpElem "CarNumber" xpInt)
 466               (xpElem "DriverID" xpInt)
 467               (xpElem "Driver" xpText)
 468               (xpElem "CarMake" xpText)
 469               (xpElem "Points" xpInt)
 470               (xpElem "Laps_Completed" xpInt)
 471               (xpElem "Laps_Leading" xpInt)
 472               (xpElem "Status" $ xpOption xpText)
 473               (xpOption $ xpElem "DNF" xpPrim)
 474               (xpOption $ xpElem "NC" xpPrim)
 475               (xpElem "Earnings" xp_earnings)
 476   where
 477     from_tuple = uncurryN AutoRacingResultsListingXml
 478
 479
 480 -- | Pickler for the top-level 'Message'.
 481 --
 482 pickle_message :: PU Message
 483 pickle_message =
 484   xpElem "message" $
 485     xpWrap (from_tuple, H.convert) $
 486     xp13Tuple (xpElem "XML_File_ID" xpInt)
 487               (xpElem "heading" xpText)
 488               (xpElem "category" xpText)
 489               (xpElem "sport" xpText)
 490               (xpElem "RaceID" xpInt)
 491               (xpElem "RaceDate" xp_datetime)
 492               (xpElem "Title" xpText)
 493               (xpElem "Track_Location" xpText)
 494               (xpElem "Laps_Remaining" xpInt)
 495               (xpElem "Checkered_Flag" xpPrim)
 496               (xpList pickle_listing)
 497               pickle_race_information
 498               (xpElem "time_stamp" xp_time_stamp)
 499   where
 500     from_tuple = uncurryN Message
 501
 502
 503 -- | Pickler for the \<Most_Laps_Leading\> child of a
 504 --   \<Race_Information\>. This is complicated by the fact that the
 505 --   three fields we're trying to parse are not actually optional;
 506 --   only the entire \<Most_Laps_Leading\> is. So we always wrap what
 507 --   we parse in a 'Just', and when converting from the DB to XML,
 508 --   we'll drop the entire element if any of its fields are missing
 509 --   (which they never should be).
 510 --
 511 pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
 512 pickle_most_laps_leading =
 513   xpElem "Most_Laps_Leading" $
 514     xpWrap (from_tuple, to_tuple') $
 515     xpTriple (xpOption $ xpElem "DriverID" xpInt)
 516              (xpOption $ xpElem "Driver" xpText)
 517              (xpOption $ xpElem "NumberOfLaps" xpInt)
 518   where
 519     from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
 520     from_tuple (Just x, Just y, Just z) =
 521       Just $ MostLapsLeading (Just x) (Just y) (Just z)
 522     from_tuple _ = Nothing
 523
 524     -- Sure had to go out of my way to avoid the warnings about unused
 525     -- db_most_laps_foo fields here.
 526     to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
 527     to_tuple' Nothing = (Nothing, Nothing, Nothing)
 528     to_tuple' (Just (MostLapsLeading 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 m) = (db_most_laps_leading_driver_id m,
 532                           db_most_laps_leading_driver m,
 533                           db_most_laps_leading_number_of_laps m)
 534
 535
 536 -- | Pickler for the \<Race_Information\> child of \<message\>.
 537 --
 538 --   There's so much voodoo going on here. We have a double-layered
 539 --   Maybe on top of the MostLapsLeading. When unpickling, we return a
 540 --   Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
 541 --   missing. But if the entire element is missing, unpickling
 542 --   fails. 'xpOption' doesn't fix this because it would give us a
 543 --   Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
 544 --   default of (Nothing :: Maybe MostLapsLeading) to stick one in
 545 --   there if unpicking a (Maybe MostLapsLeading) fails because
 546 --   \<Most_Laps_Leading\> is missing.
 547 --
 548 --   Clear as mud, I know.
 549 --
 550 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
 551 pickle_race_information =
 552   xpElem "Race_Information" $
 553     xpWrap (from_tuple, to_tuple') $
 554     xp11Tuple (-- I can't think of another way to get both the
 555                -- TrackLength and its KPH attribute. So we shove them
 556                -- both in a 2-tuple. This should probably be an embedded type!
 557                  xpElem "TrackLength" $
 558                    xpPair xpText
 559                           (xpAttr "KPH" xp_fracpart_only_double) )
 560               (xpElem "Laps" xpInt)
 561               (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
 562               (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
 563               (xpOption $ xpElem "AverageSpeed" xpPrim)
 564               (xpOption $ xpElem "TimeOfRace" xpText)
 565               (xpOption $ xpElem "MarginOfVictory" xpText)
 566               (xpOption $ xpElem "Cautions" xpText)
 567               (xpOption $ xpElem "LeadChanges" xpText)
 568               (xpOption $ xpElem "LapLeaders" xpText)
 569               (xpDefault Nothing pickle_most_laps_leading)
 570   where
 571     -- Derp. Since the first two are paired, we have to
 572     -- manually unpack the bazillion arguments.
 573     from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
 574         AutoRacingResultsRaceInformationXml
 575           x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
 576
 577     -- And here we have to re-pair the first two.
 578     to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
 579                    xml_laps m,
 580                    xml_average_speed_mph m,
 581                    xml_average_speed_kph m,
 582                    xml_average_speed m,
 583                    xml_time_of_race m,
 584                    xml_margin_of_victory m,
 585                    xml_cautions m,
 586                    xml_lead_changes m,
 587                    xml_lap_leaders m,
 588                    xml_most_laps_leading m)
 589
 590 --
 591 -- * Tasty Tests
 592 --
 593
 594 -- | A list of all tests for this module.
 595 --
 596 auto_racing_results_tests :: TestTree
 597 auto_racing_results_tests =
 598   testGroup
 599     "AutoRacingResults tests"
 600     [ test_on_delete_cascade,
 601       test_pickle_of_unpickle_is_identity,
 602       test_unpickle_succeeds ]
 603
 604 -- | If we unpickle something and then pickle it, we should wind up
 605 --   with the same thing we started with. WARNING: success of this
 606 --   test does not mean that unpickling succeeded.
 607 --
 608 test_pickle_of_unpickle_is_identity :: TestTree
 609 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 610   [ check "pickle composed with unpickle is the identity"
 611           "test/xml/AutoRacingResultsXML.xml",
 612
 613     check "pickle composed with unpickle is the identity (fractional KPH)"
 614           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 615
 616     check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
 617           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"]
 618   where
 619     check desc path = testCase desc $ do
 620       (expected, actual) <- pickle_unpickle pickle_message path
 621       actual @?= expected
 622
 623
 624
 625 -- | Make sure we can actually unpickle these things.
 626 --
 627 test_unpickle_succeeds :: TestTree
 628 test_unpickle_succeeds = testGroup "unpickle tests"
 629   [ check "unpickling succeeds"
 630           "test/xml/AutoRacingResultsXML.xml",
 631
 632     check "unpickling succeeds (fractional KPH)"
 633           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 634
 635     check "unpickling succeeds (no Most_Laps_Leading)"
 636           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 637   where
 638     check desc path = testCase desc $ do
 639       actual <- unpickleable path pickle_message
 640       let expected = True
 641       actual @?= expected
 642
 643
 644
 645 -- | Make sure everything gets deleted when we delete the top-level
 646 --   record.
 647 --
 648 test_on_delete_cascade :: TestTree
 649 test_on_delete_cascade = testGroup "cascading delete tests"
 650   [ check "deleting auto_racing_results deletes its children"
 651           "test/xml/AutoRacingResultsXML.xml",
 652
 653     check "deleting auto_racing_results deletes its children (fractional KPH)"
 654           "test/xml/AutoRacingResultsXML-fractional-kph.xml",
 655
 656     check ("deleting auto_racing_results deletes its children " ++
 657            "(No Most_Laps_Leading)")
 658           "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
 659   where
 660     check desc path = testCase desc $ do
 661       results <- unsafe_unpickle path pickle_message
 662       let a = undefined :: AutoRacingResults
 663       let b = undefined :: AutoRacingResultsListing
 664       let c = undefined :: AutoRacingResultsRaceInformation
 665
 666       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 667                   runMigration silentMigrationLogger $ do
 668                     migrate a
 669                     migrate b
 670                     migrate c
 671                   _ <- dbimport results
 672                   deleteAll a
 673                   count_a <- countAll a
 674                   count_b <- countAll b
 675                   count_c <- countAll c
 676                   return $ sum [count_a, count_b, count_c]
 677       let expected = 0
 678       actual @?= expected