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