src/TSN/XML/Odds.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE QuasiQuotes #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE StandaloneDeriving #-}
   9 {-# LANGUAGE TemplateHaskell #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11
  12 module TSN.XML.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   xp11Tuple,
  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 OddsCasino =
  67   OddsCasino {
  68     xml_casino_client_id :: Int,
  69     xml_casino_name      :: String,
  70     xml_casino_line      :: Maybe Float }
  71   deriving (Eq, Show)
  72
  73 data OddsHomeTeam =
  74   OddsHomeTeam {
  75     xml_home_team_id         :: Int,
  76     xml_home_rotation_number :: Int,
  77     xml_home_abbr            :: String,
  78     xml_home_team_name       :: String,
  79     xml_home_casinos         :: [OddsCasino] }
  80   deriving (Eq, Show)
  81
  82 data OddsAwayTeam =
  83   OddsAwayTeam {
  84     xml_away_team_id         :: Int,
  85     xml_away_rotation_number :: Int,
  86     xml_away_abbr            :: String,
  87     xml_away_team_name       :: String,
  88     xml_away_casinos         :: [OddsCasino] }
  89   deriving (Eq, Show)
  90
  91 -- | Can't use a newtype with Groundhog.
  92 data OddsOverUnder =
  93   OddsOverUnder [OddsCasino]
  94   deriving (Eq, Show)
  95
  96 data OddsGame =
  97   OddsGame {
  98     xml_game_id         :: Int,
  99     xml_game_date       :: String, -- TODO
 100     xml_game_time       :: String, -- TODO
 101     xml_game_away_team  :: OddsAwayTeam,
 102     xml_game_home_team  :: OddsHomeTeam,
 103     xml_game_over_under :: OddsOverUnder }
 104   deriving (Eq, Show)
 105
 106 data Message =
 107   Message {
 108     db_sport :: String,
 109     db_title :: String,
 110     db_line_time :: String,
 111     db_notes1 :: String,
 112     db_notes2 :: String }
 113
 114 data MessageXml =
 115   MessageXml {
 116     xml_xml_file_id :: Int,
 117     xml_heading :: String,
 118     xml_category :: String,
 119     xml_sport :: String,
 120     xml_title :: String,
 121     xml_line_time :: String, -- The DTD goes crazy here.
 122     xml_notes1 :: String,
 123     xml_games1 :: [OddsGame],
 124     xml_notes2 :: String,
 125     xml_games2 :: [OddsGame],
 126     xml_time_stamp :: String }
 127   deriving (Eq, Show)
 128
 129
 130 instance ToFromXml Message where
 131   type Xml Message = MessageXml
 132   type Container Message = ()
 133
 134   -- Use a record wildcard here so GHC doesn't complain that we never
 135   -- used our named fields.
 136   to_xml (Message {..}) =
 137     MessageXml
 138       def
 139       def
 140       def
 141       db_sport
 142       db_title
 143       db_line_time
 144       db_notes1
 145       def
 146       db_notes2
 147       def
 148       def
 149
 150   -- We don't need the key argument (from_xml_fk) since the XML type
 151   -- contains more information in this case.
 152   from_xml (MessageXml _ _ _ d e f g _ i _ _) =
 153     Message d e f g i
 154
 155
 156 pickle_casino :: PU OddsCasino
 157 pickle_casino =
 158   xpElem "Casino" $
 159   xpWrap (from_tuple, to_tuple) $
 160   xpTriple
 161     (xpAttr "ClientID" xpInt)
 162     (xpAttr "Name" xpText)
 163     (xpOption xpPrim)
 164   where
 165     from_tuple = uncurryN OddsCasino
 166     to_tuple (OddsCasino x y z) = (x, y, z)
 167
 168 instance XmlPickler OddsCasino where
 169   xpickle = pickle_casino
 170
 171
 172 pickle_home_team :: PU OddsHomeTeam
 173 pickle_home_team =
 174   xpElem "HomeTeam" $
 175   xpWrap (from_tuple, to_tuple) $
 176   xp5Tuple
 177     (xpElem "HomeTeamID" xpPrim)
 178     (xpElem "HomeRotationNumber" xpPrim)
 179     (xpElem "HomeAbbr" xpText)
 180     (xpElem "HomeTeamName" xpText)
 181     (xpList pickle_casino)
 182   where
 183     from_tuple = uncurryN OddsHomeTeam
 184     to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z)
 185
 186
 187 instance XmlPickler OddsHomeTeam where
 188   xpickle = pickle_home_team
 189
 190
 191 pickle_away_team :: PU OddsAwayTeam
 192 pickle_away_team =
 193   xpElem "AwayTeam" $
 194   xpWrap (from_tuple, to_tuple) $
 195   xp5Tuple
 196     (xpElem "AwayTeamID" xpPrim)
 197     (xpElem "AwayRotationNumber" xpPrim)
 198     (xpElem "AwayAbbr" xpText)
 199     (xpElem "AwayTeamName" xpText)
 200     (xpList pickle_casino)
 201   where
 202     from_tuple = uncurryN OddsAwayTeam
 203     to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z)
 204
 205
 206 instance XmlPickler OddsAwayTeam where
 207   xpickle = pickle_away_team
 208
 209
 210 pickle_over_under :: PU OddsOverUnder
 211 pickle_over_under =
 212   xpElem "Over_Under" $
 213   xpWrap (to_newtype, from_newtype) $
 214     xpList pickle_casino
 215   where
 216     from_newtype (OddsOverUnder cs) = cs
 217     to_newtype = OddsOverUnder
 218
 219 instance XmlPickler OddsOverUnder where
 220   xpickle = pickle_over_under
 221
 222
 223 pickle_game :: PU OddsGame
 224 pickle_game =
 225   xpElem "Game" $
 226   xpWrap (from_tuple, to_tuple) $
 227   xp6Tuple
 228     (xpElem "GameID" xpPrim)
 229     (xpElem "Game_Date" xpText)
 230     (xpElem "Game_Time" xpText)
 231     pickle_away_team
 232     pickle_home_team
 233     pickle_over_under
 234   where
 235     from_tuple = uncurryN OddsGame
 236     to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z)
 237
 238 instance XmlPickler OddsGame where
 239   xpickle = pickle_game
 240
 241
 242 pickle_message :: PU MessageXml
 243 pickle_message =
 244   xpElem "message" $
 245     xpWrap (from_tuple, to_tuple) $
 246     xp11Tuple (xpElem "XML_File_ID" xpPrim)
 247               (xpElem "heading" xpText)
 248               (xpElem "category" xpText)
 249               (xpElem "sport" xpText)
 250               (xpElem "Title" xpText)
 251               (xpElem "Line_Time" xpText)
 252               pickle_notes
 253               (xpList $ pickle_game)
 254               pickle_notes
 255               (xpList $ pickle_game)
 256               (xpElem "time_stamp" xpText)
 257   where
 258     from_tuple = uncurryN MessageXml
 259     to_tuple m = (xml_xml_file_id m,
 260                   xml_heading m,
 261                   xml_category m,
 262                   xml_sport m,
 263                   xml_title m,
 264                   xml_line_time m,
 265                   xml_notes1 m,
 266                   xml_games1 m,
 267                   xml_notes2 m,
 268                   xml_games2 m,
 269                   xml_time_stamp m)
 270
 271     pickle_notes :: PU String
 272     pickle_notes =
 273       xpWrap (to_string, from_string) $
 274           (xpList $ xpElem "Notes" xpText)
 275       where
 276         from_string :: String -> [String]
 277         from_string = split "\n"
 278
 279         to_string :: [String] -> String
 280         to_string = join "\n"
 281
 282 instance XmlPickler MessageXml where
 283   xpickle = pickle_message
 284
 285
 286
 287
 288
 289
 290 -- * Tasty Tests
 291 odds_tests :: TestTree
 292 odds_tests =
 293   testGroup
 294     "Odds tests"
 295     [ test_pickle_of_unpickle_is_identity,
 296       test_unpickle_succeeds ]
 297
 298
 299 -- | Warning, succeess of this test does not mean that unpickling
 300 --   succeeded.
 301 test_pickle_of_unpickle_is_identity :: TestTree
 302 test_pickle_of_unpickle_is_identity =
 303   testCase "pickle composed with unpickle is the identity" $ do
 304     let path = "test/xml/Odds_XML.xml"
 305     (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
 306     actual @?= expected
 307
 308
 309 test_unpickle_succeeds :: TestTree
 310 test_unpickle_succeeds =
 311   testCase "unpickling succeeds" $ do
 312   let path = "test/xml/Odds_XML.xml"
 313   actual <- unpickleable path pickle_message
 314   let expected = True
 315   actual @?= expected