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