src/TSN/XML/Odds.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE StandaloneDeriving #-}
   8 {-# LANGUAGE TemplateHaskell #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10
  11 module TSN.XML.Odds (
  12   Odds,
  13   Message,
  14   odds_tests )
  15 where
  16
  17
  18 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
  19 --   a root element \<message\> that contains a bunch of other
  20 --   unorganized crap.
  21 --
  22
  23 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
  24 import Data.List.Utils ( join, split )
  25 import Data.Tuple.Curry ( uncurryN )
  26 import Data.Typeable ( Typeable )
  27 import Database.Groundhog (
  28   defaultMigrationLogger,
  29   insert,
  30   migrate,
  31   runMigration )
  32 import Database.Groundhog.Core ( DefaultKey )
  33 import Database.Groundhog.TH (
  34   groundhog,
  35   mkPersist )
  36 import System.Console.CmdArgs.Default ( Default(..) )
  37 import Test.Tasty ( TestTree, testGroup )
  38 import Test.Tasty.HUnit ( (@?=), testCase )
  39 import Text.XML.HXT.Core (
  40   PU,
  41   XmlPickler(..),
  42   unpickleDoc,
  43   xp5Tuple,
  44   xp6Tuple,
  45   xp8Tuple,
  46   xpAttr,
  47   xpElem,
  48   xpInt,
  49   xpList,
  50   xpOption,
  51   xpPair,
  52   xpPrim,
  53   xpText,
  54   xpText0,
  55   xpTriple,
  56   xpWrap )
  57
  58 import TSN.Codegen (
  59   tsn_codegen_config,
  60   tsn_db_field_namer )
  61 import TSN.DbImport ( DbImport(..), ImportResult(..) )
  62 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
  63
  64
  65
  66 data OddsCasinoXml =
  67   OddsCasinoXml {
  68     xml_casino_client_id :: Int,
  69     xml_casino_name      :: String,
  70     xml_casino_line      :: Maybe Float }
  71   deriving (Eq, Show)
  72
  73 -- | The casinos should have their own table, but the lines don't
  74 --   belong in that table. (There should be another table joining the
  75 --   casinos and the thing the lines are for together.)
  76 data OddsCasino =
  77   OddsCasino {
  78     db_casino_client_id :: Int,
  79     db_casino_name :: String }
  80   deriving (Eq, Show)
  81
  82 instance ToFromXml OddsCasino where
  83   type Xml OddsCasino = OddsCasinoXml
  84   type Container OddsCasino = () -- It has one, but we don't use it.
  85
  86   -- Use a record wildcard here so GHC doesn't complain that we never
  87   -- used our named fields.
  88   to_xml (OddsCasino {..}) =
  89     OddsCasinoXml
  90       db_casino_client_id
  91       db_casino_name
  92       def
  93
  94   -- We don't need the key argument (from_xml_fk) since the XML type
  95   -- contains more information in this case.
  96   from_xml OddsCasinoXml{..} =
  97     OddsCasino
  98       xml_casino_client_id
  99       xml_casino_name
 100
 101 data OddsHomeTeam =
 102   OddsHomeTeam {
 103     home_team_id         :: Int,
 104     home_rotation_number :: Int,
 105     home_abbr            :: String,
 106     home_team_name       :: String,
 107     home_casinos         :: [OddsCasinoXml] }
 108   deriving (Eq, Show)
 109
 110 data OddsAwayTeam =
 111   OddsAwayTeam {
 112     away_team_id         :: Int,
 113     away_rotation_number :: Int,
 114     away_abbr            :: String,
 115     away_team_name       :: String,
 116     away_casinos         :: [OddsCasinoXml] }
 117   deriving (Eq, Show)
 118
 119 -- | Can't use a newtype with Groundhog.
 120 data OddsOverUnder =
 121   OddsOverUnder [OddsCasinoXml]
 122   deriving (Eq, Show)
 123
 124 data OddsGame =
 125   OddsGame {
 126     game_id         :: Int,
 127     game_date       :: String, -- TODO
 128     game_time       :: String, -- TODO
 129     game_away_team  :: OddsAwayTeam,
 130     game_home_team  :: OddsHomeTeam,
 131     game_over_under :: OddsOverUnder }
 132   deriving (Eq, Show)
 133
 134 data Odds =
 135   Odds {
 136     db_sport :: String,
 137     db_title :: String,
 138     db_line_time :: String }
 139
 140 -- | This is our best guess at what occurs in the Odds_XML
 141 --   documents. It looks like each consecutive set of games can
 142 --   optionally have some notes appear before it. Each "note" comes as
 143 --   its own <Notes>...</Notes> element.
 144 --
 145 --   The notes are ignored completely in the database; we only bother
 146 --   with them to ensure that we're (un)pickling correctly.
 147 --
 148 --   We can't group the notes with a "set" of 'OddsGame's, because that
 149 --   leads to ambiguity in parsing. Since we're going to ignore the
 150 --   notes anyway, we just stick them with an arbitrary game. C'est la
 151 --   vie.
 152 --
 153 data OddsGameWithNotes =
 154   OddsGameWithNotes {
 155     notes :: [String],
 156     game :: OddsGame }
 157   deriving (Eq, Show)
 158
 159 -- | The XML representation of Odds.
 160 data Message =
 161   Message {
 162     xml_xml_file_id :: Int,
 163     xml_heading :: String,
 164     xml_category :: String,
 165     xml_sport :: String,
 166     xml_title :: String,
 167     xml_line_time :: String,
 168     xml_games_with_notes :: [OddsGameWithNotes],
 169     xml_time_stamp :: String }
 170   deriving (Eq, Show)
 171
 172 -- | Pseudo-field that lets us get the 'OddsGame's out of
 173 --   'xml_games_with_notes'.
 174 xml_games :: Message -> [OddsGame]
 175 xml_games m = map game (xml_games_with_notes m)
 176
 177 instance ToFromXml Odds where
 178   type Xml Odds = Message
 179   type Container Odds = ()
 180
 181   -- Use record wildcards to avoid unused field warnings.
 182   to_xml (Odds {..}) =
 183     Message
 184       def
 185       def
 186       def
 187       db_sport
 188       db_title
 189       db_line_time
 190       def
 191       def
 192
 193   -- We don't need the key argument (from_xml_fk) since the XML type
 194   -- contains more information in this case.
 195   from_xml (Message _ _ _ d e f _ _) =
 196     Odds d e f
 197
 198
 199 pickle_game_with_notes :: PU OddsGameWithNotes
 200 pickle_game_with_notes =
 201   xpWrap (from_pair, to_pair) $
 202     xpPair
 203       (xpList $ xpElem "Notes" xpText)
 204       pickle_game
 205   where
 206     from_pair = uncurry OddsGameWithNotes
 207     to_pair OddsGameWithNotes{..} = (notes, game)
 208
 209
 210
 211 pickle_casino :: PU OddsCasinoXml
 212 pickle_casino =
 213   xpElem "Casino" $
 214   xpWrap (from_tuple, to_tuple) $
 215   xpTriple
 216     (xpAttr "ClientID" xpInt)
 217     (xpAttr "Name" xpText)
 218     (xpOption xpPrim) -- Float
 219   where
 220     from_tuple = uncurryN OddsCasinoXml
 221     -- Use record wildcards to avoid unused field warnings.
 222     to_tuple OddsCasinoXml{..} = (xml_casino_client_id,
 223                                   xml_casino_name,
 224                                   xml_casino_line)
 225
 226 instance XmlPickler OddsCasinoXml where
 227   xpickle = pickle_casino
 228
 229
 230 pickle_home_team :: PU OddsHomeTeam
 231 pickle_home_team =
 232   xpElem "HomeTeam" $
 233     xpWrap (from_tuple, to_tuple) $
 234       xp5Tuple
 235         (xpElem "HomeTeamID" xpInt)
 236         (xpElem "HomeRotationNumber" xpInt)
 237         (xpElem "HomeAbbr" xpText)
 238         (xpElem "HomeTeamName" xpText)
 239         (xpList pickle_casino)
 240   where
 241     from_tuple = uncurryN OddsHomeTeam
 242     -- Use record wildcards to avoid unused field warnings.
 243     to_tuple OddsHomeTeam{..} = (home_team_id,
 244                                  home_rotation_number,
 245                                  home_abbr,
 246                                  home_team_name,
 247                                  home_casinos)
 248
 249 instance XmlPickler OddsHomeTeam where
 250   xpickle = pickle_home_team
 251
 252
 253 pickle_away_team :: PU OddsAwayTeam
 254 pickle_away_team =
 255   xpElem "AwayTeam" $
 256     xpWrap (from_tuple, to_tuple) $
 257       xp5Tuple
 258         (xpElem "AwayTeamID" xpInt)
 259         (xpElem "AwayRotationNumber" xpInt)
 260         (xpElem "AwayAbbr" xpText)
 261         (xpElem "AwayTeamName" xpText)
 262         (xpList pickle_casino)
 263   where
 264     from_tuple = uncurryN OddsAwayTeam
 265     -- Use record wildcards to avoid unused field warnings.
 266     to_tuple OddsAwayTeam{..} = (away_team_id,
 267                                  away_rotation_number,
 268                                  away_abbr,
 269                                  away_team_name,
 270                                  away_casinos)
 271
 272
 273 instance XmlPickler OddsAwayTeam where
 274   xpickle = pickle_away_team
 275
 276
 277 pickle_over_under :: PU OddsOverUnder
 278 pickle_over_under =
 279   xpElem "Over_Under" $
 280   xpWrap (to_newtype, from_newtype) $
 281     xpList pickle_casino
 282   where
 283     from_newtype (OddsOverUnder cs) = cs
 284     to_newtype = OddsOverUnder
 285
 286 instance XmlPickler OddsOverUnder where
 287   xpickle = pickle_over_under
 288
 289
 290 pickle_game :: PU OddsGame
 291 pickle_game =
 292   xpElem "Game" $
 293   xpWrap (from_tuple, to_tuple) $
 294   xp6Tuple
 295     (xpElem "GameID" xpInt)
 296     (xpElem "Game_Date" xpText)
 297     (xpElem "Game_Time" xpText)
 298     pickle_away_team
 299     pickle_home_team
 300     pickle_over_under
 301   where
 302     from_tuple = uncurryN OddsGame
 303     -- Use record wildcards to avoid unused field warnings.
 304     to_tuple OddsGame{..} = (game_id,
 305                              game_date,
 306                              game_time,
 307                              game_away_team,
 308                              game_home_team,
 309                              game_over_under)
 310
 311 instance XmlPickler OddsGame where
 312   xpickle = pickle_game
 313
 314
 315 pickle_message :: PU Message
 316 pickle_message =
 317   xpElem "message" $
 318     xpWrap (from_tuple, to_tuple) $
 319     xp8Tuple (xpElem "XML_File_ID" xpInt)
 320              (xpElem "heading" xpText)
 321              (xpElem "category" xpText)
 322              (xpElem "sport" xpText)
 323              (xpElem "Title" xpText)
 324              (xpElem "Line_Time" xpText)
 325              (xpList $ pickle_game_with_notes)
 326              (xpElem "time_stamp" xpText)
 327   where
 328     from_tuple = uncurryN Message
 329     to_tuple m = (xml_xml_file_id m,
 330                   xml_heading m,
 331                   xml_category m,
 332                   xml_sport m,
 333                   xml_title m,
 334                   xml_line_time m,
 335                   xml_games_with_notes m,
 336                   xml_time_stamp m)
 337
 338
 339 instance XmlPickler Message where
 340   xpickle = pickle_message
 341
 342
 343
 344
 345
 346
 347 -- * Tasty Tests
 348 odds_tests :: TestTree
 349 odds_tests =
 350   testGroup
 351     "Odds tests"
 352     [ test_pickle_of_unpickle_is_identity,
 353       test_unpickle_succeeds ]
 354
 355
 356 -- | Warning, succeess of this test does not mean that unpickling
 357 --   succeeded.
 358 test_pickle_of_unpickle_is_identity :: TestTree
 359 test_pickle_of_unpickle_is_identity =
 360   testCase "pickle composed with unpickle is the identity" $ do
 361     let path = "test/xml/Odds_XML.xml"
 362     (expected :: [Message], actual) <- pickle_unpickle "message" path
 363     actual @?= expected
 364
 365
 366 test_unpickle_succeeds :: TestTree
 367 test_unpickle_succeeds =
 368   testCase "unpickling succeeds" $ do
 369   let path = "test/xml/Odds_XML.xml"
 370   actual <- unpickleable path pickle_message
 371   let expected = True
 372   actual @?= expected