src/TSN/XML/Weather.hs

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