src/TSN/XML/Odds.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
  11 --   a root element \<message\> that contains a bunch of other
  12 --   unorganized crap.
  13 --
  14 module TSN.XML.Odds (
  15   pickle_message,
  16   -- * Tests
  17   odds_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   OddsCasinoConstructor(..),
  20   OddsConstructor(..),
  21   OddsGame_OddsGameTeamConstructor(..),
  22   OddsGameConstructor(..),
  23   OddsGameLineConstructor(..),
  24   OddsGameTeamConstructor(..) )
  25 where
  26
  27 -- System imports.
  28 import Control.Monad ( forM_, join )
  29 import Data.Time ( UTCTime(..) )
  30 import Data.Tuple.Curry ( uncurryN )
  31 import Database.Groundhog (
  32   (=.),
  33   (==.),
  34   insert_,
  35   migrate,
  36   update )
  37 import Database.Groundhog.Core ( DefaultKey )
  38 import Database.Groundhog.TH (
  39   groundhog,
  40   mkPersist )
  41 import Test.Tasty ( TestTree, testGroup )
  42 import Test.Tasty.HUnit ( (@?=), testCase )
  43 import Text.Read ( readMaybe )
  44 import Text.XML.HXT.Core (
  45   PU,
  46   xp5Tuple,
  47   xp6Tuple,
  48   xp8Tuple,
  49   xpAttr,
  50   xpElem,
  51   xpInt,
  52   xpList,
  53   xpOption,
  54   xpPair,
  55   xpText,
  56   xpTriple,
  57   xpWrap )
  58
  59 -- Local imports.
  60 import TSN.Codegen (
  61   tsn_codegen_config )
  62 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  63 import TSN.Picklers ( xp_date, xp_time, xp_time_stamp )
  64 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  65 import Xml (
  66   FromXml(..),
  67   FromXmlFk(..),
  68   ToDb(..),
  69   pickle_unpickle,
  70   unpickleable )
  71
  72
  73 --
  74 -- DB/XML data types
  75 --
  76
  77 -- * OddsGameCasino/OddsGameCasinoXml
  78
  79
  80 -- | The casinos should have their own table, but the lines don't
  81 --   belong in that table (there should be another table joining the
  82 --   casinos and the thing the lines are for together.)
  83 --
  84 --   We drop the 'Game' prefix because the Casinos really aren't
  85 --   children of the games; the XML just makes it seem that way.
  86 --
  87 data OddsCasino =
  88   OddsCasino {
  89     casino_client_id :: Int,
  90     casino_name :: String }
  91   deriving (Eq, Show)
  92
  93
  94 -- | The home/away lines are 'Double's, but the over/under lines are
  95 --   textual. If we want to use one data type for both, we have to go
  96 --   with a 'String' and then attempt to 'read' a 'Double' later when we
  97 --   go to insert the thing.
  98 --
  99 data OddsGameCasinoXml =
 100   OddsGameCasinoXml {
 101     xml_casino_client_id :: Int,
 102     xml_casino_name      :: String,
 103     xml_casino_line      :: Maybe String }
 104   deriving (Eq, Show)
 105
 106
 107 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
 108 --   priori textual (because it might be an over/under line).
 109 --
 110 home_away_line :: OddsGameCasinoXml -> Maybe Double
 111 home_away_line = join . (fmap readMaybe) . xml_casino_line
 112
 113
 114
 115 instance ToDb OddsGameCasinoXml where
 116   -- | The database representation of an 'OddsGameCasinoXml' is an
 117   --   'OddsCasino'.
 118   --
 119   type Db OddsGameCasinoXml = OddsCasino
 120
 121
 122 instance FromXml OddsGameCasinoXml where
 123   -- | We convert from XML to the database by dropping the line field.
 124   from_xml OddsGameCasinoXml{..} =
 125     OddsCasino {
 126       casino_client_id = xml_casino_client_id,
 127       casino_name      = xml_casino_name }
 128
 129
 130 -- | This allows us to call 'insert_xml' on an 'OddsGameCasinoXml'
 131 --   without first converting it to the database representation.
 132 instance XmlImport OddsGameCasinoXml
 133
 134
 135 -- * OddsGameTeam
 136
 137
 138 -- | The database representation of teams as they appear in odds
 139 --   games.
 140 --
 141 data OddsGameTeam =
 142   OddsGameTeam {
 143     db_team_id         :: String, -- ^ The home/away team IDs are
 144                                   --   three characters but Postgres
 145                                   --   imposes no performance penalty
 146                                   --   on lengthless text fields, so
 147                                   --   we ignore the probable upper
 148                                   --   bound of three characters.
 149     db_abbr            :: String,
 150     db_team_name       :: String }
 151   deriving (Eq, Show)
 152
 153
 154 -- * OddsGameHomeTeam/OddsGameHomeTeamXml
 155
 156 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
 157 --
 158 data OddsGameHomeTeamXml =
 159   OddsGameHomeTeamXml {
 160     xml_home_team_id         :: String, -- ^ The home/away team IDs
 161                                         --   are three characters but
 162                                         --   Postgres imposes no
 163                                         --   performance penalty on
 164                                         --   lengthless text fields,
 165                                         --   so we ignore the probable
 166                                         --   upper bound of three
 167                                         --   characters.
 168     xml_home_rotation_number :: Int,
 169     xml_home_abbr            :: String,
 170     xml_home_team_name       :: String,
 171     xml_home_casinos         :: [OddsGameCasinoXml] }
 172   deriving (Eq, Show)
 173
 174 instance ToDb OddsGameHomeTeamXml where
 175   -- | The database representation of an 'OddsGameHomeTeamXml' is an
 176   --   'OddsGameTeam'.
 177   --
 178   type Db OddsGameHomeTeamXml = OddsGameTeam
 179
 180 instance FromXml OddsGameHomeTeamXml where
 181   -- | We convert from XML to the database by dropping the lines and
 182   --   rotation number (which are specific to the games, not the teams
 183   --   themselves).
 184   --
 185   from_xml OddsGameHomeTeamXml{..} =
 186     OddsGameTeam {
 187       db_team_id   = xml_home_team_id,
 188       db_abbr      = xml_home_abbr,
 189       db_team_name = xml_home_team_name }
 190
 191 -- | XmlImport allows us to call 'insert_xml' directly on an
 192 --   'OddsGameHomeTeamXml' without explicitly converting it to the
 193 --   associated database type.
 194 --
 195 instance XmlImport OddsGameHomeTeamXml where
 196
 197
 198 -- * OddsGameAwayTeam/OddsGameAwayTeamXml
 199
 200 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
 201 --
 202 data OddsGameAwayTeamXml =
 203   OddsGameAwayTeamXml {
 204     xml_away_team_id         :: String, -- ^ The home/away team IDs are
 205                                         --   three characters but Postgres
 206                                         --   imposes no performance penalty
 207                                         --   on lengthless text fields, so
 208                                         --   we ignore the probable upper
 209                                         --   bound of three characters
 210     xml_away_rotation_number :: Int,
 211     xml_away_abbr            :: String,
 212     xml_away_team_name       :: String,
 213     xml_away_casinos         :: [OddsGameCasinoXml] }
 214   deriving (Eq, Show)
 215
 216 instance ToDb OddsGameAwayTeamXml where
 217   -- | The database representation of an 'OddsGameAwayTeamXml' is an
 218   --   'OddsGameTeam'.
 219   --
 220   type Db OddsGameAwayTeamXml = OddsGameTeam
 221
 222 instance FromXml OddsGameAwayTeamXml where
 223   -- | We convert from XML to the database by dropping the lines and
 224   --   rotation number (which are specific to the games, not the teams
 225   --   themselves).
 226   --
 227   from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
 228                                        xml_away_team_id
 229                                        xml_away_abbr
 230                                        xml_away_team_name
 231
 232 -- | XmlImport allows us to call 'insert_xml' directly on an
 233 --   'OddsGameAwayTeamXml' without explicitly converting it to the
 234 --   associated database type.
 235 --
 236 instance XmlImport OddsGameAwayTeamXml where
 237
 238
 239 -- * OddsGame_OddsGameTeam
 240
 241 -- | Database mapping between games and their home/away teams.
 242 data OddsGame_OddsGameTeam =
 243   OddsGame_OddsGameTeam {
 244     ogogt_odds_games_id :: DefaultKey OddsGame,
 245     ogogt_away_team_id  :: DefaultKey OddsGameTeam,
 246     ogogt_home_team_id  :: DefaultKey OddsGameTeam }
 247
 248
 249 -- * OddsGameOverUnderXml
 250
 251 -- | XML representation of the over/under. A wrapper around a bunch of
 252 --   casino elements.
 253 --
 254 newtype OddsGameOverUnderXml =
 255   OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
 256   deriving (Eq, Show)
 257
 258
 259 -- * OddsGameLine
 260
 261 -- | This database representation of the casino lines can't be
 262 --   constructed from the one in the XML. The casinos within
 263 --   Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
 264 --   less the same. We don't need a bajillion different tables to
 265 --   store that, just one tying the casino/game pair to the three
 266 --   lines.
 267 --
 268 --   The one small difference between the over/under casinos and the
 269 --   home/away ones is that the home/away lines are all 'Double's, but
 270 --   the over/under lines appear to be textual.
 271 --
 272 data OddsGameLine =
 273   OddsGameLine {
 274     ogl_odds_games_id   :: DefaultKey OddsGame,
 275     ogl_odds_casinos_id :: DefaultKey OddsCasino,
 276     ogl_over_under      :: Maybe String,
 277     ogl_away_line       :: Maybe Double,
 278     ogl_home_line       :: Maybe Double }
 279
 280
 281 -- * OddsGame/OddsGameXml
 282
 283 -- | Database representation of a game. We retain the rotation number
 284 --   of the home/away teams, since those are specific to the game and
 285 --   not the teams.
 286 --
 287 data OddsGame =
 288   OddsGame {
 289     db_odds_id           :: DefaultKey Odds,
 290     db_game_id           :: Int,
 291     db_game_time         :: UTCTime, -- ^ Contains both the date and time.
 292     db_game_away_team_rotation_number :: Int,
 293     db_game_home_team_rotation_number :: Int }
 294
 295
 296 -- | XML representation of a game.
 297 --
 298 data OddsGameXml =
 299   OddsGameXml {
 300     xml_game_id         :: Int,
 301     xml_game_date       :: UTCTime, -- ^ Contains only the date
 302     xml_game_time       :: UTCTime, -- ^ Contains only the time
 303     xml_game_away_team  :: OddsGameAwayTeamXml,
 304     xml_game_home_team  :: OddsGameHomeTeamXml,
 305     xml_game_over_under :: OddsGameOverUnderXml }
 306   deriving (Eq, Show)
 307
 308 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
 309 --   xml_game_over_under.
 310 --
 311 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
 312 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
 313
 314
 315 instance ToDb OddsGameXml where
 316   -- | The database representation of an 'OddsGameXml' is an
 317   --   'OddsGame'.
 318   --
 319   type Db OddsGameXml = OddsGame
 320
 321 instance FromXmlFk OddsGameXml where
 322   type Parent OddsGameXml = Odds
 323
 324   -- | To convert from the XML representation to the database one, we
 325   --   drop the home/away teams and the casino lines, but retain the
 326   --   home/away rotation numbers.
 327   --
 328   from_xml_fk fk OddsGameXml{..} =
 329     OddsGame {
 330       db_odds_id   = fk,
 331       db_game_id   = xml_game_id,
 332
 333       db_game_time = UTCTime
 334                        (utctDay xml_game_date) -- Take the day part from one,
 335                        (utctDayTime xml_game_time), -- the time from the other.
 336
 337       db_game_away_team_rotation_number =
 338         (xml_away_rotation_number xml_game_away_team),
 339
 340       db_game_home_team_rotation_number =
 341         (xml_home_rotation_number xml_game_home_team) }
 342
 343 -- | This lets us call 'insert_xml_fk' directly on an 'OddsGameXml'
 344 --   without converting it to the database representation explicitly.
 345 --
 346 instance XmlImportFk OddsGameXml
 347
 348
 349 -- * OddsGameWithNotes
 350
 351 -- | This is our best guess at what occurs in the Odds_XML
 352 --   documents. It looks like each consecutive set of games can
 353 --   optionally have some notes appear before it. Each "note" comes as
 354 --   its own <Notes>...</Notes> element.
 355 --
 356 --   The notes are ignored completely in the database; we only bother
 357 --   with them to ensure that we're (un)pickling correctly.
 358 --
 359 --   We can't group the notes with a "set" of 'OddsGame's, because that
 360 --   leads to ambiguity in parsing. Since we're going to ignore the
 361 --   notes anyway, we just stick them with an arbitrary game. C'est la
 362 --   vie.
 363 --
 364 data OddsGameWithNotes =
 365   OddsGameWithNotes {
 366     notes :: [String],
 367     game :: OddsGameXml }
 368   deriving (Eq, Show)
 369
 370
 371 -- * Odds/Message
 372
 373 -- | Database and representation of the top-level Odds object (a
 374 --   'Message').
 375 data Odds =
 376   Odds {
 377     db_xml_file_id :: Int,
 378     db_sport :: String,
 379     db_title :: String,
 380     db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
 381                             --   because their timezones are ambiguous
 382                             --   (and the date is less than useful when
 383                             --   it might be off by an hour).
 384     db_time_stamp :: UTCTime }
 385
 386
 387 -- | The XML representation of 'Odds'.
 388 data Message =
 389   Message {
 390     xml_xml_file_id :: Int,
 391     xml_heading :: String,
 392     xml_category :: String,
 393     xml_sport :: String,
 394     xml_title :: String,
 395     xml_line_time :: String,
 396     xml_games_with_notes :: [OddsGameWithNotes],
 397     xml_time_stamp :: UTCTime }
 398   deriving (Eq, Show)
 399
 400 -- | Pseudo-field that lets us get the 'OddsGame's out of
 401 --   'xml_games_with_notes'.
 402 --
 403 xml_games :: Message -> [OddsGameXml]
 404 xml_games m = map game (xml_games_with_notes m)
 405
 406
 407 instance ToDb Message where
 408   -- | The database representation of a 'Message' is 'Odds'.
 409   --
 410   type Db Message = Odds
 411
 412 instance FromXml Message where
 413   -- | To convert from the XML representation to the database one, we
 414   --   just drop a bunch of fields.
 415   --
 416   from_xml Message{..} =
 417     Odds {
 418       db_xml_file_id = xml_xml_file_id,
 419       db_sport = xml_sport,
 420       db_title = xml_title,
 421       db_line_time = xml_line_time,
 422       db_time_stamp = xml_time_stamp }
 423
 424 -- | This lets us call 'insert_xml' on a Message directly, without
 425 --   having to convert it to its database representation explicitly.
 426 --
 427 instance XmlImport Message
 428
 429
 430 --
 431 -- Database code
 432 --
 433
 434 -- Groundhog database schema. This must come before the DbImport
 435 -- instance definition. Don't know why.
 436 mkPersist tsn_codegen_config [groundhog|
 437 - entity: Odds
 438   constructors:
 439     - name: Odds
 440       uniques:
 441         - name: unique_odds
 442           type: constraint
 443           # Prevent multiple imports of the same message.
 444           fields: [db_xml_file_id]
 445
 446 - entity: OddsCasino
 447   dbName: odds_casinos
 448   constructors:
 449     - name: OddsCasino
 450       uniques:
 451         - name: unique_odds_casino
 452           type: constraint
 453           fields: [casino_client_id]
 454
 455 - entity: OddsGameTeam
 456   dbName: odds_games_teams
 457   constructors:
 458     - name: OddsGameTeam
 459       uniques:
 460         - name: unique_odds_games_team
 461           type: constraint
 462           fields: [db_team_id]
 463
 464
 465 - entity: OddsGame
 466   dbName: odds_games
 467   constructors:
 468     - name: OddsGame
 469       fields:
 470         - name: db_odds_id
 471           reference:
 472             onDelete: cascade
 473
 474 - entity: OddsGameLine
 475   dbName: odds_games_lines
 476   constructors:
 477     - name: OddsGameLine
 478       fields:
 479         - name: ogl_odds_games_id
 480           references:
 481             onDelete: cascade
 482         - name: ogl_odds_casinos_id
 483           references:
 484             onDelete: cascade
 485
 486 - entity: OddsGame_OddsGameTeam
 487   dbName: odds_games__odds_games_teams
 488   constructors:
 489     - name: OddsGame_OddsGameTeam
 490       fields:
 491         - name: ogogt_odds_games_id
 492           reference:
 493             onDelete: cascade
 494         - name: ogogt_away_team_id
 495           reference:
 496             onDelete: cascade
 497         - name: ogogt_home_team_id
 498           reference:
 499             onDelete: cascade
 500 |]
 501
 502 instance DbImport Message where
 503   dbmigrate _=
 504     run_dbmigrate $ do
 505       migrate (undefined :: Odds)
 506       migrate (undefined :: OddsCasino)
 507       migrate (undefined :: OddsGameTeam)
 508       migrate (undefined :: OddsGame)
 509       migrate (undefined :: OddsGame_OddsGameTeam)
 510       migrate (undefined :: OddsGameLine)
 511
 512   dbimport m = do
 513     -- Insert the root "odds" element and acquire its primary key (id).
 514     odds_id <- insert_xml m
 515
 516     forM_ (xml_games m) $ \g -> do
 517       -- Next, we insert the home and away teams. We do this before
 518       -- inserting the game itself because the game has two foreign keys
 519       -- pointing to odds_games_teams.
 520       -- Next to insert the home and away teams.
 521       away_team_id <- insert_xml_or_select (xml_game_away_team g)
 522       home_team_id <- insert_xml_or_select (xml_game_home_team g)
 523
 524       -- Now insert the game, keyed to the "odds",
 525       game_id <- insert_xml_fk odds_id g
 526
 527       -- Insert a record into odds_games__odds_games_teams mapping the
 528       -- home/away teams to this game. Use the full record syntax
 529       -- because the types would let us mix up the home/away teams.
 530       insert_ OddsGame_OddsGameTeam {
 531                 ogogt_odds_games_id = game_id,
 532                 ogogt_away_team_id = away_team_id,
 533                 ogogt_home_team_id = home_team_id }
 534
 535       -- Finaly, we insert the lines. The over/under entries for this
 536       -- game and the lines for the casinos all wind up in the same
 537       -- table, odds_games_lines. We can insert the over/under entries
 538       -- freely with empty away/home lines:
 539       forM_ (xml_game_over_under_casinos g) $ \c -> do
 540         -- Start by inderting the casino.
 541         ou_casino_id <- insert_xml_or_select c
 542
 543         -- Now add the over/under entry with the casino's id.
 544         let ogl = OddsGameLine {
 545                     ogl_odds_games_id = game_id,
 546                     ogl_odds_casinos_id = ou_casino_id,
 547                     ogl_over_under = (xml_casino_line c),
 548                     ogl_away_line = Nothing,
 549                     ogl_home_line = Nothing }
 550
 551         insert_ ogl
 552
 553       -- ...but then when we insert the home/away team lines, we
 554       -- prefer to update the existing entry rather than overwrite it
 555       -- or add a new record.
 556       forM_ (xml_away_casinos $ xml_game_away_team g) $ \c -> do
 557         -- insert, or more likely retrieve the existing, casino
 558         a_casino_id <- insert_xml_or_select c
 559
 560         -- Get a Maybe Double instead of the Maybe String that's in there.
 561         let away_line = home_away_line c
 562
 563         -- Unconditionally update that casino's away team line with ours.
 564         update [Ogl_Away_Line =. away_line] $ -- WHERE
 565           Ogl_Odds_Casinos_Id ==. a_casino_id
 566
 567       -- Repeat all that for the home team.
 568       forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
 569         h_casino_id <- insert_xml_or_select c
 570         let home_line = home_away_line c
 571         update [Ogl_Home_Line =. home_line] $ -- WHERE
 572           Ogl_Odds_Casinos_Id ==. h_casino_id
 573
 574       return game_id
 575
 576     return ImportSucceeded
 577
 578
 579 --
 580 -- Pickling
 581 --
 582
 583 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
 584 --
 585 pickle_game_with_notes :: PU OddsGameWithNotes
 586 pickle_game_with_notes =
 587   xpWrap (from_pair, to_pair) $
 588     xpPair
 589       (xpList $ xpElem "Notes" xpText)
 590       pickle_game
 591   where
 592     from_pair = uncurry OddsGameWithNotes
 593     to_pair OddsGameWithNotes{..} = (notes, game)
 594
 595
 596 -- | Pickler for an 'OddsGameCasinoXml'.
 597 --
 598 pickle_casino :: PU OddsGameCasinoXml
 599 pickle_casino =
 600   xpElem "Casino" $
 601   xpWrap (from_tuple, to_tuple) $
 602   xpTriple
 603     (xpAttr "ClientID" xpInt)
 604     (xpAttr "Name" xpText)
 605     (xpOption xpText)
 606   where
 607     from_tuple = uncurryN OddsGameCasinoXml
 608     -- Use record wildcards to avoid unused field warnings.
 609     to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
 610                                       xml_casino_name,
 611                                       xml_casino_line)
 612
 613
 614 -- | Pickler for an 'OddsGameHomeTeamXml'.
 615 --
 616 pickle_home_team :: PU OddsGameHomeTeamXml
 617 pickle_home_team =
 618   xpElem "HomeTeam" $
 619     xpWrap (from_tuple, to_tuple) $
 620       xp5Tuple
 621         (xpElem "HomeTeamID" xpText)
 622         (xpElem "HomeRotationNumber" xpInt)
 623         (xpElem "HomeAbbr" xpText)
 624         (xpElem "HomeTeamName" xpText)
 625         (xpList pickle_casino)
 626   where
 627     from_tuple = uncurryN OddsGameHomeTeamXml
 628     -- Use record wildcards to avoid unused field warnings.
 629     to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
 630                                         xml_home_rotation_number,
 631                                         xml_home_abbr,
 632                                         xml_home_team_name,
 633                                         xml_home_casinos)
 634
 635
 636 -- | Pickler for an 'OddsGameAwayTeamXml'.
 637 --
 638 pickle_away_team :: PU OddsGameAwayTeamXml
 639 pickle_away_team =
 640   xpElem "AwayTeam" $
 641     xpWrap (from_tuple, to_tuple) $
 642       xp5Tuple
 643         (xpElem "AwayTeamID" xpText)
 644         (xpElem "AwayRotationNumber" xpInt)
 645         (xpElem "AwayAbbr" xpText)
 646         (xpElem "AwayTeamName" xpText)
 647         (xpList pickle_casino)
 648   where
 649     from_tuple = uncurryN OddsGameAwayTeamXml
 650     -- Use record wildcards to avoid unused field warnings.
 651     to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
 652                                         xml_away_rotation_number,
 653                                         xml_away_abbr,
 654                                         xml_away_team_name,
 655                                         xml_away_casinos)
 656
 657
 658
 659 -- | Pickler for an 'OddsGameOverUnderXml'.
 660 --
 661 pickle_over_under :: PU OddsGameOverUnderXml
 662 pickle_over_under =
 663   xpElem "Over_Under" $
 664   xpWrap (to_newtype, from_newtype) $
 665     xpList pickle_casino
 666   where
 667     from_newtype (OddsGameOverUnderXml cs) = cs
 668     to_newtype = OddsGameOverUnderXml
 669
 670
 671 -- | Pickler for an 'OddsGameXml'.
 672 --
 673 pickle_game :: PU OddsGameXml
 674 pickle_game =
 675   xpElem "Game" $
 676   xpWrap (from_tuple, to_tuple) $
 677   xp6Tuple
 678     (xpElem "GameID" xpInt)
 679     (xpElem "Game_Date" xp_date)
 680     (xpElem "Game_Time" xp_time)
 681     pickle_away_team
 682     pickle_home_team
 683     pickle_over_under
 684   where
 685     from_tuple = uncurryN OddsGameXml
 686     -- Use record wildcards to avoid unused field warnings.
 687     to_tuple OddsGameXml{..} = (xml_game_id,
 688                                 xml_game_date,
 689                                 xml_game_time,
 690                                 xml_game_away_team,
 691                                 xml_game_home_team,
 692                                 xml_game_over_under)
 693
 694
 695 -- | Pickler for the top-level 'Message'.
 696 --
 697 pickle_message :: PU Message
 698 pickle_message =
 699   xpElem "message" $
 700     xpWrap (from_tuple, to_tuple) $
 701     xp8Tuple (xpElem "XML_File_ID" xpInt)
 702              (xpElem "heading" xpText)
 703              (xpElem "category" xpText)
 704              (xpElem "sport" xpText)
 705              (xpElem "Title" xpText)
 706              (xpElem "Line_Time" xpText)
 707              (xpList pickle_game_with_notes)
 708              (xpElem "time_stamp" xp_time_stamp)
 709   where
 710     from_tuple = uncurryN Message
 711     to_tuple m = (xml_xml_file_id m,
 712                   xml_heading m,
 713                   xml_category m,
 714                   xml_sport m,
 715                   xml_title m,
 716                   xml_line_time m,
 717                   xml_games_with_notes m,
 718                   xml_time_stamp m)
 719
 720
 721 --
 722 -- Tasty Tests
 723 --
 724
 725 -- | A list of all tests for this module.
 726 --
 727 odds_tests :: TestTree
 728 odds_tests =
 729   testGroup
 730     "Odds tests"
 731     [ test_pickle_of_unpickle_is_identity,
 732       test_unpickle_succeeds ]
 733
 734
 735 -- | If we unpickle something and then pickle it, we should wind up
 736 --   with the same thing we started with. WARNING: success of this
 737 --   test does not mean that unpickling succeeded.
 738 --
 739 test_pickle_of_unpickle_is_identity :: TestTree
 740 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 741   [ check "pickle composed with unpickle is the identity"
 742          "test/xml/Odds_XML.xml",
 743
 744     check "pickle composed with unpickle is the identity (non-int team_id)"
 745           "test/xml/Odds_XML-noninteger-team-id.xml",
 746
 747     check "pickle composed with unpickle is the identity (positive(+) line)"
 748           "test/xml/Odds_XML-positive-line.xml",
 749
 750     check "pickle composed with unpickle is the identity (large file)"
 751           "test/xml/Odds_XML-largefile.xml" ]
 752   where
 753     check desc path = testCase desc $ do
 754       (expected, actual) <- pickle_unpickle pickle_message path
 755       actual @?= expected
 756
 757
 758 -- | Make sure we can actually unpickle these things.
 759 --
 760 test_unpickle_succeeds :: TestTree
 761 test_unpickle_succeeds = testGroup "unpickle tests"
 762   [ check "unpickling succeeds"
 763           "test/xml/Odds_XML.xml",
 764
 765     check "unpickling succeeds (non-int team_id)"
 766           "test/xml/Odds_XML-noninteger-team-id.xml",
 767
 768     check "unpickling succeeds (positive(+) line)"
 769           "test/xml/Odds_XML-positive-line.xml",
 770
 771     check "unpickling succeeds (large file)"
 772           "test/xml/Odds_XML-largefile.xml" ]
 773   where
 774     check desc path = testCase desc $ do
 775       actual <- unpickleable path pickle_message
 776       let expected = True
 777       actual @?= expected