src/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\".
  10 --
  11 module TSN.XML.AutoRacingResults (
  12   dtd,
  13   pickle_message,
  14   -- * Tests
  15 --  auto_racing_results_tests,
  16   -- * WARNING: these are private but exported to silence warnings
  17   AutoRacingResultsConstructor(..),
  18   AutoRacingResultsListingConstructor(..),
  19   AutoRacingResultsRaceInformationConstructor(..) )
  20 where
  21
  22 -- System imports.
  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 (
  29   countAll,
  30   deleteAll,
  31   migrate,
  32   runMigration,
  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 (
  38   groundhog,
  39   mkPersist )
  40 import Test.Tasty ( TestTree, testGroup )
  41 import Test.Tasty.HUnit ( (@?=), testCase )
  42 import Text.XML.HXT.Core (
  43   PU,
  44   xp11Tuple,
  45   xp12Tuple,
  46   xp13Tuple,
  47   xpAttr,
  48   xpElem,
  49   xpInt,
  50   xpList,
  51   xpOption,
  52   xpPair,
  53   xpPrim,
  54   xpText,
  55   xpTriple,
  56   xpWrap )
  57
  58 -- Local imports.
  59 import TSN.Codegen (
  60   tsn_codegen_config )
  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(..) )
  64 import Xml (
  65   FromXml(..),
  66   FromXmlFk(..),
  67   ToDb(..),
  68   pickle_unpickle,
  69   unpickleable,
  70   unsafe_unpickle )
  71
  72
  73 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  74 --
  75 dtd :: String
  76 dtd = "AutoRacingResultsXML.dtd"
  77
  78 --
  79 -- DB/XML data types
  80 --
  81
  82 -- * AutoRacingResults/Message
  83
  84 -- | Database representation of a 'Message'.
  85 --
  86 data AutoRacingResults =
  87   AutoRacingResults {
  88     db_xml_file_id :: Int,
  89     db_heading :: String,
  90     db_category :: String,
  91     db_sport :: String,
  92     db_race_id :: Int,
  93     db_race_date :: UTCTime,
  94     db_title :: String,
  95     db_track_location :: String,
  96     db_laps_remaining :: Int,
  97     db_checkered_flag :: Bool,
  98     db_time_stamp :: UTCTime }
  99   deriving (Eq, Show)
 100
 101
 102
 103 -- | XML Representation of an 'AutoRacingResults'.
 104 --
 105 data Message =
 106   Message {
 107     xml_xml_file_id :: Int,
 108     xml_heading :: String,
 109     xml_category :: String,
 110     xml_sport :: String,
 111     xml_race_id :: Int,
 112     xml_race_date :: UTCTime,
 113     xml_title :: String,
 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 }
 120   deriving (Eq, Show)
 121
 122
 123 instance ToDb Message where
 124   -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
 125   --
 126   type Db Message = AutoRacingResults
 127
 128
 129 -- | The 'FromXml' instance for 'Message' is required for the
 130 --   'XmlImport' instance.
 131 --
 132 instance FromXml Message where
 133   -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
 134   --   the 'xml_listings' and 'xml_race_information'.
 135   --
 136   from_xml Message{..} =
 137     AutoRacingResults {
 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 }
 149
 150
 151 -- | This allows us to insert the XML representation 'Message'
 152 --   directly.
 153 --
 154 instance XmlImport Message
 155
 156
 157 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
 158
 159 -- | Database representation of a \<Listing\> contained within a
 160 --   \<Message\>.
 161 --
 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,
 168     db_driver_id :: Int,
 169     db_driver :: String,
 170     db_car_make :: String,
 171     db_points :: Int,
 172     db_laps_completed :: Int,
 173     db_laps_leading :: Int,
 174     db_status :: Maybe String,
 175     db_dnf :: Maybe Bool,
 176     db_nc :: Maybe Bool,
 177     db_earnings :: Maybe Int }
 178
 179 -- | XML representation of a \<Listing\> contained within a
 180 --   \<message\>.
 181 --
 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,
 190     xml_points :: Int,
 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 }
 197   deriving (Eq, Show)
 198
 199
 200 instance ToDb AutoRacingResultsListingXml where
 201   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 202   --   an 'AutoRacingResultsListing'.
 203   --
 204   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 205
 206 instance FromXmlFk AutoRacingResultsListingXml where
 207   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 208   --   foreign key to) a 'AutoRacingResults'.
 209   --
 210   type Parent AutoRacingResultsListingXml = AutoRacingResults
 211
 212   -- | To convert an 'AutoRacingResultsListingXml' to an
 213   --   'AutoRacingResultsListing', we add the foreign key and copy
 214   --   everything else verbatim.
 215   --
 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,
 229       db_dnf = xml_dnf,
 230       db_nc = xml_nc,
 231       db_earnings = xml_earnings }
 232
 233
 234 -- | This allows us to insert the XML representation
 235 --   'AutoRacingResultsListingXml' directly.
 236 --
 237 instance XmlImportFk AutoRacingResultsListingXml
 238
 239
 240
 241 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
 242
 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.
 248 --
 249 data MostLapsLeading =
 250   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)
 255
 256
 257 -- | Database representation of a \<Race_Information\> contained within a
 258 --   \<Message\>.
 259 --
 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,
 267     db_laps :: Int,
 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 }
 277
 278
 279 -- | XML representation of a \<Listing\> contained within a
 280 --   \<message\>.
 281 --
 282 data AutoRacingResultsRaceInformationXml =
 283   AutoRacingResultsRaceInformationXml {
 284     xml_track_length :: Double,
 285     xml_track_length_kph :: Double,
 286     xml_laps :: Int,
 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 }
 296   deriving (Eq,Show)
 297
 298
 299 instance ToDb AutoRacingResultsRaceInformationXml where
 300   -- | The database analogue of an
 301   --   'AutoRacingResultsRaceInformationXml' is an
 302   --   'AutoRacingResultsRaceInformation'.
 303   --
 304   type Db AutoRacingResultsRaceInformationXml =
 305     AutoRacingResultsRaceInformation
 306
 307 instance FromXmlFk AutoRacingResultsRaceInformationXml where
 308   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 309   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 310   --
 311   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 312
 313   -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
 314   --   'AutoRacingResultsRaceInformartion', we add the foreign key and
 315   --   copy everything else verbatim.
 316   --
 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,
 322       db_laps = xml_laps,
 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 }
 332
 333
 334 -- | This allows us to insert the XML representation
 335 --   'AutoRacingResultsRaceInformationXml' directly.
 336 --
 337 instance XmlImportFk AutoRacingResultsRaceInformationXml
 338
 339
 340
 341 ---
 342 --- Database stuff.
 343 ---
 344
 345 instance DbImport Message where
 346   dbmigrate _ =
 347     run_dbmigrate $ do
 348       migrate (undefined :: AutoRacingResults)
 349       migrate (undefined :: AutoRacingResultsListing)
 350       migrate (undefined :: AutoRacingResultsRaceInformation)
 351
 352   dbimport = undefined
 353
 354
 355 mkPersist tsn_codegen_config [groundhog|
 356 - entity: AutoRacingResults
 357   dbName: auto_racing_results
 358   constructors:
 359     - name: AutoRacingResults
 360       uniques:
 361         - name: unique_auto_racing_schedule
 362           type: constraint
 363           # Prevent multiple imports of the same message.
 364           fields: [db_xml_file_id]
 365
 366
 367 - entity: AutoRacingResultsListing
 368   dbName: auto_racing_results_listings
 369   constructors:
 370     - name: AutoRacingResultsListing
 371       fields:
 372         - name: db_auto_racing_results_id
 373           reference:
 374             onDelete: cascade
 375
 376
 377 - entity: AutoRacingResultsRaceInformation
 378   dbName: auto_racing_results_race_information
 379   constructors:
 380     - name: AutoRacingResultsRaceInformation
 381       fields:
 382         - name: db_auto_racing_results_id'
 383           reference:
 384             onDelete: cascade
 385         - name: db_most_laps_leading
 386           embeddedType:
 387             - {name: most_laps_leading_driver_id, dbName: most_laps_leading_driver_id}
 388             - {name: most_laps_leading_driver, dbName: most_laps_leading_driver}
 389
 390 - embedded: MostLapsLeading
 391   fields:
 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
 398 |]
 399
 400
 401 ---
 402 --- Pickling
 403 ---
 404
 405 pickle_listing :: PU AutoRacingResultsListingXml
 406 pickle_listing =
 407   xpElem "Listing" $
 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)
 422   where
 423     from_tuple = uncurryN AutoRacingResultsListingXml
 424     to_tuple m = (xml_finish_position m,
 425                   xml_starting_position m,
 426                   xml_car_number m,
 427                   xml_driver_id m,
 428                   xml_driver m,
 429                   xml_car_make m,
 430                   xml_points m,
 431                   xml_laps_completed m,
 432                   xml_laps_leading m,
 433                   xml_status m,
 434                   xml_dnf m,
 435                   xml_nc m,
 436                   xml_earnings m)
 437
 438
 439 -- | Pickler for the top-level 'Message'.
 440 pickle_message :: PU Message
 441 pickle_message =
 442   xpElem "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)
 457   where
 458     from_tuple = uncurryN Message
 459     to_tuple m = (xml_xml_file_id m,
 460                   xml_heading m,
 461                   xml_category m,
 462                   xml_sport m,
 463                   xml_race_id m,
 464                   xml_race_date m,
 465                   xml_title m,
 466                   xml_track_location m,
 467                   xml_laps_remaining m,
 468                   xml_checkered_flag m,
 469                   xml_listings m,
 470                   xml_race_information m,
 471                   xml_time_stamp m)
 472
 473
 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)
 481   where
 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)
 486
 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
 505   where
 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
 511
 512     -- And here we have to re-pair the first two.
 513     to_tuple m = ((xml_track_length m, xml_track_length_kph m),
 514                   xml_laps m,
 515                   xml_average_speed_mph m,
 516                   xml_average_speed_kph m,
 517                   xml_average_speed m,
 518                   xml_time_of_race m,
 519                   xml_margin_of_victory m,
 520                   xml_cautions m,
 521                   xml_lead_changes m,
 522                   xml_lap_leaders m,
 523                   xml_most_laps_leading m)