src/TSN/XML/AutoRacingResults.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\".
  11 --
  12 module TSN.XML.AutoRacingResults (
  13   dtd,
  14 --  pickle_message,
  15   -- * Tests
  16 --  auto_racing_results_tests,
  17   -- * WARNING: these are private but exported to silence warnings
  18   AutoRacingResultsConstructor(..),
  19   AutoRacingResultsListingConstructor(..) )
  20 --  AutoRacingResultsRaceInformationConstructor(..) )
  21 where
  22
  23 -- System imports.
  24 import Control.Monad ( forM_ )
  25 import Data.Time ( UTCTime(..) )
  26 import Data.Tuple.Curry ( uncurryN )
  27 import Database.Groundhog (
  28   countAll,
  29   deleteAll,
  30   migrate,
  31   runMigration,
  32   silentMigrationLogger )
  33 import Database.Groundhog.Core ( DefaultKey )
  34 import Database.Groundhog.Generic ( runDbConn )
  35 import Database.Groundhog.Sqlite ( withSqliteConn )
  36 import Database.Groundhog.TH (
  37   groundhog,
  38   mkPersist )
  39 import Test.Tasty ( TestTree, testGroup )
  40 import Test.Tasty.HUnit ( (@?=), testCase )
  41 import Text.XML.HXT.Core (
  42   PU,
  43   xp7Tuple,
  44   xp8Tuple,
  45   xp10Tuple,
  46   xpElem,
  47   xpInt,
  48   xpList,
  49   xpOption,
  50   xpText,
  51   xpWrap )
  52
  53 -- Local imports.
  54 import TSN.Codegen (
  55   tsn_codegen_config )
  56 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  57 import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
  58 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  59 import Xml (
  60   FromXml(..),
  61   FromXmlFk(..),
  62   ToDb(..),
  63   pickle_unpickle,
  64   unpickleable,
  65   unsafe_unpickle )
  66
  67
  68 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  69 --
  70 dtd :: String
  71 dtd = "AutoRacingResultsXML.dtd"
  72
  73 --
  74 -- DB/XML data types
  75 --
  76
  77 -- * AutoRacingResults/Message
  78
  79 -- | Database representation of a 'Message'.
  80 --
  81 data AutoRacingResults =
  82   AutoRacingResults {
  83     db_xml_file_id :: Int,
  84     db_heading :: String,
  85     db_category :: String,
  86     db_sport :: String,
  87     db_title :: String,
  88     db_race_id :: Int,
  89     db_race_date :: UTCTime,
  90     db_track_location :: String,
  91     db_laps_remaining :: Int,
  92     db_checkered_flag :: Bool,
  93     db_time_stamp :: UTCTime }
  94   deriving (Eq, Show)
  95
  96
  97
  98 -- | XML Representation of an 'AutoRacingResults'.
  99 --
 100 data Message =
 101   Message {
 102     xml_xml_file_id :: Int,
 103     xml_heading :: String,
 104     xml_category :: String,
 105     xml_sport :: String,
 106     xml_title :: String,
 107     xml_race_id :: Int,
 108     xml_race_date :: UTCTime,
 109     xml_track_location :: String,
 110     xml_laps_remaining :: Int,
 111     xml_checkered_flag :: Bool,
 112     xml_listings :: [AutoRacingResultsListingXml],
 113 --    xml_race_information :: AutoRacingResultsRaceInformation,
 114     xml_time_stamp :: UTCTime }
 115   deriving (Eq, Show)
 116
 117
 118 instance ToDb Message where
 119   -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
 120   --
 121   type Db Message = AutoRacingResults
 122
 123
 124 -- | The 'FromXml' instance for 'Message' is required for the
 125 --   'XmlImport' instance.
 126 --
 127 instance FromXml Message where
 128   -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
 129   --   the 'xml_listings' and 'xml_race_information'.
 130   --
 131   from_xml Message{..} =
 132     AutoRacingResults {
 133       db_xml_file_id = xml_xml_file_id,
 134       db_heading = xml_heading,
 135       db_category = xml_category,
 136       db_sport = xml_sport,
 137       db_title = xml_title,
 138       db_race_id = xml_race_id,
 139       db_race_date = xml_race_date,
 140       db_track_location = xml_track_location,
 141       db_laps_remaining = xml_laps_remaining,
 142       db_checkered_flag = xml_checkered_flag,
 143       db_time_stamp = xml_time_stamp }
 144
 145
 146 -- | This allows us to insert the XML representation 'Message'
 147 --   directly.
 148 --
 149 instance XmlImport Message
 150
 151
 152 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
 153
 154 -- | Database representation of a \<Listing\> contained within a
 155 --   \<Message\>.
 156 --
 157 data AutoRacingResultsListing =
 158   AutoRacingResultsListing {
 159     db_auto_racing_results_id :: DefaultKey AutoRacingResults,
 160     db_finish_position :: Int,
 161     db_starting_position :: Int,
 162     db_car_number :: Int,
 163     db_driver_id :: Int,
 164     db_driver :: String,
 165     db_car_make :: String,
 166     db_points :: Int,
 167     db_laps_completed :: Int,
 168     db_laps_leading :: Int,
 169     db_status :: Int,
 170     db_dnf :: Maybe Bool,
 171     db_nc :: Maybe Bool,
 172     db_earnings :: Maybe Int }
 173
 174
 175 -- | XML representation of a \<Listing\> contained within a
 176 --   \<message\>.
 177 --
 178 data AutoRacingResultsListingXml =
 179   AutoRacingResultsListingXml {
 180     xml_finish_position :: Int,
 181     xml_starting_position :: Int,
 182     xml_car_number :: Int,
 183     xml_driver_id :: Int,
 184     xml_driver :: String,
 185     xml_car_make :: String,
 186     xml_points :: Int,
 187     xml_laps_completed :: Int,
 188     xml_laps_leading :: Int,
 189     xml_status :: Int,
 190     xml_dnf :: Maybe Bool,
 191     xml_nc :: Maybe Bool,
 192     xml_earnings :: Maybe Int }
 193   deriving (Eq, Show)
 194
 195
 196 instance ToDb AutoRacingResultsListingXml where
 197   -- | The database analogue of an 'AutoRacingResultsListingXml' is
 198   --   an 'AutoRacingResultsListing'.
 199   --
 200   type Db AutoRacingResultsListingXml = AutoRacingResultsListing
 201
 202 instance FromXmlFk AutoRacingResultsListingXml where
 203   -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
 204   --   foreign key to) a 'AutoRacingResults'.
 205   --
 206   type Parent AutoRacingResultsListingXml = AutoRacingResults
 207
 208   -- | To convert an 'AutoRacingResultsListingXml' to an
 209   --   'AutoRacingResultsListing', we add the foreign key and copy
 210   --   everything else verbatim.
 211   --
 212   from_xml_fk fk AutoRacingResultsListingXml{..} =
 213     AutoRacingResultsListing {
 214       db_auto_racing_results_id = fk,
 215       db_finish_position = xml_finish_position,
 216       db_starting_position = xml_starting_position,
 217       db_car_number = xml_car_number,
 218       db_driver_id = xml_driver_id,
 219       db_driver = xml_driver,
 220       db_car_make = xml_car_make,
 221       db_points = xml_points,
 222       db_laps_completed = xml_laps_completed,
 223       db_laps_leading = xml_laps_leading,
 224       db_status = xml_status,
 225       db_dnf = xml_dnf,
 226       db_nc = xml_nc,
 227       db_earnings = xml_earnings }
 228
 229
 230 -- | This allows us to insert the XML representation
 231 --   'AutoRacingResultsListingXml' directly.
 232 --
 233 instance XmlImportFk AutoRacingResultsListingXml
 234
 235
 236
 237
 238 ---
 239 --- Database stuff.
 240 ---
 241
 242
 243 mkPersist tsn_codegen_config [groundhog|
 244 - entity: AutoRacingResults
 245   dbName: auto_racing_results
 246   constructors:
 247     - name: AutoRacingResults
 248       uniques:
 249         - name: unique_auto_racing_schedule
 250           type: constraint
 251           # Prevent multiple imports of the same message.
 252           fields: [db_xml_file_id]
 253
 254
 255 - entity: AutoRacingResultsListing
 256   dbName: auto_racing_results_listings
 257   constructors:
 258     - name: AutoRacingResultsListing
 259       fields:
 260         - name: db_auto_racing_results_id
 261           reference:
 262             onDelete: cascade
 263 |]