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