1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\".
11 module TSN.XML.AutoRacingResults (
15 -- auto_racing_results_tests,
16 -- * WARNING: these are private but exported to silence warnings
17 AutoRacingResultsConstructor(..),
18 AutoRacingResultsListingConstructor(..),
19 AutoRacingResultsRaceInformationConstructor(..) )
23 import Control.Monad ( forM_ )
24 import Data.Data ( Data )
25 import Data.Time ( UTCTime(..) )
26 import Data.Tuple.Curry ( uncurryN )
27 import Data.Typeable ( Typeable )
28 import Database.Groundhog (
33 silentMigrationLogger )
34 import Database.Groundhog.Core ( DefaultKey )
35 import Database.Groundhog.Generic ( runDbConn )
36 import Database.Groundhog.Sqlite ( withSqliteConn )
37 import Database.Groundhog.TH (
40 import Test.Tasty ( TestTree, testGroup )
41 import Test.Tasty.HUnit ( (@?=), testCase )
42 import Text.XML.HXT.Core (
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Picklers ( xp_earnings, xp_racedate, xp_time_stamp )
63 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
73 -- | The DTD to which this module corresponds. Used to invoke dbimport.
76 dtd = "AutoRacingResultsXML.dtd"
82 -- * AutoRacingResults/Message
84 -- | Database representation of a 'Message'.
86 data AutoRacingResults =
88 db_xml_file_id :: Int,
90 db_category :: String,
93 db_race_date :: UTCTime,
95 db_track_location :: String,
96 db_laps_remaining :: Int,
97 db_checkered_flag :: Bool,
98 db_time_stamp :: UTCTime }
103 -- | XML Representation of an 'AutoRacingResults'.
107 xml_xml_file_id :: Int,
108 xml_heading :: String,
109 xml_category :: String,
112 xml_race_date :: UTCTime,
114 xml_track_location :: String,
115 xml_laps_remaining :: Int,
116 xml_checkered_flag :: Bool,
117 xml_listings :: [AutoRacingResultsListingXml],
118 xml_race_information :: AutoRacingResultsRaceInformationXml,
119 xml_time_stamp :: UTCTime }
123 instance ToDb Message where
124 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
126 type Db Message = AutoRacingResults
129 -- | The 'FromXml' instance for 'Message' is required for the
130 -- 'XmlImport' instance.
132 instance FromXml Message where
133 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
134 -- the 'xml_listings' and 'xml_race_information'.
136 from_xml Message{..} =
138 db_xml_file_id = xml_xml_file_id,
139 db_heading = xml_heading,
140 db_category = xml_category,
141 db_sport = xml_sport,
142 db_race_id = xml_race_id,
143 db_race_date = xml_race_date,
144 db_title = xml_title,
145 db_track_location = xml_track_location,
146 db_laps_remaining = xml_laps_remaining,
147 db_checkered_flag = xml_checkered_flag,
148 db_time_stamp = xml_time_stamp }
151 -- | This allows us to insert the XML representation 'Message'
154 instance XmlImport Message
157 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
159 -- | Database representation of a \<Listing\> contained within a
162 data AutoRacingResultsListing =
163 AutoRacingResultsListing {
164 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
165 db_finish_position :: Int,
166 db_starting_position :: Int,
167 db_car_number :: Int,
170 db_car_make :: String,
172 db_laps_completed :: Int,
173 db_laps_leading :: Int,
174 db_status :: Maybe String,
175 db_dnf :: Maybe Bool,
177 db_earnings :: Maybe Int }
179 -- | XML representation of a \<Listing\> contained within a
182 data AutoRacingResultsListingXml =
183 AutoRacingResultsListingXml {
184 xml_finish_position :: Int,
185 xml_starting_position :: Int,
186 xml_car_number :: Int,
187 xml_driver_id :: Int,
188 xml_driver :: String,
189 xml_car_make :: String,
191 xml_laps_completed :: Int,
192 xml_laps_leading :: Int,
193 xml_status :: Maybe String,
194 xml_dnf :: Maybe Bool,
195 xml_nc :: Maybe Bool,
196 xml_earnings :: Maybe Int }
200 instance ToDb AutoRacingResultsListingXml where
201 -- | The database analogue of an 'AutoRacingResultsListingXml' is
202 -- an 'AutoRacingResultsListing'.
204 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
206 instance FromXmlFk AutoRacingResultsListingXml where
207 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
208 -- foreign key to) a 'AutoRacingResults'.
210 type Parent AutoRacingResultsListingXml = AutoRacingResults
212 -- | To convert an 'AutoRacingResultsListingXml' to an
213 -- 'AutoRacingResultsListing', we add the foreign key and copy
214 -- everything else verbatim.
216 from_xml_fk fk AutoRacingResultsListingXml{..} =
217 AutoRacingResultsListing {
218 db_auto_racing_results_id = fk,
219 db_finish_position = xml_finish_position,
220 db_starting_position = xml_starting_position,
221 db_car_number = xml_car_number,
222 db_driver_id = xml_driver_id,
223 db_driver = xml_driver,
224 db_car_make = xml_car_make,
225 db_points = xml_points,
226 db_laps_completed = xml_laps_completed,
227 db_laps_leading = xml_laps_leading,
228 db_status = xml_status,
231 db_earnings = xml_earnings }
234 -- | This allows us to insert the XML representation
235 -- 'AutoRacingResultsListingXml' directly.
237 instance XmlImportFk AutoRacingResultsListingXml
241 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
243 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
244 -- contains exactly three fields, so we just embed those three into
245 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
246 -- the \"db_\" prefix since our field namer is going to strip of
247 -- everything before the first underscore.
249 data MostLapsLeading =
251 db_most_laps_leading_driver_id :: Int,
252 db_most_laps_leading_driver :: String,
253 db_most_laps_leading_number_of_laps :: Int }
254 deriving (Data, Eq, Show, Typeable)
257 -- | Database representation of a \<Race_Information\> contained within a
260 data AutoRacingResultsRaceInformation =
261 AutoRacingResultsRaceInformation {
262 -- Note the apostrophe to disambiguate it from the
263 -- AutoRacingResultsListing filed.
264 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
265 db_track_length :: Double,
266 db_track_length_kph :: Double,
268 db_average_speed_mph :: Maybe Double,
269 db_average_speed_kph :: Maybe Double,
270 db_average_speed :: Maybe Double,
271 db_time_of_race :: Maybe String,
272 db_margin_of_victory :: Maybe String,
273 db_cautions :: Maybe String,
274 db_lead_changes :: Maybe String,
275 db_lap_leaders :: Maybe String,
276 db_most_laps_leading :: MostLapsLeading }
279 -- | XML representation of a \<Listing\> contained within a
282 data AutoRacingResultsRaceInformationXml =
283 AutoRacingResultsRaceInformationXml {
284 xml_track_length :: Double,
285 xml_track_length_kph :: Double,
287 xml_average_speed_mph :: Maybe Double,
288 xml_average_speed_kph :: Maybe Double,
289 xml_average_speed :: Maybe Double,
290 xml_time_of_race :: Maybe String,
291 xml_margin_of_victory :: Maybe String,
292 xml_cautions :: Maybe String,
293 xml_lead_changes :: Maybe String,
294 xml_lap_leaders :: Maybe String,
295 xml_most_laps_leading :: MostLapsLeading }
299 instance ToDb AutoRacingResultsRaceInformationXml where
300 -- | The database analogue of an
301 -- 'AutoRacingResultsRaceInformationXml' is an
302 -- 'AutoRacingResultsRaceInformation'.
304 type Db AutoRacingResultsRaceInformationXml =
305 AutoRacingResultsRaceInformation
307 instance FromXmlFk AutoRacingResultsRaceInformationXml where
308 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
309 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
311 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
313 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
314 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
315 -- copy everything else verbatim.
317 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
318 AutoRacingResultsRaceInformation {
319 db_auto_racing_results_id' = fk,
320 db_track_length = xml_track_length,
321 db_track_length_kph = xml_track_length_kph,
323 db_average_speed_mph = xml_average_speed_mph,
324 db_average_speed_kph = xml_average_speed_kph,
325 db_average_speed = xml_average_speed,
326 db_time_of_race = xml_time_of_race,
327 db_margin_of_victory = xml_margin_of_victory,
328 db_cautions = xml_cautions,
329 db_lead_changes = xml_lead_changes,
330 db_lap_leaders = xml_lap_leaders,
331 db_most_laps_leading = xml_most_laps_leading }
334 -- | This allows us to insert the XML representation
335 -- 'AutoRacingResultsRaceInformationXml' directly.
337 instance XmlImportFk AutoRacingResultsRaceInformationXml
345 instance DbImport Message where
348 migrate (undefined :: AutoRacingResults)
349 migrate (undefined :: AutoRacingResultsListing)
350 migrate (undefined :: AutoRacingResultsRaceInformation)
355 mkPersist tsn_codegen_config [groundhog|
356 - entity: AutoRacingResults
357 dbName: auto_racing_results
359 - name: AutoRacingResults
361 - name: unique_auto_racing_schedule
363 # Prevent multiple imports of the same message.
364 fields: [db_xml_file_id]
367 - entity: AutoRacingResultsListing
368 dbName: auto_racing_results_listings
370 - name: AutoRacingResultsListing
372 - name: db_auto_racing_results_id
377 - entity: AutoRacingResultsRaceInformation
378 dbName: auto_racing_results_race_information
380 - name: AutoRacingResultsRaceInformation
382 - name: db_auto_racing_results_id'
385 - name: db_most_laps_leading
387 - {name: most_laps_leading_driver_id, dbName: most_laps_leading_driver_id}
388 - {name: most_laps_leading_driver, dbName: most_laps_leading_driver}
390 - embedded: MostLapsLeading
392 - name: db_most_laps_leading_driver_id
393 dbName: most_laps_leading_driver_id
394 - name: db_most_laps_leading_driver
395 dbName: most_laps_leading_driver
396 - name: db_most_laps_leading_number_of_laps
397 dbName: most_laps_leading_number_of_laps
405 pickle_listing :: PU AutoRacingResultsListingXml
408 xpWrap (from_tuple, to_tuple) $
409 xp13Tuple (xpElem "FinishPosition" xpInt)
410 (xpElem "StartingPosition" xpInt)
411 (xpElem "CarNumber" xpInt)
412 (xpElem "DriverID" xpInt)
413 (xpElem "Driver" xpText)
414 (xpElem "CarMake" xpText)
415 (xpElem "Points" xpInt)
416 (xpElem "Laps_Completed" xpInt)
417 (xpElem "Laps_Leading" xpInt)
418 (xpElem "Status" $ xpOption xpText)
419 (xpOption $ xpElem "DNF" xpPrim)
420 (xpOption $ xpElem "NC" xpPrim)
421 (xpElem "Earnings" xp_earnings)
423 from_tuple = uncurryN AutoRacingResultsListingXml
424 to_tuple m = (xml_finish_position m,
425 xml_starting_position m,
431 xml_laps_completed m,
439 -- | Pickler for the top-level 'Message'.
440 pickle_message :: PU Message
443 xpWrap (from_tuple, to_tuple) $
444 xp13Tuple (xpElem "XML_File_ID" xpInt)
445 (xpElem "heading" xpText)
446 (xpElem "category" xpText)
447 (xpElem "sport" xpText)
448 (xpElem "RaceID" xpInt)
449 (xpElem "RaceDate" xp_racedate)
450 (xpElem "Title" xpText)
451 (xpElem "Track_Location" xpText)
452 (xpElem "Laps_Remaining" xpInt)
453 (xpElem "Checkered_Flag" xpPrim)
454 (xpList pickle_listing)
455 pickle_race_information
456 (xpElem "time_stamp" xp_time_stamp)
458 from_tuple = uncurryN Message
459 to_tuple m = (xml_xml_file_id m,
466 xml_track_location m,
467 xml_laps_remaining m,
468 xml_checkered_flag m,
470 xml_race_information m,
474 pickle_most_laps_leading :: PU MostLapsLeading
475 pickle_most_laps_leading =
476 xpElem "Most_Laps_Leading" $
477 xpWrap (from_tuple, to_tuple) $
478 xpTriple (xpElem "DriverID" xpInt)
479 (xpElem "Driver" xpText)
480 (xpElem "NumberOfLaps" xpInt)
482 from_tuple = uncurryN MostLapsLeading
483 to_tuple m = (db_most_laps_leading_driver_id m,
484 db_most_laps_leading_driver m,
485 db_most_laps_leading_number_of_laps m)
487 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
488 pickle_race_information =
489 xpElem "Race_Information" $
490 xpWrap (from_tuple, to_tuple) $
491 xp11Tuple (-- I can't think of another way to get both the
492 -- TrackLength and its KPH attribute. So we shove them
493 -- both in a 2-tuple.
494 xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) )
495 (xpElem "Laps" xpInt)
496 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
497 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
498 (xpOption $ xpElem "AverageSpeed" xpPrim)
499 (xpOption $ xpElem "TimeOfRace" xpText)
500 (xpOption $ xpElem "MarginOfVictory" xpText)
501 (xpOption $ xpElem "Cautions" xpText)
502 (xpOption $ xpElem "LeadChanges" xpText)
503 (xpOption $ xpElem "LapLeaders" xpText)
504 pickle_most_laps_leading
506 -- Derp. Since the first two are paired, we have to
507 -- manually unpack the bazillion arguments.
508 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
509 AutoRacingResultsRaceInformationXml
510 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
512 -- And here we have to re-pair the first two.
513 to_tuple m = ((xml_track_length m, xml_track_length_kph m),
515 xml_average_speed_mph m,
516 xml_average_speed_kph m,
519 xml_margin_of_victory m,
523 xml_most_laps_leading m)