{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each -- \ element contains a \ and a bunch of -- \s. -- module TSN.XML.AutoRacingResults ( dtd, pickle_message, -- * Tests auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings AutoRacingResultsConstructor(..), AutoRacingResultsListingConstructor(..), AutoRacingResultsRaceInformationConstructor(..) ) where -- System imports. import Control.Monad ( forM_ ) import Data.Data ( Data ) import Data.Maybe ( fromMaybe ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) import qualified Data.Vector.HFixed as H ( HVector, cons, convert ) import Database.Groundhog ( countAll, deleteAll, migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xp11Tuple, xp13Tuple, xpAttr, xpDefault, xpElem, xpInt, xpList, xpOption, xpPair, xpPrim, xpText, xpTriple, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_earnings, xp_fracpart_only_double, xp_datetime, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "AutoRacingResultsXML.dtd" -- -- DB/XML data types -- -- * AutoRacingResults/Message -- | Database representation of a 'Message'. Comparatively, it lacks -- the listings and race information since they are linked via a -- foreign key. -- data AutoRacingResults = AutoRacingResults { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_race_id :: Int, db_race_date :: UTCTime, db_title :: String, db_track_location :: String, db_laps_remaining :: Int, db_checkered_flag :: Bool, db_time_stamp :: UTCTime } deriving (Eq, Show) -- | XML Representation of an 'AutoRacingResults'. It has the same -- fields, but in addition contains the 'xml_listings' and -- 'xml_race_information'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_race_id :: Int, xml_race_date :: UTCTime, xml_title :: String, xml_track_location :: String, xml_laps_remaining :: Int, xml_checkered_flag :: Bool, xml_listings :: [AutoRacingResultsListingXml], xml_race_information :: AutoRacingResultsRaceInformationXml, xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector Message instance ToDb Message where -- | The database analogue of a 'Message' is a 'AutoRacingResults'. -- type Db Message = AutoRacingResults -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'AutoRacingResults', we just drop -- the 'xml_listings' and 'xml_race_information'. -- from_xml Message{..} = AutoRacingResults { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_race_id = xml_race_id, db_race_date = xml_race_date, db_title = xml_title, db_track_location = xml_track_location, db_laps_remaining = xml_laps_remaining, db_checkered_flag = xml_checkered_flag, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- * AutoRacingResultsListing/AutoRacingResultsListingXml -- | Database representation of a \ contained within a -- \. The leading underscores prevent unused field -- warnings. -- data AutoRacingResultsListing = AutoRacingResultsListing { _db_auto_racing_results_id :: DefaultKey AutoRacingResults, _db_finish_position :: Int, _db_starting_position :: Int, _db_car_number :: Int, _db_driver_id :: Int, _db_driver :: String, _db_car_make :: String, _db_points :: Int, _db_laps_completed :: Int, _db_laps_leading :: Int, _db_status :: Maybe String, _db_dnf :: Maybe Bool, _db_nc :: Maybe Bool, _db_earnings :: Maybe Int } deriving ( GHC.Generic ) -- | For 'H.convert' and 'H.cons'. -- instance H.HVector AutoRacingResultsListing -- | XML representation of a \ contained within a -- \. The leading underscores prevent unused field -- warnings. -- data AutoRacingResultsListingXml = AutoRacingResultsListingXml { _xml_finish_position :: Int, _xml_starting_position :: Int, _xml_car_number :: Int, _xml_driver_id :: Int, _xml_driver :: String, _xml_car_make :: String, _xml_points :: Int, _xml_laps_completed :: Int, _xml_laps_leading :: Int, _xml_status :: Maybe String, _xml_dnf :: Maybe Bool, _xml_nc :: Maybe Bool, _xml_earnings :: Maybe Int } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector AutoRacingResultsListingXml instance ToDb AutoRacingResultsListingXml where -- | The database analogue of an 'AutoRacingResultsListingXml' is -- an 'AutoRacingResultsListing'. -- type Db AutoRacingResultsListingXml = AutoRacingResultsListing instance Child AutoRacingResultsListingXml where -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a -- foreign key to) a 'AutoRacingResults'. -- type Parent AutoRacingResultsListingXml = AutoRacingResults instance FromXmlFk AutoRacingResultsListingXml where -- | To convert an 'AutoRacingResultsListingXml' to an -- 'AutoRacingResultsListing', we add the foreign key and copy -- everything else verbatim. -- from_xml_fk = H.cons -- | This allows us to insert the XML representation -- 'AutoRacingResultsListingXml' directly. -- instance XmlImportFk AutoRacingResultsListingXml -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml -- | The \ child of \ always -- contains exactly three fields, so we just embed those three into -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use -- the \"db_\" prefix since our field namer is going to strip of -- everything before the first underscore. -- -- We make the three fields optional because the entire -- \ is apparently optional (although it is -- usually present). A 'Nothing' in the XML should get turned into -- three 'Nothing's in the DB. -- data MostLapsLeading = MostLapsLeading { db_most_laps_leading_driver_id :: Maybe Int, db_most_laps_leading_driver :: Maybe String, db_most_laps_leading_number_of_laps :: Maybe Int } deriving (Data, Eq, Show, Typeable) -- | Database representation of a \ contained -- within a \. -- -- The 'db_most_laps_leading' field is not optional because when we -- convert from our XML representation, a missing 'MostLapsLeading' -- will be replaced with a 'MostLapsLeading' with three missing -- fields. -- data AutoRacingResultsRaceInformation = AutoRacingResultsRaceInformation { -- Note the apostrophe to disambiguate it from the -- AutoRacingResultsListing field. db_auto_racing_results_id' :: DefaultKey AutoRacingResults, db_track_length :: String, -- ^ Usually a Double, but sometimes a String, -- like \"1.25 miles\". db_track_length_kph :: Double, db_laps :: Int, db_average_speed_mph :: Maybe Double, db_average_speed_kph :: Maybe Double, db_average_speed :: Maybe Double, db_time_of_race :: Maybe String, db_margin_of_victory :: Maybe String, db_cautions :: Maybe String, db_lead_changes :: Maybe String, db_lap_leaders :: Maybe String, db_most_laps_leading :: MostLapsLeading } -- | XML representation of a \ contained within a -- \. -- data AutoRacingResultsRaceInformationXml = AutoRacingResultsRaceInformationXml { xml_track_length :: String, xml_track_length_kph :: Double, xml_laps :: Int, xml_average_speed_mph :: Maybe Double, xml_average_speed_kph :: Maybe Double, xml_average_speed :: Maybe Double, xml_time_of_race :: Maybe String, xml_margin_of_victory :: Maybe String, xml_cautions :: Maybe String, xml_lead_changes :: Maybe String, xml_lap_leaders :: Maybe String, xml_most_laps_leading :: Maybe MostLapsLeading } deriving (Eq, Show) instance ToDb AutoRacingResultsRaceInformationXml where -- | The database analogue of an -- 'AutoRacingResultsRaceInformationXml' is an -- 'AutoRacingResultsRaceInformation'. -- type Db AutoRacingResultsRaceInformationXml = AutoRacingResultsRaceInformation instance Child AutoRacingResultsRaceInformationXml where -- | Each 'AutoRacingResultsRaceInformationXml' is contained in -- (i.e. has a foreign key to) a 'AutoRacingResults'. -- type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults instance FromXmlFk AutoRacingResultsRaceInformationXml where -- | To convert an 'AutoRacingResultsRaceInformationXml' to an -- 'AutoRacingResultsRaceInformartion', we add the foreign key and -- massage the 'MostLapsLeading' embedded type, -- from_xml_fk fk AutoRacingResultsRaceInformationXml{..} = AutoRacingResultsRaceInformation { db_auto_racing_results_id' = fk, db_track_length = xml_track_length, db_track_length_kph = xml_track_length_kph, db_laps = xml_laps, db_average_speed_mph = xml_average_speed_mph, db_average_speed_kph = xml_average_speed_kph, db_average_speed = xml_average_speed, db_time_of_race = xml_time_of_race, db_margin_of_victory = xml_margin_of_victory, db_cautions = xml_cautions, db_lead_changes = xml_lead_changes, db_lap_leaders = xml_lap_leaders, db_most_laps_leading = most_laps_leading } where -- If we didn't get a \, indicate that in -- the database with an (embedded) 'MostLapsLeading' with three -- missing fields. most_laps_leading = fromMaybe (MostLapsLeading Nothing Nothing Nothing) xml_most_laps_leading -- | This allows us to insert the XML representation -- 'AutoRacingResultsRaceInformationXml' directly. -- instance XmlImportFk AutoRacingResultsRaceInformationXml -- -- * Database stuff. -- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: AutoRacingResults) migrate (undefined :: AutoRacingResultsListing) migrate (undefined :: AutoRacingResultsRaceInformation) -- | We insert the message, then use its ID to insert the listings -- and race information. dbimport m = do msg_id <- insert_xml m insert_xml_fk_ msg_id (xml_race_information m) forM_ (xml_listings m) $ insert_xml_fk_ msg_id return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: AutoRacingResults dbName: auto_racing_results constructors: - name: AutoRacingResults uniques: - name: unique_auto_racing_results type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - entity: AutoRacingResultsListing dbName: auto_racing_results_listings constructors: - name: AutoRacingResultsListing fields: - name: _db_auto_racing_results_id reference: onDelete: cascade # Note the apostrophe in the foreign key. This is to disambiguate # it from the AutoRacingResultsListing foreign key of the same name. # We strip it out of the dbName. - entity: AutoRacingResultsRaceInformation dbName: auto_racing_results_race_information constructors: - name: AutoRacingResultsRaceInformation fields: - name: db_auto_racing_results_id' dbName: auto_racing_results_id reference: onDelete: cascade - name: db_most_laps_leading embeddedType: - {name: most_laps_leading_driver_id, dbName: most_laps_leading_driver_id} - {name: most_laps_leading_driver, dbName: most_laps_leading_driver} - embedded: MostLapsLeading fields: - name: db_most_laps_leading_driver_id dbName: most_laps_leading_driver_id - name: db_most_laps_leading_driver dbName: most_laps_leading_driver - name: db_most_laps_leading_number_of_laps dbName: most_laps_leading_number_of_laps |] --- --- Pickling --- -- | Pickler for the \s contained within \s. -- pickle_listing :: PU AutoRacingResultsListingXml pickle_listing = xpElem "Listing" $ xpWrap (from_tuple, H.convert) $ xp13Tuple (xpElem "FinishPosition" xpInt) (xpElem "StartingPosition" xpInt) (xpElem "CarNumber" xpInt) (xpElem "DriverID" xpInt) (xpElem "Driver" xpText) (xpElem "CarMake" xpText) (xpElem "Points" xpInt) (xpElem "Laps_Completed" xpInt) (xpElem "Laps_Leading" xpInt) (xpElem "Status" $ xpOption xpText) (xpOption $ xpElem "DNF" xpPrim) (xpOption $ xpElem "NC" xpPrim) (xpElem "Earnings" xp_earnings) where from_tuple = uncurryN AutoRacingResultsListingXml -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, H.convert) $ xp13Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "RaceID" xpInt) (xpElem "RaceDate" xp_datetime) (xpElem "Title" xpText) (xpElem "Track_Location" xpText) (xpElem "Laps_Remaining" xpInt) (xpElem "Checkered_Flag" xpPrim) (xpList pickle_listing) pickle_race_information (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message -- | Pickler for the \ child of a -- \. This is complicated by the fact that the -- three fields we're trying to parse are not actually optional; -- only the entire \ is. So we always wrap what -- we parse in a 'Just', and when converting from the DB to XML, -- we'll drop the entire element if any of its fields are missing -- (which they never should be). -- pickle_most_laps_leading :: PU (Maybe MostLapsLeading) pickle_most_laps_leading = xpElem "Most_Laps_Leading" $ xpWrap (from_tuple, to_tuple') $ xpTriple (xpOption $ xpElem "DriverID" xpInt) (xpOption $ xpElem "Driver" xpText) (xpOption $ xpElem "NumberOfLaps" xpInt) where from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading from_tuple (Just x, Just y, Just z) = Just $ MostLapsLeading (Just x) (Just y) (Just z) from_tuple _ = Nothing -- Sure had to go out of my way to avoid the warnings about unused -- db_most_laps_foo fields here. to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int) to_tuple' Nothing = (Nothing, Nothing, Nothing) to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing) to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing) to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing) to_tuple' (Just m) = (db_most_laps_leading_driver_id m, db_most_laps_leading_driver m, db_most_laps_leading_number_of_laps m) -- | Pickler for the \ child of \. -- -- There's so much voodoo going on here. We have a double-layered -- Maybe on top of the MostLapsLeading. When unpickling, we return a -- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are -- missing. But if the entire element is missing, unpickling -- fails. 'xpOption' doesn't fix this because it would give us a -- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a -- default of (Nothing :: Maybe MostLapsLeading) to stick one in -- there if unpicking a (Maybe MostLapsLeading) fails because -- \ is missing. -- -- Clear as mud, I know. -- pickle_race_information :: PU AutoRacingResultsRaceInformationXml pickle_race_information = xpElem "Race_Information" $ xpWrap (from_tuple, to_tuple') $ xp11Tuple (-- I can't think of another way to get both the -- TrackLength and its KPH attribute. So we shove them -- both in a 2-tuple. This should probably be an embedded type! xpElem "TrackLength" $ xpPair xpText (xpAttr "KPH" xp_fracpart_only_double) ) (xpElem "Laps" xpInt) (xpOption $ xpElem "AverageSpeedMPH" xpPrim) (xpOption $ xpElem "AverageSpeedKPH" xpPrim) (xpOption $ xpElem "AverageSpeed" xpPrim) (xpOption $ xpElem "TimeOfRace" xpText) (xpOption $ xpElem "MarginOfVictory" xpText) (xpOption $ xpElem "Cautions" xpText) (xpOption $ xpElem "LeadChanges" xpText) (xpOption $ xpElem "LapLeaders" xpText) (xpDefault Nothing pickle_most_laps_leading) where -- Derp. Since the first two are paired, we have to -- manually unpack the bazillion arguments. from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) = AutoRacingResultsRaceInformationXml x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 -- And here we have to re-pair the first two. to_tuple' m = ((xml_track_length m, xml_track_length_kph m), xml_laps m, xml_average_speed_mph m, xml_average_speed_kph m, xml_average_speed m, xml_time_of_race m, xml_margin_of_victory m, xml_cautions m, xml_lead_changes m, xml_lap_leaders m, xml_most_laps_leading m) -- -- * Tasty Tests -- -- | A list of all tests for this module. -- auto_racing_results_tests :: TestTree auto_racing_results_tests = testGroup "AutoRacingResults tests" [ test_on_delete_cascade, test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] -- | If we unpickle something and then pickle it, we should wind up -- with the same thing we started with. WARNING: success of this -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" "test/xml/AutoRacingResultsXML.xml", check "pickle composed with unpickle is the identity (fractional KPH)" "test/xml/AutoRacingResultsXML-fractional-kph.xml", check "pickle composed with unpickle is the identity (No Most_Laps_Leading)" "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected -- | Make sure we can actually unpickle these things. -- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/AutoRacingResultsXML.xml", check "unpickling succeeds (fractional KPH)" "test/xml/AutoRacingResultsXML-fractional-kph.xml", check "unpickling succeeds (no Most_Laps_Leading)" "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message let expected = True actual @?= expected -- | Make sure everything gets deleted when we delete the top-level -- record. -- test_on_delete_cascade :: TestTree test_on_delete_cascade = testGroup "cascading delete tests" [ check "deleting auto_racing_results deletes its children" "test/xml/AutoRacingResultsXML.xml", check "deleting auto_racing_results deletes its children (fractional KPH)" "test/xml/AutoRacingResultsXML-fractional-kph.xml", check ("deleting auto_racing_results deletes its children " ++ "(No Most_Laps_Leading)") "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ] where check desc path = testCase desc $ do results <- unsafe_unpickle path pickle_message let a = undefined :: AutoRacingResults let b = undefined :: AutoRacingResultsListing let c = undefined :: AutoRacingResultsRaceInformation actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigrationSilent $ do migrate a migrate b migrate c _ <- dbimport results deleteAll a count_a <- countAll a count_b <- countAll b count_c <- countAll c return $ sum [count_a, count_b, count_c] let expected = 0 actual @?= expected