Make <weather> and <Description> elements optional in 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 26935cf83b84068a49001e4f700170ed348dbd2f..e7c0e3c7004ecd456e6d4a4caa92d8e4aba9a7d6 100644 (file)
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -52,10 +52,8 @@ import Text.XML.HXT.Core (
   filterAxis,
   followingSiblingAxis,
   hasName,
-  readDocument,
   remNav,
   runLA,
-  runX,
   xp8Tuple,
   xp9Tuple,
   xpAttr,
@@ -79,9 +77,9 @@ import Xml (
   FromXml(..),
   FromXmlFk(..),
   ToDb(..),
-  parse_opts,
   pickle_unpickle,
   unpickleable,
+  unsafe_read_document,
   unsafe_unpickle )
 
 
@@ -103,7 +101,7 @@ dtd = "weatherxml.dtd"
 data WeatherForecastListingXml =
   WeatherForecastListingXml {
     xml_teams :: String,
-    xml_weather :: String }
+    xml_weather :: Maybe String }
   deriving (Eq, Show)
 
 
@@ -116,7 +114,7 @@ data WeatherForecastListing =
     db_weather_forecasts_id :: DefaultKey WeatherForecast,
     db_league_name :: Maybe String,
     db_teams :: String,
-    db_weather :: String }
+    db_weather :: Maybe String }
 
 
 -- | We don't make 'WeatherForecastListingXml' an instance of
@@ -249,7 +247,7 @@ data WeatherDetailedWeatherListingItem =
     db_away_team :: String,
     db_home_team :: String,
     db_weather_type :: Int,
-    db_description :: String,
+    db_description :: Maybe String,
     db_temp_adjust :: Maybe String,
     db_temperature :: Int }
 
@@ -265,7 +263,7 @@ data WeatherDetailedWeatherListingItemXml =
     xml_away_team :: String,
     xml_home_team :: String,
     xml_weather_type :: Int,
-    xml_description :: String,
+    xml_description :: Maybe String,
     xml_temp_adjust :: Maybe String,
     xml_temperature :: Int }
   deriving (Eq, Show)
@@ -384,7 +382,8 @@ mkPersist tsn_codegen_config [groundhog|
           reference:
             onDelete: cascade
 
-# We rename the two fields that needed a "dtl" prefix to avoid a name clash.
+  # We rename the two fields that needed a "dtl" prefix to avoid a name
+  # clash.
 - entity: WeatherDetailedWeatherListingItem
   dbName: weather_detailed_items
   constructors:
@@ -507,8 +506,9 @@ pickle_listing =
     xpWrap (from_pair, to_pair) $
       xpPair
         (xpElem "teams" xpText)
-        (xpElem "weather" xpText)
+        (xpElem "weather" (xpOption xpText))
   where
+--    from_pair (ts, Nothing) = WeatherForecastListingXml ts (Just "")
     from_pair = uncurry WeatherForecastListingXml
     to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 
@@ -555,7 +555,7 @@ pickle_item =
              (xpElem "AwayTeam" xpText)
              (xpElem "HomeTeam" xpText)
              (xpElem "WeatherType" xpInt)
-             (xpElem "Description" xpText)
+             (xpElem "Description" (xpOption xpText))
              (xpElem "TempAdjust" (xpOption xpText))
              (xpElem "Temperature" xpInt)
   where
@@ -661,7 +661,9 @@ test_unpickle_succeeds = testGroup "unpickle tests"
   [ check "unpickling succeeds"
           "test/xml/weatherxml.xml",
     check "unpickling succeeds (detailed)"
-          "test/xml/weatherxml-detailed.xml" ]
+          "test/xml/weatherxml-detailed.xml",
+    check "unpickling succeeds (empty weather)"
+          "test/xml/weatherxml-empty-weather.xml"]
   where
     check desc path = testCase desc $ do
       actual <- unpickleable path pickle_message
@@ -677,7 +679,9 @@ test_on_delete_cascade = testGroup "cascading delete tests"
   [ check "deleting weather deletes its children"
           "test/xml/weatherxml.xml",
     check "deleting weather deletes its children (detailed)"
-          "test/xml/weatherxml-detailed.xml" ]
+          "test/xml/weatherxml-detailed.xml",
+    check "deleting weather deletes its children (empty weather)"
+          "test/xml/weatherxml-empty-weather.xml"]
   where
     check desc path = testCase desc $ do
       weather <- unsafe_unpickle path pickle_message
@@ -702,31 +706,27 @@ 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" $
+  testGroup "weatherxml types detected correctly"
     [ check "test/xml/weatherxml.xml"
             "first type detected correctly"
             True,
       check "test/xml/weatherxml-detailed.xml"
             "first type detected correctly (detailed)"
             True,
+      check "test/xml/weatherxml-empty-weather.xml"
+            "first type detected correctly (empty weather)"
+            True,
       check "test/xml/weatherxml-type2.xml"
             "second type detected correctly"
             False ]
   where
     check path desc expected = testCase desc $ do
-      xmltree <- unsafe_get_xmltree path
+      xmltree <- unsafe_read_document path
       let actual = is_type1 xmltree
       actual @?= expected
 
@@ -747,6 +747,6 @@ test_normal_teams_detected_correctly =
           False ]
   where
     check desc path expected = testCase desc $ do
-      xmltree <- unsafe_get_xmltree path
+      xmltree <- unsafe_read_document path
       let actual = teams_are_normal xmltree
       actual @?= expected