X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingResults.hs;h=0e80b11b4702a18756328f2021d0d123a174e5ac;hb=4ad960facfe0b939e71e4afe4502fce3108d90e3;hp=596b0bd46c4d7fff742a444f304ef3a7ec462360;hpb=f2c3c36ec22bbf8d56a9a2cfdfc49276facc349b;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index 596b0bd..0e80b11 100644 --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -57,12 +57,16 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. -import TSN.Codegen ( - tsn_codegen_config ) +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_earnings, xp_racedate, xp_time_stamp ) +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(..), @@ -82,7 +86,9 @@ dtd = "AutoRacingResultsXML.dtd" -- * AutoRacingResults/Message --- | Database representation of a '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 { @@ -101,7 +107,9 @@ data AutoRacingResults = --- | XML Representation of an 'AutoRacingResults'. +-- | XML Representation of an 'AutoRacingResults'. It has the same +-- fields, but in addition contains the 'xml_listings' and +-- 'xml_race_information'. -- data Message = Message { @@ -158,7 +166,7 @@ instance XmlImport Message -- * AutoRacingResultsListing/AutoRacingResultsListingXml -- | Database representation of a \ contained within a --- \. +-- \. -- data AutoRacingResultsListing = AutoRacingResultsListing { @@ -177,6 +185,7 @@ data AutoRacingResultsListing = db_nc :: Maybe Bool, db_earnings :: Maybe Int } + -- | XML representation of a \ contained within a -- \. -- @@ -204,12 +213,15 @@ instance ToDb AutoRacingResultsListingXml where -- type Db AutoRacingResultsListingXml = AutoRacingResultsListing -instance FromXmlFk AutoRacingResultsListingXml where + +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. @@ -255,15 +267,16 @@ data MostLapsLeading = deriving (Data, Eq, Show, Typeable) --- | Database representation of a \ contained within a --- \. +-- | Database representation of a \ contained +-- within a \. -- data AutoRacingResultsRaceInformation = AutoRacingResultsRaceInformation { -- Note the apostrophe to disambiguate it from the - -- AutoRacingResultsListing filed. + -- AutoRacingResultsListing field. db_auto_racing_results_id' :: DefaultKey AutoRacingResults, - db_track_length :: Double, + 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, @@ -282,7 +295,7 @@ data AutoRacingResultsRaceInformation = -- data AutoRacingResultsRaceInformationXml = AutoRacingResultsRaceInformationXml { - xml_track_length :: Double, + xml_track_length :: String, xml_track_length_kph :: Double, xml_laps :: Int, xml_average_speed_mph :: Maybe Double, @@ -305,12 +318,15 @@ instance ToDb AutoRacingResultsRaceInformationXml where type Db AutoRacingResultsRaceInformationXml = AutoRacingResultsRaceInformation -instance FromXmlFk AutoRacingResultsRaceInformationXml where + +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 -- copy everything else verbatim. @@ -339,9 +355,9 @@ instance XmlImportFk AutoRacingResultsRaceInformationXml ---- ---- Database stuff. ---- +-- +-- * Database stuff. +-- instance DbImport Message where dbmigrate _ = @@ -357,8 +373,7 @@ instance DbImport Message where insert_xml_fk_ msg_id (xml_race_information m) - forM_ (xml_listings m) $ \listing -> do - insert_xml_fk_ msg_id listing + forM_ (xml_listings m) $ insert_xml_fk_ msg_id return ImportSucceeded @@ -370,7 +385,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: AutoRacingResults uniques: - - name: unique_auto_racing_schedule + - name: unique_auto_racing_results type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] @@ -385,19 +400,24 @@ mkPersist tsn_codegen_config [groundhog| 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} + - {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: @@ -414,6 +434,8 @@ mkPersist tsn_codegen_config [groundhog| --- Pickling --- +-- | Pickler for the \s contained within \s. +-- pickle_listing :: PU AutoRacingResultsListingXml pickle_listing = xpElem "Listing" $ @@ -449,6 +471,7 @@ pickle_listing = -- | Pickler for the top-level 'Message'. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -458,7 +481,7 @@ pickle_message = (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "RaceID" xpInt) - (xpElem "RaceDate" xp_racedate) + (xpElem "RaceDate" xp_datetime) (xpElem "Title" xpText) (xpElem "Track_Location" xpText) (xpElem "Laps_Remaining" xpInt) @@ -483,6 +506,9 @@ pickle_message = xml_time_stamp m) +-- | Pickler for the \ child of a +-- \. +-- pickle_most_laps_leading :: PU MostLapsLeading pickle_most_laps_leading = xpElem "Most_Laps_Leading" $ @@ -496,14 +522,19 @@ pickle_most_laps_leading = db_most_laps_leading_driver m, db_most_laps_leading_number_of_laps m) + +-- | Pickler for the \ child of \. +-- 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. - xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) ) + -- 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) @@ -535,7 +566,7 @@ pickle_race_information = xml_most_laps_leading m) -- --- Tasty Tests +-- * Tasty Tests -- -- | A list of all tests for this module. @@ -553,24 +584,33 @@ auto_racing_results_tests = -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree -test_pickle_of_unpickle_is_identity = - testCase "pickle composed with unpickle is the identity" $ do - let path = "test/xml/AutoRacingResultsXML.xml" - (expected, actual) <- pickle_unpickle pickle_message path - actual @?= expected +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" ] + 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 = - testCase "unpickling succeeds" $ do - let path = "test/xml/AutoRacingResultsXML.xml" - actual <- unpickleable path pickle_message +test_unpickle_succeeds = testGroup "unpickle tests" $ + [ check "unpickling succeeds" + "test/xml/AutoRacingResultsXML.xml", - let expected = True - actual @?= expected + check "unpickling succeeds (fractional KPH)" + "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + where + check desc path = testCase desc $ do + actual <- unpickleable path pickle_message + let expected = True + actual @?= expected @@ -578,24 +618,29 @@ test_unpickle_succeeds = -- record. -- test_on_delete_cascade :: TestTree -test_on_delete_cascade = - testCase "deleting auto_racing_results deletes its children" $ do - let path = "test/xml/AutoRacingResultsXML.xml" - results <- unsafe_unpickle path pickle_message - let a = undefined :: AutoRacingResults - let b = undefined :: AutoRacingResultsListing - let c = undefined :: AutoRacingResultsRaceInformation - - actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ 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 +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" ] + 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 + runMigration silentMigrationLogger $ 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