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