Add a teams_are_normal function to TSN.XML.Weather.

[dead/htsn-import.git] / src / TSN / XML / Weather.hs

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 2146c3f6f565597e166244bac8b970e7360b9590..0866f6f09ee7a666f54da7cb4ce47e1f60e8c47a 100644 (file)
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -13,6 +13,7 @@ module TSN.XML.Weather (
   dtd,
   is_type1,
   pickle_message,
+  teams_are_normal,
   -- * Tests
   weather_tests,
   -- * WARNING: these are private but exported to silence warnings
@@ -45,8 +46,14 @@ import Text.XML.HXT.Core (
   PU,
   XmlTree,
   (/>),
+  (>>>),
+  addNav,
+  descendantAxis,
+  filterAxis,
+  followingSiblingAxis,
   hasName,
   readDocument,
+  remNav,
   runLA,
   runX,
   xp8Tuple,
@@ -243,7 +250,7 @@ data WeatherDetailedWeatherListingItem =
     db_home_team :: String,
     db_weather_type :: Int,
     db_description :: String,
-    db_temp_adjust :: String,
+    db_temp_adjust :: Maybe String,
     db_temperature :: Int }
 
 
@@ -259,7 +266,7 @@ data WeatherDetailedWeatherListingItemXml =
     xml_home_team :: String,
     xml_weather_type :: Int,
     xml_description :: String,
-    xml_temp_adjust :: String,
+    xml_temp_adjust :: Maybe String,
     xml_temperature :: Int }
   deriving (Eq, Show)
 
@@ -420,6 +427,34 @@ is_type1 xmltree =
     elements = parse xmltree
 
 
+-- | Some weatherxml documents even have the Home/Away teams in the
+--   wrong order. We can't parse that! This next bit of voodoo detects
+--   whether or not there are any \<HomeTeam\> elements that are
+--   directly followed by sibling \<AwayTeam\> elements. This is the
+--   opposite of the usual order.
+--
+teams_are_normal :: XmlTree -> Bool
+teams_are_normal xmltree =
+  case elements of
+    [] -> True
+    _  -> False
+  where
+    parse :: XmlTree -> [XmlTree]
+    parse = runLA $  hasName "/"
+                  /> hasName "message"
+                  /> hasName "Detailed_Weather"
+                  /> hasName "DW_Listing"
+                  /> hasName "Item"
+                  >>> addNav
+                  >>> descendantAxis
+                  >>> filterAxis (hasName "HomeTeam")
+                  >>> followingSiblingAxis
+                  >>> remNav
+                  >>> hasName "AwayTeam"
+
+    elements = parse xmltree
+
+
 instance DbImport Message where
   dbmigrate _ =
     run_dbmigrate $ do
@@ -513,7 +548,7 @@ pickle_item =
              (xpElem "HomeTeam" xpText)
              (xpElem "WeatherType" xpInt)
              (xpElem "Description" xpText)
-             (xpElem "TempAdjust" xpText)
+             (xpElem "TempAdjust" (xpOption xpText))
              (xpElem "Temperature" xpInt)
   where
     from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
@@ -590,7 +625,8 @@ weather_tests =
     [ test_on_delete_cascade,
       test_pickle_of_unpickle_is_identity,
       test_unpickle_succeeds,
-      test_types_detected_correctly ]
+      test_types_detected_correctly,
+      test_normal_teams_detected_correctly ]
 
 
 -- | If we unpickle something and then pickle it, we should wind up
@@ -658,6 +694,16 @@ test_on_delete_cascade = testGroup "cascading delete tests"
       actual @?= expected
 
 
+-- | This is used in a few tests to extract an 'XmlTree' from a path.
+--
+unsafe_get_xmltree :: String -> IO XmlTree
+unsafe_get_xmltree path =
+  fmap head $ runX $ readDocument parse_opts path
+
+
+-- | We want to make sure type1 documents are detected as type1, and
+--   type2 documents detected as type2..
+--
 test_types_detected_correctly :: TestTree
 test_types_detected_correctly =
   testGroup "weatherxml types detected correctly" $
@@ -671,11 +717,28 @@ test_types_detected_correctly =
             "second type detected correctly"
             False ]
   where
-    unsafe_get_xmltree :: String -> IO XmlTree
-    unsafe_get_xmltree path =
-      fmap head $ runX $ readDocument parse_opts path
-
     check path desc expected = testCase desc $ do
       xmltree <- unsafe_get_xmltree path
       let actual = is_type1 xmltree
       actual @?= expected
+
+
+-- | We want to make sure normal teams are detected as normal, and the
+--   backwards ones are flagged as backwards.
+--
+test_normal_teams_detected_correctly :: TestTree
+test_normal_teams_detected_correctly =
+  testGroup "team order is detected correctly" [
+
+    check "normal teams are detected correctly"
+          "test/xml/weatherxml.xml"
+          True,
+
+    check "backwards teams are detected correctly"
+          "test/xml/weatherxml-backwards-teams.xml"
+          False ]
+  where
+    check desc path expected = testCase desc $ do
+      xmltree <- unsafe_get_xmltree path
+      let actual = teams_are_normal xmltree
+      actual @?= expected