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   Message,
  13   odds_tests )
  14 where
  15
  16
  17 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
  18 --   a root element \<message\> that contains a bunch of other
  19 --   unorganized crap.
  20 --
  21
  22 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
  23 import Data.List.Utils ( join, split )
  24 import Data.Tuple.Curry ( uncurryN )
  25 import Data.Typeable ( Typeable )
  26 import Database.Groundhog (
  27   defaultMigrationLogger,
  28   insert,
  29   migrate,
  30   runMigration )
  31 import Database.Groundhog.Core ( DefaultKey )
  32 import Database.Groundhog.TH (
  33   groundhog,
  34   mkPersist )
  35 import System.Console.CmdArgs.Default ( Default(..) )
  36 import Test.Tasty ( TestTree, testGroup )
  37 import Test.Tasty.HUnit ( (@?=), testCase )
  38 import Text.XML.HXT.Core (
  39   PU,
  40   XmlPickler(..),
  41   unpickleDoc,
  42   xp5Tuple,
  43   xp6Tuple,
  44   xp11Tuple,
  45   xpAttr,
  46   xpElem,
  47   xpInt,
  48   xpList,
  49   xpOption,
  50   xpPair,
  51   xpPrim,
  52   xpText,
  53   xpText0,
  54   xpTriple,
  55   xpWrap )
  56
  57 import TSN.Codegen (
  58   tsn_codegen_config,
  59   tsn_db_field_namer )
  60 import TSN.DbImport ( DbImport(..), ImportResult(..) )
  61 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
  62
  63
  64
  65 data OddsCasino =
  66   OddsCasino {
  67     xml_casino_client_id :: Int,
  68     xml_casino_name      :: String,
  69     xml_casino_line      :: Maybe Float }
  70   deriving (Eq, Show)
  71
  72 data OddsHomeTeam =
  73   OddsHomeTeam {
  74     xml_home_team_id         :: Int,
  75     xml_home_rotation_number :: Int,
  76     xml_home_abbr            :: String,
  77     xml_home_team_name       :: String,
  78     xml_home_casinos         :: [OddsCasino] }
  79   deriving (Eq, Show)
  80
  81 data OddsAwayTeam =
  82   OddsAwayTeam {
  83     xml_away_team_id         :: Int,
  84     xml_away_rotation_number :: Int,
  85     xml_away_abbr            :: String,
  86     xml_away_team_name       :: String,
  87     xml_away_casinos         :: [OddsCasino] }
  88   deriving (Eq, Show)
  89
  90 -- | Can't use a newtype with Groundhog.
  91 data OddsOverUnder =
  92   OddsOverUnder [OddsCasino]
  93   deriving (Eq, Show)
  94
  95 data OddsGame =
  96   OddsGame {
  97     xml_game_id         :: Int,
  98     xml_game_date       :: String, -- TODO
  99     xml_game_time       :: String, -- TODO
 100     xml_game_away_team  :: OddsAwayTeam,
 101     xml_game_home_team  :: OddsHomeTeam,
 102     xml_game_over_under :: OddsOverUnder }
 103   deriving (Eq, Show)
 104
 105 data Message =
 106   Message {
 107     db_sport :: String,
 108     db_title :: String,
 109     db_line_time :: String,
 110     db_notes1 :: String,
 111     db_notes2 :: String }
 112
 113 data MessageXml =
 114   MessageXml {
 115     xml_xml_file_id :: Int,
 116     xml_heading :: String,
 117     xml_category :: String,
 118     xml_sport :: String,
 119     xml_title :: String,
 120     xml_line_time :: String, -- The DTD goes crazy here.
 121     xml_notes1 :: String,
 122     xml_games1 :: [OddsGame],
 123     xml_notes2 :: String,
 124     xml_games2 :: [OddsGame],
 125     xml_time_stamp :: String }
 126   deriving (Eq, Show)
 127
 128
 129 instance ToFromXml Message where
 130   type Xml Message = MessageXml
 131   type Container Message = ()
 132
 133   -- Use a record wildcard here so GHC doesn't complain that we never
 134   -- used our named fields.
 135   to_xml (Message {..}) =
 136     MessageXml
 137       def
 138       def
 139       def
 140       db_sport
 141       db_title
 142       db_line_time
 143       db_notes1
 144       def
 145       db_notes2
 146       def
 147       def
 148
 149   -- We don't need the key argument (from_xml_fk) since the XML type
 150   -- contains more information in this case.
 151   from_xml (MessageXml _ _ _ d e f g _ i _ _) =
 152     Message d e f g i
 153
 154
 155 pickle_casino :: PU OddsCasino
 156 pickle_casino =
 157   xpElem "Casino" $
 158   xpWrap (from_tuple, to_tuple) $
 159   xpTriple
 160     (xpAttr "ClientID" xpInt)
 161     (xpAttr "Name" xpText)
 162     (xpOption xpPrim)
 163   where
 164     from_tuple = uncurryN OddsCasino
 165     to_tuple (OddsCasino x y z) = (x, y, z)
 166
 167 instance XmlPickler OddsCasino where
 168   xpickle = pickle_casino
 169
 170
 171 pickle_home_team :: PU OddsHomeTeam
 172 pickle_home_team =
 173   xpElem "HomeTeam" $
 174   xpWrap (from_tuple, to_tuple) $
 175   xp5Tuple
 176     (xpElem "HomeTeamID" xpPrim)
 177     (xpElem "HomeRotationNumber" xpPrim)
 178     (xpElem "HomeAbbr" xpText)
 179     (xpElem "HomeTeamName" xpText)
 180     (xpList pickle_casino)
 181   where
 182     from_tuple = uncurryN OddsHomeTeam
 183     to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z)
 184
 185
 186 instance XmlPickler OddsHomeTeam where
 187   xpickle = pickle_home_team
 188
 189
 190 pickle_away_team :: PU OddsAwayTeam
 191 pickle_away_team =
 192   xpElem "AwayTeam" $
 193   xpWrap (from_tuple, to_tuple) $
 194   xp5Tuple
 195     (xpElem "AwayTeamID" xpPrim)
 196     (xpElem "AwayRotationNumber" xpPrim)
 197     (xpElem "AwayAbbr" xpText)
 198     (xpElem "AwayTeamName" xpText)
 199     (xpList pickle_casino)
 200   where
 201     from_tuple = uncurryN OddsAwayTeam
 202     to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z)
 203
 204
 205 instance XmlPickler OddsAwayTeam where
 206   xpickle = pickle_away_team
 207
 208
 209 pickle_over_under :: PU OddsOverUnder
 210 pickle_over_under =
 211   xpElem "Over_Under" $
 212   xpWrap (to_newtype, from_newtype) $
 213     xpList pickle_casino
 214   where
 215     from_newtype (OddsOverUnder cs) = cs
 216     to_newtype = OddsOverUnder
 217
 218 instance XmlPickler OddsOverUnder where
 219   xpickle = pickle_over_under
 220
 221
 222 pickle_game :: PU OddsGame
 223 pickle_game =
 224   xpElem "Game" $
 225   xpWrap (from_tuple, to_tuple) $
 226   xp6Tuple
 227     (xpElem "GameID" xpPrim)
 228     (xpElem "Game_Date" xpText)
 229     (xpElem "Game_Time" xpText)
 230     pickle_away_team
 231     pickle_home_team
 232     pickle_over_under
 233   where
 234     from_tuple = uncurryN OddsGame
 235     to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z)
 236
 237 instance XmlPickler OddsGame where
 238   xpickle = pickle_game
 239
 240
 241 pickle_message :: PU MessageXml
 242 pickle_message =
 243   xpElem "message" $
 244     xpWrap (from_tuple, to_tuple) $
 245     xp11Tuple (xpElem "XML_File_ID" xpPrim)
 246               (xpElem "heading" xpText)
 247               (xpElem "category" xpText)
 248               (xpElem "sport" xpText)
 249               (xpElem "Title" xpText)
 250               (xpElem "Line_Time" xpText)
 251               pickle_notes
 252               (xpList pickle_game)
 253               pickle_notes
 254               (xpList pickle_game)
 255               (xpElem "time_stamp" xpText)
 256   where
 257     from_tuple = uncurryN MessageXml
 258     to_tuple m = (xml_xml_file_id m,
 259                   xml_heading m,
 260                   xml_category m,
 261                   xml_sport m,
 262                   xml_title m,
 263                   xml_line_time m,
 264                   xml_notes1 m,
 265                   xml_games1 m,
 266                   xml_notes2 m,
 267                   xml_games2 m,
 268                   xml_time_stamp m)
 269
 270     pickle_notes :: PU String
 271     pickle_notes =
 272       xpWrap (to_string, from_string) $
 273         xpList (xpElem "Notes" xpText)
 274       where
 275         from_string :: String -> [String]
 276         from_string = split "\n"
 277
 278         to_string :: [String] -> String
 279         to_string = join "\n"
 280
 281 instance XmlPickler MessageXml where
 282   xpickle = pickle_message
 283
 284
 285
 286
 287
 288
 289 -- * Tasty Tests
 290 odds_tests :: TestTree
 291 odds_tests =
 292   testGroup
 293     "Odds tests"
 294     [ test_pickle_of_unpickle_is_identity,
 295       test_unpickle_succeeds ]
 296
 297
 298 -- | Warning, succeess of this test does not mean that unpickling
 299 --   succeeded.
 300 test_pickle_of_unpickle_is_identity :: TestTree
 301 test_pickle_of_unpickle_is_identity =
 302   testCase "pickle composed with unpickle is the identity" $ do
 303     let path = "test/xml/Odds_XML.xml"
 304     (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
 305     actual @?= expected
 306
 307
 308 test_unpickle_succeeds :: TestTree
 309 test_unpickle_succeeds =
 310   testCase "unpickling succeeds" $ do
 311   let path = "test/xml/Odds_XML.xml"
 312   actual <- unpickleable path pickle_message
 313   let expected = True
 314   actual @?= expected