X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=2f3a3ca2b2d32a8759083b13ffa675338393978d;hb=32147474ba5c91452eeb532381f63e88c257a982;hp=092cc7e54aff76c278a5313d43928381b5f37063;hpb=4fc769d60f0cac3b4a0cf38add8d8e883583bd61;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 092cc7e..2f3a3ca 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -5,18 +6,20 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD "weatherxml.dtd". Each document --- contains a bunch of forecasts, which each contain one league, and --- that league contains a bunch of listings. +-- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document +-- contains a bunch of forecasts, which each contain zero or more +-- leagues, which in turn (each) contain a bunch of listings. -- module TSN.XML.Weather ( + dtd, + is_type1, pickle_message, + teams_are_normal, -- * Tests weather_tests, -- * WARNING: these are private but exported to silence warnings - Weather_WeatherForecastConstructor(..), WeatherConstructor(..), - WeatherForecast_WeatherForecastListingConstructor(..), + WeatherDetailedWeatherListingItemConstructor(..), WeatherForecastConstructor(..), WeatherForecastListingConstructor(..) ) where @@ -25,18 +28,35 @@ where import Control.Monad ( forM_ ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, cons, convert ) import Database.Groundhog ( + countAll, + deleteAll, insert_, migrate ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) +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 ( PU, - xp7Tuple, + XmlTree, + (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, + hasName, + remNav, + runLA, + xp8Tuple, + xp9Tuple, xpAttr, xpElem, xpInt, @@ -44,62 +64,289 @@ import Text.XML.HXT.Core ( xpOption, xpPair, xpText, + xpTriple, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_gamedate ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp ) +import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) +import Xml ( + Child(..), + FromXml(..), + FromXmlFk(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_read_document, + unsafe_unpickle ) + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "weatherxml.dtd" + + +-- +-- DB/XML Data types +-- + +-- * WeatherForecastListing/WeatherForecastListingXml + +-- | XML representation of a weather forecast listing. +-- +data WeatherForecastListingXml = + WeatherForecastListingXml { + xml_teams :: String, + xml_weather :: Maybe String } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector WeatherForecastListingXml + + +-- | Database representation of a weather forecast listing. The +-- 'db_league_name' field should come from the containing \ +-- element which is not stored in the database. +-- data WeatherForecastListing = WeatherForecastListing { + db_weather_forecasts_id :: DefaultKey WeatherForecast, + db_league_name :: Maybe String, db_teams :: String, - db_weather :: String } - deriving (Eq, Show) - -instance FromXml WeatherForecastListing where - type Db WeatherForecastListing = WeatherForecastListing - from_xml = id - -instance XmlImport WeatherForecastListing + db_weather :: Maybe String } +-- | We don't make 'WeatherForecastListingXml' an instance of +-- 'FromXmlFk' because it needs some additional information, namely +-- the league name from its containing \ element. +-- +-- When supplied with a forecast id and a league name, this will +-- turn an XML listing into a database one. +-- +from_xml_fk_league :: DefaultKey WeatherForecast + -> (Maybe String) + -> WeatherForecastListingXml + -> WeatherForecastListing +from_xml_fk_league fk ln WeatherForecastListingXml{..} = + WeatherForecastListing { + db_weather_forecasts_id = fk, + db_league_name = ln, + db_teams = xml_teams, + db_weather = xml_weather } + + +-- * WeatherLeague + +-- | XML representation of a league, as they appear in the weather +-- documents. There is no associated database representation because +-- the league element really adds no information besides its own +-- (usually empty) name. The leagues contain listings, so we +-- associate the league name with each listing instead. +-- data WeatherLeague = WeatherLeague { - league_name :: Maybe String, - listings :: [WeatherForecastListing] } + league_name :: Maybe String, + listings :: [WeatherForecastListingXml] } deriving (Eq, Show) + +-- * WeatherForecast/WeatherForecastXml + +-- | Database representation of a weather forecast. +-- data WeatherForecast = WeatherForecast { - db_game_date :: UTCTime, - db_league_name :: Maybe String } + db_weather_id :: DefaultKey Weather, + db_game_date :: UTCTime } + +-- | XML representation of a weather forecast. +-- data WeatherForecastXml = WeatherForecastXml { xml_game_date :: UTCTime, - xml_league :: WeatherLeague } - deriving (Eq, Show) + xml_leagues :: [WeatherLeague] } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector WeatherForecastXml -instance FromXml WeatherForecastXml where +instance ToDb WeatherForecastXml where + -- | The database representation of a 'WeatherForecastXml' is a + -- 'WeatherForecast'. + -- type Db WeatherForecastXml = WeatherForecast - from_xml WeatherForecastXml{..} = - WeatherForecast { db_game_date = xml_game_date, - db_league_name = (league_name xml_league) } -instance XmlImport WeatherForecastXml +instance Child WeatherForecastXml where + -- | The database type containing a 'WeatherForecastXml' is + -- 'Weather'. + type Parent WeatherForecastXml = Weather + + +instance FromXmlFk WeatherForecastXml where + + -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we + -- add the foreign key to the containing 'Weather', and copy the + -- game date. + -- + -- This is so short it's pointless to do it generically. + -- + from_xml_fk fk WeatherForecastXml{..} = + WeatherForecast { + db_weather_id = fk, + db_game_date = xml_game_date } + + +-- | This allows us to call 'insert_xml' on an 'WeatherForecastXml' +-- without first converting it to the database representation. +-- +instance XmlImportFk WeatherForecastXml + +-- * WeatherDetailedWeatherXml + +-- | XML Representation of a \, which just contains +-- a bunch iof \s. There is no associated database type +-- since these don't really contain any information. +-- +data WeatherDetailedWeatherXml = + WeatherDetailedWeatherXml { + xml_detailed_listings :: [WeatherDetailedWeatherListingXml] } + deriving (Eq, Show) + + +-- * WeatherDetailedWeatherXml + +-- | XML Representation of a \. The sport and sport code +-- come as attributes, but then these just contain a bunch of +-- \s. There is no associated database type since these don't +-- contain much information. The sport we already know from the +-- \, while the sport code is ignored since it's already +-- present in each \s. +-- +data WeatherDetailedWeatherListingXml = + WeatherDetailedWeatherListingXml + String -- xml_dtl_listing_sport, unused + String -- xml_dtl_listing_sport_code, unused + [WeatherDetailedWeatherListingItemXml] -- xml_items + deriving (Eq, GHC.Generic, Show) + + +-- | Accessor for the third field of WeatherDetailedWeatherListingXml. +-- We don't use field names to avoid the unused field warnings that +-- we'd otherwise get for the first two fields. +-- +xml_items :: WeatherDetailedWeatherListingXml + -> [WeatherDetailedWeatherListingItemXml] +xml_items (WeatherDetailedWeatherListingXml _ _ items) = items + +-- | For 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingXml + + +-- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml + +-- | Database representation of a detailed weather item. The away/home +-- teams don't use the representation in "TSN.Team" because all +-- we're given is a name, and a team id is required for "TSN.Team". +-- +-- We also drop the sport name, because it's given in the parent +-- 'Weather'. +-- +-- The leading underscores prevent unused field warnings. +-- +data WeatherDetailedWeatherListingItem = + WeatherDetailedWeatherListingItem { + _db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by + -- using \"dtl\" prefix. + _db_sport_code :: String, + _db_game_id :: Int, + _db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix + _db_away_team :: String, + _db_home_team :: String, + _db_weather_type :: Int, + _db_description :: Maybe String, + _db_temp_adjust :: Maybe String, + _db_temperature :: Int } + deriving ( GHC.Generic ) + +-- | For 'H.cons' and 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingItem + + +-- | XML representation of a detailed weather item. Same as the +-- database representation, only without the foreign key and the +-- sport name that comes from the containing listing. +-- +-- The leading underscores prevent unused field warnings. +-- +data WeatherDetailedWeatherListingItemXml = + WeatherDetailedWeatherListingItemXml { + _xml_sport_code :: String, + _xml_game_id :: Int, + _xml_dtl_game_date :: UTCTime, + _xml_away_team :: String, + _xml_home_team :: String, + _xml_weather_type :: Int, + _xml_description :: Maybe String, + _xml_temp_adjust :: Maybe String, + _xml_temperature :: Int } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingItemXml + +instance ToDb WeatherDetailedWeatherListingItemXml where + -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'. + type Db WeatherDetailedWeatherListingItemXml = + WeatherDetailedWeatherListingItem + +instance Child WeatherDetailedWeatherListingItemXml where + -- | We skip two levels of containers and say that the items belong + -- to the top-level 'Weather'. + type Parent WeatherDetailedWeatherListingItemXml = Weather + +instance FromXmlFk WeatherDetailedWeatherListingItemXml where + -- | To convert from the XML to database representation, we simply + -- add the foreign key (to Weather) and copy the rest of the fields. + from_xml_fk = H.cons + +-- | This allows us to insert the XML representation directly without +-- having to do the manual XML -\> DB conversion. +-- +instance XmlImportFk WeatherDetailedWeatherListingItemXml + +-- * Weather/Message + +-- | The database representation of a weather message. We don't +-- contain the forecasts or the detailed weather since those are +-- foreigned-keyed to us. +-- data Weather = Weather { + db_xml_file_id :: Int, db_sport :: String, - db_title :: String } + db_title :: String, + db_time_stamp :: UTCTime } + +-- | The XML representation of a weather message. +-- data Message = Message { xml_xml_file_id :: Int, @@ -108,96 +355,202 @@ data Message = xml_sport :: String, xml_title :: String, xml_forecasts :: [WeatherForecastXml], - xml_time_stamp :: String } - deriving (Eq, Show) + xml_detailed_weather :: Maybe WeatherDetailedWeatherXml, + xml_time_stamp :: UTCTime } + deriving (Eq, GHC.Generic, Show) -instance FromXml Message where + +-- | For 'H.convert'. +-- +instance H.HVector Message + + +instance ToDb Message where + -- | The database representation of 'Message' is 'Weather'. + -- type Db Message = Weather + +instance FromXml Message where + -- | To get a 'Weather' from a 'Message', we drop a bunch of + -- unwanted fields. + -- from_xml Message{..} = Weather { + db_xml_file_id = xml_xml_file_id, db_sport = xml_sport, - db_title = xml_title } + db_title = xml_title, + db_time_stamp = xml_time_stamp } +-- | This allows us to insert the XML representation 'Message' +-- directly. +-- instance XmlImport Message -data Weather_WeatherForecast = - Weather_WeatherForecast - (DefaultKey Weather) - (DefaultKey WeatherForecast) - -data WeatherForecast_WeatherForecastListing = - WeatherForecast_WeatherForecastListing - (DefaultKey WeatherForecast) - (DefaultKey WeatherForecastListing) +-- +-- * Database stuff +-- mkPersist tsn_codegen_config [groundhog| - entity: Weather + constructors: + - name: Weather + uniques: + - name: unique_weather + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] - entity: WeatherForecast dbName: weather_forecasts + constructors: + - name: WeatherForecast + fields: + - name: db_weather_id + reference: + onDelete: cascade - entity: WeatherForecastListing dbName: weather_forecast_listings - -- entity: Weather_WeatherForecast - dbName: weather__weather_forecasts constructors: - - name: Weather_WeatherForecast + - name: WeatherForecastListing fields: - - name: weather_WeatherForecast0 # Default created by mkNormalFieldName - dbName: weather_id - - name: weather_WeatherForecast1 # Default created by mkNormalFieldName - dbName: weather_forecasts_id - -- entity: WeatherForecast_WeatherForecastListing - dbName: weather_forecasts__weather_forecast_listings + - name: db_weather_forecasts_id + reference: + onDelete: cascade + + # We rename the two fields that needed a "dtl" prefix to avoid a name + # clash. +- entity: WeatherDetailedWeatherListingItem + dbName: weather_detailed_items constructors: - - name: WeatherForecast_WeatherForecastListing + - name: WeatherDetailedWeatherListingItem fields: - # Default by mkNormalFieldName - - name: weatherForecast_WeatherForecastListing0 - dbName: weather_forecasts_id + - name: _db_dtl_weather_id + dbName: weather_id + reference: + onDelete: cascade + - name: _db_dtl_game_date + dbName: game_date - # Default by mkNormalFieldName - - name: weatherForecast_WeatherForecastListing1 - dbName: weather_forecast_listings_id |] + +-- | 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 \ elements that are +-- directly followed by sibling \ 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 migrate (undefined :: Weather) migrate (undefined :: WeatherForecast) migrate (undefined :: WeatherForecastListing) - migrate (undefined :: Weather_WeatherForecast) - migrate (undefined :: WeatherForecast_WeatherForecastListing) + migrate (undefined :: WeatherDetailedWeatherListingItem) dbimport m = do + -- First we insert the top-level weather record. weather_id <- insert_xml m + -- Next insert all of the forecasts, one at a time. forM_ (xml_forecasts m) $ \forecast -> do - forecast_id <- insert_xml forecast - insert_ (Weather_WeatherForecast weather_id forecast_id) - forM_ (listings $ xml_league forecast) $ \listing -> do - listing_id <- insert_xml listing - insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id + forecast_id <- insert_xml_fk weather_id forecast + + -- With the forecast id in hand, loop through this forecast's + -- leagues... + forM_ (xml_leagues forecast) $ \league -> do + -- Construct the function that converts an XML listing to a + -- database one. + let todb = from_xml_fk_league forecast_id (league_name league) + + -- Now use it to convert all of the XML listings. + let db_listings = map todb (listings league) + + -- 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 -pickle_listing :: PU WeatherForecastListing +-- +-- * Pickling +-- + +-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML. +-- +pickle_listing :: PU WeatherForecastListingXml pickle_listing = xpElem "listing" $ - xpWrap (from_pair, to_pair) $ + xpWrap (from_pair, H.convert) $ xpPair (xpElem "teams" xpText) - (xpElem "weather" xpText) + (xpElem "weather" (xpOption xpText)) where - from_pair = uncurry WeatherForecastListing - to_pair WeatherForecastListing{..} = (db_teams, db_weather) + from_pair = uncurry WeatherForecastListingXml + + +-- | Pickler to convert a 'WeatherLeague' to/from XML. +-- pickle_league :: PU WeatherLeague pickle_league = xpElem "league" $ @@ -209,50 +562,96 @@ pickle_league = from_pair = uncurry WeatherLeague to_pair WeatherLeague{..} = (league_name, listings) + +-- | Pickler to convert a 'WeatherForecastXml' to/from XML. +-- pickle_forecast :: PU WeatherForecastXml pickle_forecast = xpElem "forecast" $ xpWrap (from_pair, to_pair) $ xpPair (xpAttr "gamedate" xp_gamedate) - pickle_league + (xpList pickle_league) where from_pair = uncurry WeatherForecastXml to_pair WeatherForecastXml{..} = (xml_game_date, - xml_league) + xml_leagues) + + + +-- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'. +-- +pickle_item :: PU WeatherDetailedWeatherListingItemXml +pickle_item = + xpElem "Item" $ + xpWrap (from_tuple, H.convert) $ + xp9Tuple (xpElem "Sportcode" xpText) + (xpElem "GameID" xpInt) + (xpElem "Gamedate" xp_datetime) + (xpElem "AwayTeam" xpText) + (xpElem "HomeTeam" xpText) + (xpElem "WeatherType" xpInt) + (xpElem "Description" (xpOption xpText)) + (xpElem "TempAdjust" (xpOption xpText)) + (xpElem "Temperature" xpInt) + where + from_tuple = uncurryN WeatherDetailedWeatherListingItemXml + + + +-- | (Un)pickle a 'WeatherDetailedWeatherListingXml'. +-- +pickle_dw_listing :: PU WeatherDetailedWeatherListingXml +pickle_dw_listing = + xpElem "DW_Listing" $ + xpWrap (from_tuple, H.convert) $ + xpTriple (xpAttr "SportCode" xpText) + (xpAttr "Sport" xpText) + (xpList pickle_item) + where + from_tuple = uncurryN WeatherDetailedWeatherListingXml + + +-- | (Un)pickle a 'WeatherDetailedWeatherXml' +-- +pickle_detailed_weather :: PU WeatherDetailedWeatherXml +pickle_detailed_weather = + xpElem "Detailed_Weather" $ + xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings) + (xpList pickle_dw_listing) + +-- | Pickler to convert a 'Message' to/from XML. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ - xp7Tuple + xpWrap (from_tuple, H.convert) $ + xp8Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "title" xpText) (xpList pickle_forecast) - (xpElem "time_stamp" xpText) + (xpOption pickle_detailed_weather) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple Message{..} = (xml_xml_file_id, - xml_heading, - xml_category, - xml_sport, - xml_title, - xml_forecasts, - xml_time_stamp) + -- --- Tasty tests +-- * Tasty tests -- - weather_tests :: TestTree weather_tests = testGroup "Weather tests" - [ test_pickle_of_unpickle_is_identity, - test_unpickle_succeeds ] + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, + test_unpickle_succeeds, + test_types_detected_correctly, + test_normal_teams_detected_correctly ] -- | If we unpickle something and then pickle it, we should wind up @@ -260,19 +659,111 @@ weather_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/weatherxml.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/weatherxml.xml", + + check "pickle composed with unpickle is the identity (detailed)" + "test/xml/weatherxml-detailed.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/weatherxml.xml" - actual <- unpickleable path pickle_message - let expected = True - actual @?= expected +test_unpickle_succeeds = testGroup "unpickle tests" + [ check "unpickling succeeds" + "test/xml/weatherxml.xml", + check "unpickling succeeds (detailed)" + "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 + let expected = True + actual @?= expected + + +-- | Make sure everything gets deleted when we delete the top-level +-- record. +-- +test_on_delete_cascade :: TestTree +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", + 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 + let a = undefined :: Weather + let b = undefined :: WeatherForecast + let c = undefined :: WeatherForecastListing + let d = undefined :: WeatherDetailedWeatherListingItem + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigrationSilent $ do + migrate a + migrate b + migrate c + migrate d + _ <- dbimport weather + deleteAll a + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + count_d <- countAll d + 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-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_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