+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# 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
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,
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 \<league\>
+-- 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 \<league\> 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 \<Detailed_Weather\>, which just contains
+-- a bunch iof \<DW_Listing\>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 \<DW_Listing\>. The sport and sport code
+-- come as attributes, but then these just contain a bunch of
+-- \<Item\>s. There is no associated database type since these don't
+-- contain much information. The sport we already know from the
+-- \<message\>, while the sport code is ignored since it's already
+-- present in each \<Item\>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,
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 \<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
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" $
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
-- 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
projects / dead / htsn-import.git / blobdiff