1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 {-# LANGUAGE TypeFamilies #-}
18 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
19 -- a root element \<message\> that contains a bunch of other
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,
32 import Database.Groundhog.Core ( DefaultKey )
33 import Database.Groundhog.TH (
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 (
61 import TSN.DbImport ( DbImport(..), ImportResult(..) )
62 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
68 xml_casino_client_id :: Int,
69 xml_casino_name :: String,
70 xml_casino_line :: Maybe Float }
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.)
78 db_casino_client_id :: Int,
79 db_casino_name :: String }
82 instance ToFromXml OddsCasino where
83 type Xml OddsCasino = OddsCasinoXml
84 type Container OddsCasino = () -- It has one, but we don't use it.
86 -- Use a record wildcard here so GHC doesn't complain that we never
87 -- used our named fields.
88 to_xml (OddsCasino {..}) =
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{..} =
104 home_rotation_number :: Int,
106 home_team_name :: String,
107 home_casinos :: [OddsCasinoXml] }
113 away_rotation_number :: Int,
115 away_team_name :: String,
116 away_casinos :: [OddsCasinoXml] }
119 -- | Can't use a newtype with Groundhog.
121 OddsOverUnder [OddsCasinoXml]
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 }
138 db_line_time :: String }
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.
145 -- The notes are ignored completely in the database; we only bother
146 -- with them to ensure that we're (un)pickling correctly.
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
153 data OddsGameWithNotes =
159 -- | The XML representation of Odds.
162 xml_xml_file_id :: Int,
163 xml_heading :: String,
164 xml_category :: String,
167 xml_line_time :: String,
168 xml_games_with_notes :: [OddsGameWithNotes],
169 xml_time_stamp :: String }
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)
177 instance ToFromXml Odds where
178 type Xml Odds = Message
179 type Container Odds = ()
181 -- Use record wildcards to avoid unused field warnings.
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 _ _) =
199 pickle_game_with_notes :: PU OddsGameWithNotes
200 pickle_game_with_notes =
201 xpWrap (from_pair, to_pair) $
203 (xpList $ xpElem "Notes" xpText)
206 from_pair = uncurry OddsGameWithNotes
207 to_pair OddsGameWithNotes{..} = (notes, game)
211 pickle_casino :: PU OddsCasinoXml
214 xpWrap (from_tuple, to_tuple) $
216 (xpAttr "ClientID" xpInt)
217 (xpAttr "Name" xpText)
218 (xpOption xpPrim) -- Float
220 from_tuple = uncurryN OddsCasinoXml
221 -- Use record wildcards to avoid unused field warnings.
222 to_tuple OddsCasinoXml{..} = (xml_casino_client_id,
226 instance XmlPickler OddsCasinoXml where
227 xpickle = pickle_casino
230 pickle_home_team :: PU OddsHomeTeam
233 xpWrap (from_tuple, to_tuple) $
235 (xpElem "HomeTeamID" xpInt)
236 (xpElem "HomeRotationNumber" xpInt)
237 (xpElem "HomeAbbr" xpText)
238 (xpElem "HomeTeamName" xpText)
239 (xpList pickle_casino)
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,
249 instance XmlPickler OddsHomeTeam where
250 xpickle = pickle_home_team
253 pickle_away_team :: PU OddsAwayTeam
256 xpWrap (from_tuple, to_tuple) $
258 (xpElem "AwayTeamID" xpInt)
259 (xpElem "AwayRotationNumber" xpInt)
260 (xpElem "AwayAbbr" xpText)
261 (xpElem "AwayTeamName" xpText)
262 (xpList pickle_casino)
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,
273 instance XmlPickler OddsAwayTeam where
274 xpickle = pickle_away_team
277 pickle_over_under :: PU OddsOverUnder
279 xpElem "Over_Under" $
280 xpWrap (to_newtype, from_newtype) $
283 from_newtype (OddsOverUnder cs) = cs
284 to_newtype = OddsOverUnder
286 instance XmlPickler OddsOverUnder where
287 xpickle = pickle_over_under
290 pickle_game :: PU OddsGame
293 xpWrap (from_tuple, to_tuple) $
295 (xpElem "GameID" xpInt)
296 (xpElem "Game_Date" xpText)
297 (xpElem "Game_Time" xpText)
302 from_tuple = uncurryN OddsGame
303 -- Use record wildcards to avoid unused field warnings.
304 to_tuple OddsGame{..} = (game_id,
311 instance XmlPickler OddsGame where
312 xpickle = pickle_game
315 pickle_message :: PU 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)
328 from_tuple = uncurryN Message
329 to_tuple m = (xml_xml_file_id m,
335 xml_games_with_notes m,
339 instance XmlPickler Message where
340 xpickle = pickle_message
348 odds_tests :: TestTree
352 [ test_pickle_of_unpickle_is_identity,
353 test_unpickle_succeeds ]
356 -- | Warning, succeess of this test does not mean that unpickling
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
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