From 4ad960facfe0b939e71e4afe4502fce3108d90e3 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 25 Jul 2014 15:15:12 -0400 Subject: [PATCH] Add a new pickler for Double values that have no leading integer. Use the new pickler to fix an unhandled AutoRacingResultsXML document. Add a test case for the aforementioned fix. --- src/TSN/Picklers.hs | 42 +++++++++ src/TSN/XML/AutoRacingResults.hs | 88 ++++++++++++------- test/shell/import-duplicates.test | 6 +- .../AutoRacingResultsXML-fractional-kph.xml | 1 + 4 files changed, 100 insertions(+), 37 deletions(-) create mode 100644 test/xml/AutoRacingResultsXML-fractional-kph.xml diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs index 3d7215a..6f131a7 100644 --- a/src/TSN/Picklers.hs +++ b/src/TSN/Picklers.hs @@ -9,6 +9,7 @@ module TSN.Picklers ( xp_datetime, xp_early_line_date, xp_earnings, + xp_fracpart_only_double, xp_gamedate, xp_tba_time, xp_time, @@ -28,6 +29,7 @@ import Data.Tree.NTree.TypeDefs ( NTree(..) ) import System.Locale ( TimeLocale( wDays, months ), defaultTimeLocale ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) +import Text.Read ( readMaybe ) import Text.XML.HXT.Arrow.Pickle ( xpText, xpWrap, @@ -148,6 +150,7 @@ format_commas x = reverse (intercalate "," $ chunksOf 3 $ reverse $ show x) + -- | Parse \ from an 'AutoRaceResultsListing'. These are -- essentially 'Int's, but they look like, -- @@ -185,6 +188,45 @@ xp_earnings = +-- | Pickle a 'Double' that can be missing its leading zero (for +-- values less than one). For example, we've seen, +-- +-- 0.5 +-- +-- Which 'xpPrim' can't handle without the leading +-- zero. Unfortunately there's no way pickle/unpickle can be +-- inverses of each other here, since \"0.5\" and \".5\" should +-- unpickle to the same 'Double'. +-- +-- Examples: +-- +-- >>> let tn = text_node "0.5" +-- >>> unpickleDoc xp_fracpart_only_double tn +-- Just 0.5 +-- +-- >>> let tn = text_node ".5" +-- >>> unpickleDoc xp_fracpart_only_double tn +-- Just 0.5 +-- +-- >>> let tn = text_node "foo" +-- >>> unpickleDoc xp_fracpart_only_double tn +-- Nothing +-- +xp_fracpart_only_double :: PU Double +xp_fracpart_only_double = + (to_double, from_double) `xpWrapMaybe` xpText + where + -- | Convert a 'String' to a 'Double', maybe. We always prepend a + -- zero, since it will fix the fraction-only values, and not hurt + -- the ones that already have a leading integer. + to_double :: String -> Maybe Double + to_double s = readMaybe ("0" ++ s) + + from_double :: Double -> String + from_double = show + + + -- | (Un)pickle an unpadded 'UTCTime'. Used for example on the -- \ elements in an 'AutoRaceResults' message. -- diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index cd5ebec..0e80b11 100644 --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -59,7 +59,11 @@ import Text.XML.HXT.Core ( -- Local imports. 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(..), @@ -528,7 +532,9 @@ pickle_race_information = 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" xpPrim) ) + xpElem "TrackLength" $ + xpPair xpText + (xpAttr "KPH" xp_fracpart_only_double) ) (xpElem "Laps" xpInt) (xpOption $ xpElem "AverageSpeedMPH" xpPrim) (xpOption $ xpElem "AverageSpeedKPH" xpPrim) @@ -578,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 @@ -603,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 diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index 94034c8..33b1e78 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -16,15 +16,15 @@ rm -f shelltest.sqlite3 # and a newsxml that aren't really supposed to import. find ./test/xml -maxdepth 1 -name '*.xml' | wc -l >>> -29 +30 >>>= 0 # Run the imports again; we should get complaints about the duplicate -# xml_file_ids. There are 2 errors for each violation, so we expect 2*25 +# xml_file_ids. There are 2 errors for each violation, so we expect 2*26 # occurrences of the string 'ERROR'. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -50 +52 >>>= 0 # Finally, clean up after ourselves. diff --git a/test/xml/AutoRacingResultsXML-fractional-kph.xml b/test/xml/AutoRacingResultsXML-fractional-kph.xml new file mode 100644 index 0000000..5576ab8 --- /dev/null +++ b/test/xml/AutoRacingResultsXML-fractional-kph.xml @@ -0,0 +1 @@ + 21475733 ATX%CRAFTSMAN-FINAL-RESULTS Statistics NASCAR-T 1747 7/23/2014 9:00:00 PM NASCAR - Camping World - 1-800 CarCash Mudsummer Classic - Final Results Eldora Speedway - New Weston, OH 0 True 1 6 54 1484 Darrell Wallace Jr. Toyota 0 150 0 Running False TBA 2 3 30 108 Ron Hornaday Jr. Chevrolet 0 150 0 Running False TBA 3 4 29 1482 Ryan Blaney Ford 0 150 0 Running False TBA 4 10 52 40 Ken Schrader Toyota 0 150 0 Running False TBA 5 13 3 1061 Ty Dillon Chevrolet 0 150 0 Running False TBA 6 18 8 1106 John H. Nemechek Toyota 0 150 0 Running False TBA 7 2 13 1483 Jeb Burton Toyota 0 150 0 Running False TBA 8 5 98 117 Johnny Sauter Toyota 0 150 0 Running False TBA 9 9 88 123 Matt Crafton Toyota 0 150 0 Running False TBA 10 19 2 1321 Austin Dillon Chevrolet 0 150 0 Running False TBA 11 8 19 1105 Tyler Reddick Ford 0 150 0 Running False TBA 12 24 77 1221 German Quiroga Toyota 0 150 0 Running False TBA 13 21 31 1085 Ben Kennedy Chevrolet 0 150 0 Running False TBA 14 7 21 1477 Joey Coulter Chevrolet 0 150 0 Running False TBA 15 27 02 1486 Tyler Young Chevrolet 0 150 0 Running False TBA 16 14 17 550 Timothy Peters Toyota 0 150 0 Running False TBA 17 23 9 1509 Chase Pistone Chevrolet 0 150 0 Running False TBA 18 16 63 999 J.R. Heffner Chevrolet 0 150 0 Running False TBA 19 26 05 1300 John Wes Townley Toyota 0 150 0 Running False TBA 20 17 20 1504 Gray Gaulding Chevrolet 0 150 0 Running False TBA 21 15 50 241 T.J. Bell Chevrolet 0 150 0 Running False TBA 22 12 35 1115 Mason Mingus Toyota 0 150 0 Running False TBA 23 20 99 1238 Bryan Silas Chevrolet 0 150 0 Running False TBA 24 25 08 1503 Korbin Forrister Chevrolet 0 150 0 Running False TBA 25 30 14 1307 Michael Annett Chevrolet 0 149 0 Running False TBA 26 11 32 965 Kyle Larson Chevrolet 0 148 0 Accident False TBA 27 29 6 171 Norm Benning Chevrolet 0 148 0 Running False TBA 28 28 80 1520 Jody Knowles Ford 0 148 0 Running False TBA 29 1 51 639 Erik Jones Toyota 0 144 0 Running False TBA 30 22 03 1518 Michael Affarano Chevrolet 0 93 0 Overheating False TBA 0.5 150 50.195 80.764 50.195 1 Hr., 29 Mins., 39 Secs. 5.489 Seconds 7 for 33 laps 5 among 5 drivers 1484 Darrell Wallace Jr. 0 July 23, 2014, at 11:32 PM ET \ No newline at end of file -- 2.43.2