X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingResults.hs;h=e2bb7e7af1edb1278410029480a5baa2352c5b3b;hb=f2c9d5fe3dcbc43309c0561d55442cf26b67889a;hp=d96c7495f8c171cd10b71d315a5c849a22b5d5cf;hpb=9320bfe4aa73724f5988f88f13d5882d9119be39;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index d96c749..e2bb7e7 100644 --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -1,4 +1,6 @@ + {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -24,6 +26,7 @@ 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 ) @@ -39,6 +42,7 @@ 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 ( @@ -46,6 +50,7 @@ import Text.XML.HXT.Core ( xp11Tuple, xp13Tuple, xpAttr, + xpDefault, xpElem, xpInt, xpList, @@ -57,12 +62,17 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. -import TSN.Codegen ( - tsn_codegen_config ) +import Generics ( Generic(..), prepend, to_tuple ) +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_earnings, xp_datetime, 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(..), @@ -122,7 +132,11 @@ data Message = xml_listings :: [AutoRacingResultsListingXml], xml_race_information :: AutoRacingResultsRaceInformationXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message instance ToDb Message where @@ -162,46 +176,55 @@ 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 } - + _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 'Generics.prepend'. +-- +instance Generic 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, Show) - + _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 'Generics.to_tuple'. +-- +instance Generic AutoRacingResultsListingXml instance ToDb AutoRacingResultsListingXml where -- | The database analogue of an 'AutoRacingResultsListingXml' is @@ -210,32 +233,19 @@ 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. -- - from_xml_fk fk AutoRacingResultsListingXml{..} = - AutoRacingResultsListing { - db_auto_racing_results_id = fk, - db_finish_position = xml_finish_position, - db_starting_position = xml_starting_position, - db_car_number = xml_car_number, - db_driver_id = xml_driver_id, - db_driver = xml_driver, - db_car_make = xml_car_make, - db_points = xml_points, - db_laps_completed = xml_laps_completed, - db_laps_leading = xml_laps_leading, - db_status = xml_status, - db_dnf = xml_dnf, - db_nc = xml_nc, - db_earnings = xml_earnings } + from_xml_fk = prepend -- | This allows us to insert the XML representation @@ -253,23 +263,34 @@ instance XmlImportFk AutoRacingResultsListingXml -- 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 :: Int, - db_most_laps_leading_driver :: String, - db_most_laps_leading_number_of_laps :: Int } + 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 --- \. +-- | 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 :: 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, @@ -288,7 +309,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, @@ -299,8 +320,8 @@ data AutoRacingResultsRaceInformationXml = xml_cautions :: Maybe String, xml_lead_changes :: Maybe String, xml_lap_leaders :: Maybe String, - xml_most_laps_leading :: MostLapsLeading } - deriving (Eq,Show) + xml_most_laps_leading :: Maybe MostLapsLeading } + deriving (Eq, Show) instance ToDb AutoRacingResultsRaceInformationXml where @@ -311,15 +332,18 @@ 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. + -- massage the 'MostLapsLeading' embedded type, -- from_xml_fk fk AutoRacingResultsRaceInformationXml{..} = AutoRacingResultsRaceInformation { @@ -335,7 +359,14 @@ instance FromXmlFk AutoRacingResultsRaceInformationXml where db_cautions = xml_cautions, db_lead_changes = xml_lead_changes, db_lap_leaders = xml_lap_leaders, - db_most_laps_leading = xml_most_laps_leading } + 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 @@ -345,9 +376,9 @@ instance XmlImportFk AutoRacingResultsRaceInformationXml ---- ---- Database stuff. ---- +-- +-- * Database stuff. +-- instance DbImport Message where dbmigrate _ = @@ -363,8 +394,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 @@ -376,7 +406,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] @@ -387,13 +417,13 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: AutoRacingResultsListing fields: - - name: db_auto_racing_results_id + - 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. + # 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: @@ -446,19 +476,6 @@ pickle_listing = (xpElem "Earnings" xp_earnings) where from_tuple = uncurryN AutoRacingResultsListingXml - to_tuple m = (xml_finish_position m, - xml_starting_position m, - xml_car_number m, - xml_driver_id m, - xml_driver m, - xml_car_make m, - xml_points m, - xml_laps_completed m, - xml_laps_leading m, - xml_status m, - xml_dnf m, - xml_nc m, - xml_earnings m) -- | Pickler for the top-level 'Message'. @@ -482,48 +499,65 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_category m, - xml_sport m, - xml_race_id m, - xml_race_date m, - xml_title m, - xml_track_location m, - xml_laps_remaining m, - xml_checkered_flag m, - xml_listings m, - xml_race_information m, - xml_time_stamp m) -- | 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 MostLapsLeading +pickle_most_laps_leading :: PU (Maybe MostLapsLeading) pickle_most_laps_leading = xpElem "Most_Laps_Leading" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "DriverID" xpInt) - (xpElem "Driver" xpText) - (xpElem "NumberOfLaps" xpInt) + xpWrap (from_tuple, to_tuple') $ + xpTriple (xpOption $ xpElem "DriverID" xpInt) + (xpOption $ xpElem "Driver" xpText) + (xpOption $ xpElem "NumberOfLaps" xpInt) where - from_tuple = uncurryN MostLapsLeading - to_tuple m = (db_most_laps_leading_driver_id m, - db_most_laps_leading_driver m, - db_most_laps_leading_number_of_laps m) + 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) $ + 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 xpPrim (xpAttr "KPH" xpPrim) ) + xpElem "TrackLength" $ + xpPair xpText + (xpAttr "KPH" xp_fracpart_only_double) ) (xpElem "Laps" xpInt) (xpOption $ xpElem "AverageSpeedMPH" xpPrim) (xpOption $ xpElem "AverageSpeedKPH" xpPrim) @@ -533,7 +567,7 @@ pickle_race_information = (xpOption $ xpElem "Cautions" xpText) (xpOption $ xpElem "LeadChanges" xpText) (xpOption $ xpElem "LapLeaders" xpText) - pickle_most_laps_leading + (xpDefault Nothing pickle_most_laps_leading) where -- Derp. Since the first two are paired, we have to -- manually unpack the bazillion arguments. @@ -542,20 +576,20 @@ pickle_race_information = 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) + 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 +-- * Tasty Tests -- -- | A list of all tests for this module. @@ -573,24 +607,39 @@ 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", + + 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 = - 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", + + 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 @@ -598,24 +647,33 @@ 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", + + 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 + 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