src/TSN/XML/Weather.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
   9 --   contains a bunch of forecasts, which each contain zero or more
  10 --   leagues, which in turn (each) contain a bunch of listings.
  11 --
  12 module TSN.XML.Weather (
  13   dtd,
  14   is_type1,
  15   pickle_message,
  16   teams_are_normal,
  17   -- * Tests
  18   weather_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   WeatherConstructor(..),
  21   WeatherDetailedWeatherListingItemConstructor(..),
  22   WeatherForecastConstructor(..),
  23   WeatherForecastListingConstructor(..) )
  24 where
  25
  26 -- System imports.
  27 import Control.Monad ( forM_ )
  28 import Data.Time ( UTCTime )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Database.Groundhog (
  31   countAll,
  32   deleteAll,
  33   insert_,
  34   migrate,
  35   runMigration,
  36   silentMigrationLogger )
  37 import Database.Groundhog.Core ( DefaultKey )
  38 import Database.Groundhog.Generic ( runDbConn )
  39 import Database.Groundhog.Sqlite ( withSqliteConn )
  40 import Database.Groundhog.TH (
  41   groundhog,
  42   mkPersist )
  43 import Test.Tasty ( TestTree, testGroup )
  44 import Test.Tasty.HUnit ( (@?=), testCase )
  45 import Text.XML.HXT.Core (
  46   PU,
  47   XmlTree,
  48   (/>),
  49   (>>>),
  50   addNav,
  51   descendantAxis,
  52   filterAxis,
  53   followingSiblingAxis,
  54   hasName,
  55   remNav,
  56   runLA,
  57   xp8Tuple,
  58   xp9Tuple,
  59   xpAttr,
  60   xpElem,
  61   xpInt,
  62   xpList,
  63   xpOption,
  64   xpPair,
  65   xpText,
  66   xpTriple,
  67   xpWrap )
  68
  69 -- Local imports.
  70 import TSN.Codegen (
  71   tsn_codegen_config )
  72 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  73 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
  74 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  75 import Xml (
  76   Child(..),
  77   FromXml(..),
  78   FromXmlFk(..),
  79   ToDb(..),
  80   pickle_unpickle,
  81   unpickleable,
  82   unsafe_read_document,
  83   unsafe_unpickle )
  84
  85
  86
  87 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  88 --
  89 dtd :: String
  90 dtd = "weatherxml.dtd"
  91
  92
  93 --
  94 -- DB/XML Data types
  95 --
  96
  97 -- * WeatherForecastListing/WeatherForecastListingXml
  98
  99 -- | XML representation of a weather forecast listing.
 100 --
 101 data WeatherForecastListingXml =
 102   WeatherForecastListingXml {
 103     xml_teams :: String,
 104     xml_weather :: Maybe String }
 105   deriving (Eq, Show)
 106
 107
 108 -- | Database representation of a weather forecast listing. The
 109 --   'db_league_name' field should come from the containing \<league\>
 110 --   element which is not stored in the database.
 111 --
 112 data WeatherForecastListing =
 113   WeatherForecastListing {
 114     db_weather_forecasts_id :: DefaultKey WeatherForecast,
 115     db_league_name :: Maybe String,
 116     db_teams :: String,
 117     db_weather :: Maybe String }
 118
 119
 120 -- | We don't make 'WeatherForecastListingXml' an instance of
 121 --   'FromXmlFk' because it needs some additional information, namely
 122 --   the league name from its containing \<league\> element.
 123 --
 124 --   When supplied with a forecast id and a league name, this will
 125 --   turn an XML listing into a database one.
 126 --
 127 from_xml_fk_league :: DefaultKey WeatherForecast
 128                    -> (Maybe String)
 129                    -> WeatherForecastListingXml
 130                    -> WeatherForecastListing
 131 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
 132     WeatherForecastListing {
 133       db_weather_forecasts_id = fk,
 134       db_league_name = ln,
 135       db_teams = xml_teams,
 136       db_weather = xml_weather }
 137
 138
 139 -- * WeatherLeague
 140
 141 -- | XML representation of a league, as they appear in the weather
 142 --   documents. There is no associated database representation because
 143 --   the league element really adds no information besides its own
 144 --   (usually empty) name. The leagues contain listings, so we
 145 --   associate the league name with each listing instead.
 146 --
 147 data WeatherLeague =
 148   WeatherLeague {
 149     league_name :: Maybe String,
 150     listings    :: [WeatherForecastListingXml] }
 151   deriving (Eq, Show)
 152
 153
 154 -- * WeatherForecast/WeatherForecastXml
 155
 156 -- | Database representation of a weather forecast.
 157 --
 158 data WeatherForecast =
 159   WeatherForecast {
 160     db_weather_id :: DefaultKey Weather,
 161     db_game_date :: UTCTime }
 162
 163
 164 -- | XML representation of a weather forecast.
 165 --
 166 data WeatherForecastXml =
 167   WeatherForecastXml {
 168     xml_game_date :: UTCTime,
 169     xml_leagues :: [WeatherLeague] }
 170   deriving (Eq, Show)
 171
 172
 173 instance ToDb WeatherForecastXml where
 174   -- | The database representation of a 'WeatherForecastXml' is a
 175   --   'WeatherForecast'.
 176   --
 177   type Db WeatherForecastXml = WeatherForecast
 178
 179
 180 instance Child WeatherForecastXml where
 181   -- | The database type containing a 'WeatherForecastXml' is
 182   --   'Weather'.
 183   type Parent WeatherForecastXml = Weather
 184
 185
 186 instance FromXmlFk WeatherForecastXml where
 187
 188   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
 189   --   add the foreign key to the containing 'Weather', and copy the
 190   --   game date.
 191   --
 192   from_xml_fk fk WeatherForecastXml{..} =
 193     WeatherForecast {
 194       db_weather_id  = fk,
 195       db_game_date   = xml_game_date }
 196
 197
 198 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 199 --   without first converting it to the database representation.
 200 --
 201 instance XmlImportFk WeatherForecastXml
 202
 203 -- * WeatherDetailedWeatherXml
 204
 205 -- | XML Representation of a \<Detailed_Weather\>, which just contains
 206 --   a bunch iof \<DW_Listing\>s. There is no associated database type
 207 --   since these don't really contain any information.
 208 --
 209 data WeatherDetailedWeatherXml =
 210   WeatherDetailedWeatherXml {
 211     xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
 212   deriving (Eq, Show)
 213
 214
 215 -- * WeatherDetailedWeatherXml
 216
 217 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
 218 --   come as attributes, but then these just contain a bunch of
 219 --   \<Item\>s. There is no associated database type since these don't
 220 --   contain much information. The sport we already know from the
 221 --   \<message\>, while the sport code is ignored since it's already
 222 --   present in each \<Item\>s.
 223 --
 224 data WeatherDetailedWeatherListingXml =
 225   WeatherDetailedWeatherListingXml {
 226     xml_dtl_listing_sport :: String,
 227     xml_dtl_listing_sport_code :: String,
 228     xml_items :: [WeatherDetailedWeatherListingItemXml] }
 229   deriving (Eq, Show)
 230
 231 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
 232
 233 -- | Database representation of a detailed weather item. The away/home
 234 --   teams don't use the representation in "TSN.Team" because all
 235 --   we're given is a name, and a team id is required for "TSN.Team".
 236 --
 237 --   We also drop the sport name, because it's given in the parent
 238 --   'Weather'.
 239 --
 240 data WeatherDetailedWeatherListingItem =
 241   WeatherDetailedWeatherListingItem {
 242     db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
 243                                              --   using \"dtl\" prefix.
 244     db_sport_code :: String,
 245     db_game_id :: Int,
 246     db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
 247     db_away_team :: String,
 248     db_home_team :: String,
 249     db_weather_type :: Int,
 250     db_description :: Maybe String,
 251     db_temp_adjust :: Maybe String,
 252     db_temperature :: Int }
 253
 254
 255 -- | XML representation of a detailed weather item. Same as the
 256 --   database representation, only without the foreign key and the
 257 --   sport name that comes from the containing listing.
 258 data WeatherDetailedWeatherListingItemXml =
 259   WeatherDetailedWeatherListingItemXml {
 260     xml_sport_code :: String,
 261     xml_game_id :: Int,
 262     xml_dtl_game_date :: UTCTime,
 263     xml_away_team :: String,
 264     xml_home_team :: String,
 265     xml_weather_type :: Int,
 266     xml_description :: Maybe String,
 267     xml_temp_adjust :: Maybe String,
 268     xml_temperature :: Int }
 269   deriving (Eq, Show)
 270
 271
 272 instance ToDb WeatherDetailedWeatherListingItemXml where
 273   -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
 274   type Db WeatherDetailedWeatherListingItemXml =
 275     WeatherDetailedWeatherListingItem
 276
 277 instance Child WeatherDetailedWeatherListingItemXml where
 278   -- | We skip two levels of containers and say that the items belong
 279   --   to the top-level 'Weather'.
 280   type Parent WeatherDetailedWeatherListingItemXml = Weather
 281
 282 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
 283   -- | To convert from the XML to database representation, we simply
 284   --   add the foreign key (to Weather) and copy the rest of the fields.
 285   from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
 286     WeatherDetailedWeatherListingItem {
 287       db_dtl_weather_id = fk,
 288       db_sport_code = xml_sport_code,
 289       db_game_id = xml_game_id,
 290       db_dtl_game_date = xml_dtl_game_date,
 291       db_away_team = xml_away_team,
 292       db_home_team = xml_home_team,
 293       db_weather_type = xml_weather_type,
 294       db_description = xml_description,
 295       db_temp_adjust = xml_temp_adjust,
 296       db_temperature = xml_temperature }
 297
 298 -- | This allows us to insert the XML representation directly without
 299 --   having to do the manual XML -\> DB conversion.
 300 --
 301 instance XmlImportFk WeatherDetailedWeatherListingItemXml
 302
 303 -- * Weather/Message
 304
 305 -- | The database representation of a weather message. We don't
 306 -- contain the forecasts or the detailed weather since those are
 307 -- foreigned-keyed to us.
 308 --
 309 data Weather =
 310   Weather {
 311     db_xml_file_id :: Int,
 312     db_sport :: String,
 313     db_title :: String,
 314     db_time_stamp :: UTCTime }
 315
 316
 317 -- | The XML representation of a weather message.
 318 --
 319 data Message =
 320   Message {
 321     xml_xml_file_id :: Int,
 322     xml_heading :: String,
 323     xml_category :: String,
 324     xml_sport :: String,
 325     xml_title :: String,
 326     xml_forecasts :: [WeatherForecastXml],
 327     xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
 328     xml_time_stamp :: UTCTime }
 329   deriving (Eq, Show)
 330
 331 instance ToDb Message where
 332   -- | The database representation of 'Message' is 'Weather'.
 333   --
 334   type Db Message = Weather
 335
 336 instance FromXml Message where
 337   -- | To get a 'Weather' from a 'Message', we drop a bunch of
 338   --   unwanted fields.
 339   --
 340   from_xml Message{..} =
 341     Weather {
 342       db_xml_file_id = xml_xml_file_id,
 343       db_sport = xml_sport,
 344       db_title = xml_title,
 345       db_time_stamp = xml_time_stamp }
 346
 347 -- | This allows us to insert the XML representation 'Message'
 348 --   directly.
 349 --
 350 instance XmlImport Message
 351
 352
 353 --
 354 -- * Database stuff
 355 --
 356
 357 mkPersist tsn_codegen_config [groundhog|
 358 - entity: Weather
 359   constructors:
 360     - name: Weather
 361       uniques:
 362         - name: unique_weather
 363           type: constraint
 364           # Prevent multiple imports of the same message.
 365           fields: [db_xml_file_id]
 366
 367 - entity: WeatherForecast
 368   dbName: weather_forecasts
 369   constructors:
 370     - name: WeatherForecast
 371       fields:
 372         - name: db_weather_id
 373           reference:
 374             onDelete: cascade
 375
 376 - entity: WeatherForecastListing
 377   dbName: weather_forecast_listings
 378   constructors:
 379     - name: WeatherForecastListing
 380       fields:
 381         - name: db_weather_forecasts_id
 382           reference:
 383             onDelete: cascade
 384
 385   # We rename the two fields that needed a "dtl" prefix to avoid a name
 386   # clash.
 387 - entity: WeatherDetailedWeatherListingItem
 388   dbName: weather_detailed_items
 389   constructors:
 390     - name: WeatherDetailedWeatherListingItem
 391       fields:
 392         - name: db_dtl_weather_id
 393           dbName: weather_id
 394           reference:
 395             onDelete: cascade
 396         - name: db_dtl_game_date
 397           dbName: game_date
 398
 399 |]
 400
 401
 402
 403 -- | There are two different types of documents that claim to be
 404 --   \"weatherxml.dtd\". The first, more common type has listings
 405 --   within forecasts. The second type has forecasts within
 406 --   listings. Clearly we can't parse both of these using the same
 407 --   parser!
 408 --
 409 --   For now we're simply punting on the issue and refusing to parse
 410 --   the second type. This will check the given @xmltree@ to see if
 411 --   there are any forecasts contained within listings. If there are,
 412 --   then it's the second type that we don't know what to do with.
 413 --
 414 is_type1 :: XmlTree -> Bool
 415 is_type1 xmltree =
 416   case elements of
 417     [] -> True
 418     _  -> False
 419   where
 420     parse :: XmlTree -> [XmlTree]
 421     parse = runLA $  hasName "/"
 422                   /> hasName "message"
 423                   /> hasName "listing"
 424                   /> hasName "forecast"
 425
 426     elements = parse xmltree
 427
 428
 429 -- | Some weatherxml documents even have the Home/Away teams in the
 430 --   wrong order. We can't parse that! This next bit of voodoo detects
 431 --   whether or not there are any \<HomeTeam\> elements that are
 432 --   directly followed by sibling \<AwayTeam\> elements. This is the
 433 --   opposite of the usual order.
 434 --
 435 teams_are_normal :: XmlTree -> Bool
 436 teams_are_normal xmltree =
 437   case elements of
 438     [] -> True
 439     _  -> False
 440   where
 441     parse :: XmlTree -> [XmlTree]
 442     parse = runLA $  hasName "/"
 443                   /> hasName "message"
 444                   /> hasName "Detailed_Weather"
 445                   /> hasName "DW_Listing"
 446                   /> hasName "Item"
 447                   >>> addNav
 448                   >>> descendantAxis
 449                   >>> filterAxis (hasName "HomeTeam")
 450                   >>> followingSiblingAxis
 451                   >>> remNav
 452                   >>> hasName "AwayTeam"
 453
 454     elements = parse xmltree
 455
 456
 457 instance DbImport Message where
 458   dbmigrate _ =
 459     run_dbmigrate $ do
 460       migrate (undefined :: Weather)
 461       migrate (undefined :: WeatherForecast)
 462       migrate (undefined :: WeatherForecastListing)
 463       migrate (undefined :: WeatherDetailedWeatherListingItem)
 464
 465   dbimport m = do
 466     -- First we insert the top-level weather record.
 467     weather_id <- insert_xml m
 468
 469     -- Next insert all of the forecasts, one at a time.
 470     forM_ (xml_forecasts m) $ \forecast -> do
 471       forecast_id <- insert_xml_fk weather_id forecast
 472
 473       -- With the forecast id in hand, loop through this forecast's
 474       -- leagues...
 475       forM_ (xml_leagues forecast) $ \league -> do
 476         -- Construct the function that converts an XML listing to a
 477         -- database one.
 478         let todb = from_xml_fk_league forecast_id (league_name league)
 479
 480         -- Now use it to convert all of the XML listings.
 481         let db_listings = map todb (listings league)
 482
 483         -- And finally, insert those DB listings.
 484         mapM_ insert_ db_listings
 485
 486     -- Now we do the detailed weather items.
 487     case (xml_detailed_weather m) of
 488       Nothing -> return ()
 489       Just dw -> do
 490         let detailed_listings = xml_detailed_listings dw
 491         let items = concatMap xml_items detailed_listings
 492         mapM_ (insert_xml_fk_ weather_id) items
 493
 494     return ImportSucceeded
 495
 496
 497 --
 498 -- * Pickling
 499 --
 500
 501 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 502 --
 503 pickle_listing :: PU WeatherForecastListingXml
 504 pickle_listing =
 505   xpElem "listing" $
 506     xpWrap (from_pair, to_pair) $
 507       xpPair
 508         (xpElem "teams" xpText)
 509         (xpElem "weather" (xpOption xpText))
 510   where
 511 --    from_pair (ts, Nothing) = WeatherForecastListingXml ts (Just "")
 512     from_pair = uncurry WeatherForecastListingXml
 513     to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 514
 515
 516 -- | Pickler to convert a 'WeatherLeague' to/from XML.
 517 --
 518 pickle_league :: PU WeatherLeague
 519 pickle_league =
 520   xpElem "league" $
 521     xpWrap (from_pair, to_pair) $
 522       xpPair
 523         (xpAttr "name" $ xpOption xpText)
 524         (xpList pickle_listing)
 525   where
 526     from_pair = uncurry WeatherLeague
 527     to_pair WeatherLeague{..} = (league_name, listings)
 528
 529
 530 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
 531 --
 532 pickle_forecast :: PU WeatherForecastXml
 533 pickle_forecast =
 534   xpElem "forecast" $
 535     xpWrap (from_pair, to_pair) $
 536       xpPair
 537         (xpAttr "gamedate" xp_gamedate)
 538         (xpList pickle_league)
 539   where
 540     from_pair = uncurry WeatherForecastXml
 541     to_pair WeatherForecastXml{..} = (xml_game_date,
 542                                       xml_leagues)
 543
 544
 545
 546 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
 547 --
 548 pickle_item :: PU WeatherDetailedWeatherListingItemXml
 549 pickle_item =
 550   xpElem "Item" $
 551     xpWrap (from_tuple, to_tuple) $
 552     xp9Tuple (xpElem "Sportcode" xpText)
 553              (xpElem "GameID" xpInt)
 554              (xpElem "Gamedate" xp_datetime)
 555              (xpElem "AwayTeam" xpText)
 556              (xpElem "HomeTeam" xpText)
 557              (xpElem "WeatherType" xpInt)
 558              (xpElem "Description" (xpOption xpText))
 559              (xpElem "TempAdjust" (xpOption xpText))
 560              (xpElem "Temperature" xpInt)
 561   where
 562     from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
 563     to_tuple w = (xml_sport_code w,
 564                   xml_game_id w,
 565                   xml_dtl_game_date w,
 566                   xml_away_team w,
 567                   xml_home_team w,
 568                   xml_weather_type w,
 569                   xml_description w,
 570                   xml_temp_adjust w,
 571                   xml_temperature w)
 572
 573
 574 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
 575 --
 576 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
 577 pickle_dw_listing =
 578   xpElem "DW_Listing" $
 579     xpWrap (from_tuple, to_tuple) $
 580     xpTriple (xpAttr "SportCode" xpText)
 581              (xpAttr "Sport" xpText)
 582              (xpList pickle_item)
 583   where
 584     from_tuple = uncurryN WeatherDetailedWeatherListingXml
 585     to_tuple w = (xml_dtl_listing_sport w,
 586                   xml_dtl_listing_sport_code w,
 587                   xml_items w)
 588
 589
 590 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
 591 --
 592 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
 593 pickle_detailed_weather =
 594   xpElem "Detailed_Weather" $
 595     xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
 596     (xpList pickle_dw_listing)
 597
 598
 599 -- | Pickler to convert a 'Message' to/from XML.
 600 --
 601 pickle_message :: PU Message
 602 pickle_message =
 603   xpElem "message" $
 604     xpWrap (from_tuple, to_tuple) $
 605       xp8Tuple
 606         (xpElem "XML_File_ID" xpInt)
 607         (xpElem "heading" xpText)
 608         (xpElem "category" xpText)
 609         (xpElem "sport" xpText)
 610         (xpElem "title" xpText)
 611         (xpList pickle_forecast)
 612         (xpOption pickle_detailed_weather)
 613         (xpElem "time_stamp" xp_time_stamp)
 614   where
 615     from_tuple = uncurryN Message
 616     to_tuple Message{..} = (xml_xml_file_id,
 617                             xml_heading,
 618                             xml_category,
 619                             xml_sport,
 620                             xml_title,
 621                             xml_forecasts,
 622                             xml_detailed_weather,
 623                             xml_time_stamp)
 624
 625
 626 --
 627 -- * Tasty tests
 628 --
 629 weather_tests :: TestTree
 630 weather_tests =
 631   testGroup
 632     "Weather tests"
 633     [ test_on_delete_cascade,
 634       test_pickle_of_unpickle_is_identity,
 635       test_unpickle_succeeds,
 636       test_types_detected_correctly,
 637       test_normal_teams_detected_correctly ]
 638
 639
 640 -- | If we unpickle something and then pickle it, we should wind up
 641 --   with the same thing we started with. WARNING: success of this
 642 --   test does not mean that unpickling succeeded.
 643 --
 644 test_pickle_of_unpickle_is_identity :: TestTree
 645 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 646   [ check "pickle composed with unpickle is the identity"
 647           "test/xml/weatherxml.xml",
 648
 649     check "pickle composed with unpickle is the identity (detailed)"
 650           "test/xml/weatherxml-detailed.xml" ]
 651   where
 652     check desc path = testCase desc $ do
 653       (expected, actual) <- pickle_unpickle pickle_message path
 654       actual @?= expected
 655
 656
 657 -- | Make sure we can actually unpickle these things.
 658 --
 659 test_unpickle_succeeds :: TestTree
 660 test_unpickle_succeeds = testGroup "unpickle tests"
 661   [ check "unpickling succeeds"
 662           "test/xml/weatherxml.xml",
 663     check "unpickling succeeds (detailed)"
 664           "test/xml/weatherxml-detailed.xml",
 665     check "unpickling succeeds (empty weather)"
 666           "test/xml/weatherxml-empty-weather.xml"]
 667   where
 668     check desc path = testCase desc $ do
 669       actual <- unpickleable path pickle_message
 670       let expected = True
 671       actual @?= expected
 672
 673
 674 -- | Make sure everything gets deleted when we delete the top-level
 675 --   record.
 676 --
 677 test_on_delete_cascade :: TestTree
 678 test_on_delete_cascade = testGroup "cascading delete tests"
 679   [ check "deleting weather deletes its children"
 680           "test/xml/weatherxml.xml",
 681     check "deleting weather deletes its children (detailed)"
 682           "test/xml/weatherxml-detailed.xml",
 683     check "deleting weather deletes its children (empty weather)"
 684           "test/xml/weatherxml-empty-weather.xml"]
 685   where
 686     check desc path = testCase desc $ do
 687       weather <- unsafe_unpickle path pickle_message
 688       let a = undefined :: Weather
 689       let b = undefined :: WeatherForecast
 690       let c = undefined :: WeatherForecastListing
 691       let d = undefined :: WeatherDetailedWeatherListingItem
 692       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 693                   runMigration silentMigrationLogger $ do
 694                     migrate a
 695                     migrate b
 696                     migrate c
 697                     migrate d
 698                   _ <- dbimport weather
 699                   deleteAll a
 700                   count_a <- countAll a
 701                   count_b <- countAll b
 702                   count_c <- countAll c
 703                   count_d <- countAll d
 704                   return $ count_a + count_b + count_c + count_d
 705       let expected = 0
 706       actual @?= expected
 707
 708
 709 -- | We want to make sure type1 documents are detected as type1, and
 710 --   type2 documents detected as type2..
 711 --
 712 test_types_detected_correctly :: TestTree
 713 test_types_detected_correctly =
 714   testGroup "weatherxml types detected correctly"
 715     [ check "test/xml/weatherxml.xml"
 716             "first type detected correctly"
 717             True,
 718       check "test/xml/weatherxml-detailed.xml"
 719             "first type detected correctly (detailed)"
 720             True,
 721       check "test/xml/weatherxml-empty-weather.xml"
 722             "first type detected correctly (empty weather)"
 723             True,
 724       check "test/xml/weatherxml-type2.xml"
 725             "second type detected correctly"
 726             False ]
 727   where
 728     check path desc expected = testCase desc $ do
 729       xmltree <- unsafe_read_document path
 730       let actual = is_type1 xmltree
 731       actual @?= expected
 732
 733
 734 -- | We want to make sure normal teams are detected as normal, and the
 735 --   backwards ones are flagged as backwards.
 736 --
 737 test_normal_teams_detected_correctly :: TestTree
 738 test_normal_teams_detected_correctly =
 739   testGroup "team order is detected correctly" [
 740
 741     check "normal teams are detected correctly"
 742           "test/xml/weatherxml.xml"
 743           True,
 744
 745     check "backwards teams are detected correctly"
 746           "test/xml/weatherxml-backwards-teams.xml"
 747           False ]
 748   where
 749     check desc path expected = testCase desc $ do
 750       xmltree <- unsafe_read_document path
 751       let actual = teams_are_normal xmltree
 752       actual @?= expected