--
module TSN.XML.Weather (
dtd,
+ is_type1,
pickle_message,
+ teams_are_normal,
-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
+ XmlTree,
+ (/>),
+ (>>>),
+ addNav,
+ descendantAxis,
+ filterAxis,
+ followingSiblingAxis,
+ hasName,
+ remNav,
+ runLA,
xp8Tuple,
xp9Tuple,
xpAttr,
ToDb(..),
pickle_unpickle,
unpickleable,
+ unsafe_read_document,
unsafe_unpickle )
instance FromXmlFk WeatherForecastXml where
-- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
- -- just copy everything verbatim.
+ -- add the foreign key to the containing 'Weather', and copy the
+ -- game date.
--
from_xml_fk fk WeatherForecastXml{..} =
WeatherForecast {
db_home_team :: String,
db_weather_type :: Int,
db_description :: String,
- db_temp_adjust :: String,
+ db_temp_adjust :: Maybe String,
db_temperature :: Int }
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)
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:
|]
+
+-- | There are two different types of documents that claim to be
+-- \"weatherxml.dtd\". The first, more common type has listings
+-- within forecasts. The second type has forecasts within
+-- listings. Clearly we can't parse both of these using the same
+-- parser!
+--
+-- For now we're simply punting on the issue and refusing to parse
+-- the second type. This will check the given @xmltree@ to see if
+-- there are any forecasts contained within listings. If there are,
+-- then it's the second type that we don't know what to do with.
+--
+is_type1 :: XmlTree -> Bool
+is_type1 xmltree =
+ case elements of
+ [] -> True
+ _ -> False
+ where
+ parse :: XmlTree -> [XmlTree]
+ parse = runLA $ hasName "/"
+ /> hasName "message"
+ /> hasName "listing"
+ /> hasName "forecast"
+
+ 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
-- And finally, insert those DB listings.
mapM_ insert_ db_listings
+ -- Now we do the detailed weather items.
+ case (xml_detailed_weather m) of
+ Nothing -> return ()
+ Just dw -> do
+ let detailed_listings = xml_detailed_listings dw
+ let items = concatMap xml_items detailed_listings
+ mapM_ (insert_xml_fk_ weather_id) items
+
return ImportSucceeded
(xpElem "HomeTeam" xpText)
(xpElem "WeatherType" xpInt)
(xpElem "Description" xpText)
- (xpElem "TempAdjust" xpText)
+ (xpElem "TempAdjust" (xpOption xpText))
(xpElem "Temperature" xpInt)
where
from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
"Weather tests"
[ test_on_delete_cascade,
test_pickle_of_unpickle_is_identity,
- test_unpickle_succeeds ]
+ test_unpickle_succeeds,
+ test_types_detected_correctly,
+ test_normal_teams_detected_correctly ]
-- | If we unpickle something and then pickle it, we should wind up
return $ count_a + count_b + count_c + count_d
let expected = 0
actual @?= expected
+
+
+-- | 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"
+ [ 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-type2.xml"
+ "second type detected correctly"
+ False ]
+ where
+ check path desc expected = testCase desc $ do
+ xmltree <- unsafe_read_document 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_read_document path
+ let actual = teams_are_normal xmltree
+ actual @?= expected