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 TSN.XmlImport ( XmlImport(..) )
63 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
69 xml_casino_client_id :: Int,
70 xml_casino_name :: String,
71 xml_casino_line :: Maybe Float }
75 -- | The casinos should have their own table, but the lines don't
76 -- belong in that table. (There should be another table joining the
77 -- casinos and the thing the lines are for together.)
80 casino_client_id :: Int,
81 casino_name :: String }
84 instance FromXml OddsCasinoXml where
85 type Db OddsCasinoXml = OddsCasino
87 -- We don't need the key argument (from_xml_fk) since the XML type
88 -- contains more information in this case.
89 from_xml OddsCasinoXml{..} = OddsCasino
93 instance XmlImport OddsCasinoXml
96 data OddsHomeTeamXml =
98 xml_home_team_id :: Int,
99 xml_home_rotation_number :: Int,
100 xml_home_abbr :: String,
101 xml_home_team_name :: String,
102 xml_home_casinos :: [OddsCasinoXml] }
105 instance FromXml OddsHomeTeamXml where
106 type Db OddsHomeTeamXml = OddsTeam
107 from_xml OddsHomeTeamXml{..} = OddsTeam
112 instance XmlImport OddsHomeTeamXml where
119 db_team_name :: String }
122 data OddsAwayTeamXml =
124 xml_away_team_id :: Int,
125 xml_away_rotation_number :: Int,
126 xml_away_abbr :: String,
127 xml_away_team_name :: String,
128 xml_away_casinos :: [OddsCasinoXml] }
131 instance FromXml OddsAwayTeamXml where
132 type Db OddsAwayTeamXml = OddsTeam
133 from_xml OddsAwayTeamXml{..} = OddsTeam
138 instance XmlImport OddsAwayTeamXml where
140 -- | Can't use a newtype with Groundhog.
142 OddsOverUnder [OddsCasinoXml]
148 db_game_date :: String, -- TODO
149 db_game_time :: String, -- TODO
150 db_game_away_team_id :: DefaultKey OddsTeam,
151 db_game_away_team_rotation_number :: Int,
152 db_game_home_team_id :: DefaultKey OddsTeam,
153 db_game_home_team_rotation_number :: Int }
154 deriving instance Eq OddsGame
155 deriving instance Show OddsGame
160 xml_game_date :: String, -- TODO
161 xml_game_time :: String, -- TODO
162 xml_game_away_team :: OddsAwayTeamXml,
163 xml_game_home_team :: OddsHomeTeamXml,
164 xml_game_over_under :: OddsOverUnder }
171 db_line_time :: String }
173 -- | This is our best guess at what occurs in the Odds_XML
174 -- documents. It looks like each consecutive set of games can
175 -- optionally have some notes appear before it. Each "note" comes as
176 -- its own <Notes>...</Notes> element.
178 -- The notes are ignored completely in the database; we only bother
179 -- with them to ensure that we're (un)pickling correctly.
181 -- We can't group the notes with a "set" of 'OddsGame's, because that
182 -- leads to ambiguity in parsing. Since we're going to ignore the
183 -- notes anyway, we just stick them with an arbitrary game. C'est la
186 data OddsGameWithNotes =
189 game :: OddsGameXml }
192 -- | The XML representation of Odds.
195 xml_xml_file_id :: Int,
196 xml_heading :: String,
197 xml_category :: String,
200 xml_line_time :: String,
201 xml_games_with_notes :: [OddsGameWithNotes],
202 xml_time_stamp :: String }
205 -- | Pseudo-field that lets us get the 'OddsGame's out of
206 -- 'xml_games_with_notes'.
207 xml_games :: Message -> [OddsGameXml]
208 xml_games m = map game (xml_games_with_notes m)
210 instance FromXml Message where
211 type Db Message = Odds
213 -- We don't need the key argument (from_xml_fk) since the XML type
214 -- contains more information in this case.
215 from_xml (Message _ _ _ d e f _ _) =
218 instance XmlImport Message
220 instance DbImport Message where
221 dbmigrate _= undefined
224 pickle_game_with_notes :: PU OddsGameWithNotes
225 pickle_game_with_notes =
226 xpWrap (from_pair, to_pair) $
228 (xpList $ xpElem "Notes" xpText)
231 from_pair = uncurry OddsGameWithNotes
232 to_pair OddsGameWithNotes{..} = (notes, game)
236 pickle_casino :: PU OddsCasinoXml
239 xpWrap (from_tuple, to_tuple) $
241 (xpAttr "ClientID" xpInt)
242 (xpAttr "Name" xpText)
243 (xpOption xpPrim) -- Float
245 from_tuple = uncurryN OddsCasinoXml
246 -- Use record wildcards to avoid unused field warnings.
247 to_tuple OddsCasinoXml{..} = (xml_casino_client_id,
251 instance XmlPickler OddsCasinoXml where
252 xpickle = pickle_casino
255 pickle_home_team :: PU OddsHomeTeamXml
258 xpWrap (from_tuple, to_tuple) $
260 (xpElem "HomeTeamID" xpInt)
261 (xpElem "HomeRotationNumber" xpInt)
262 (xpElem "HomeAbbr" xpText)
263 (xpElem "HomeTeamName" xpText)
264 (xpList pickle_casino)
266 from_tuple = uncurryN OddsHomeTeamXml
267 -- Use record wildcards to avoid unused field warnings.
268 to_tuple OddsHomeTeamXml{..} = (xml_home_team_id,
269 xml_home_rotation_number,
274 instance XmlPickler OddsHomeTeamXml where
275 xpickle = pickle_home_team
278 pickle_away_team :: PU OddsAwayTeamXml
281 xpWrap (from_tuple, to_tuple) $
283 (xpElem "AwayTeamID" xpInt)
284 (xpElem "AwayRotationNumber" xpInt)
285 (xpElem "AwayAbbr" xpText)
286 (xpElem "AwayTeamName" xpText)
287 (xpList pickle_casino)
289 from_tuple = uncurryN OddsAwayTeamXml
290 -- Use record wildcards to avoid unused field warnings.
291 to_tuple OddsAwayTeamXml{..} = (xml_away_team_id,
292 xml_away_rotation_number,
298 instance XmlPickler OddsAwayTeamXml where
299 xpickle = pickle_away_team
302 pickle_over_under :: PU OddsOverUnder
304 xpElem "Over_Under" $
305 xpWrap (to_newtype, from_newtype) $
308 from_newtype (OddsOverUnder cs) = cs
309 to_newtype = OddsOverUnder
311 instance XmlPickler OddsOverUnder where
312 xpickle = pickle_over_under
315 pickle_game :: PU OddsGameXml
318 xpWrap (from_tuple, to_tuple) $
320 (xpElem "GameID" xpInt)
321 (xpElem "Game_Date" xpText)
322 (xpElem "Game_Time" xpText)
327 from_tuple = uncurryN OddsGameXml
328 -- Use record wildcards to avoid unused field warnings.
329 to_tuple OddsGameXml{..} = (xml_game_id,
336 instance XmlPickler OddsGameXml where
337 xpickle = pickle_game
340 pickle_message :: PU Message
343 xpWrap (from_tuple, to_tuple) $
344 xp8Tuple (xpElem "XML_File_ID" xpInt)
345 (xpElem "heading" xpText)
346 (xpElem "category" xpText)
347 (xpElem "sport" xpText)
348 (xpElem "Title" xpText)
349 (xpElem "Line_Time" xpText)
350 (xpList pickle_game_with_notes)
351 (xpElem "time_stamp" xpText)
353 from_tuple = uncurryN Message
354 to_tuple m = (xml_xml_file_id m,
360 xml_games_with_notes m,
364 instance XmlPickler Message where
365 xpickle = pickle_message
371 -- * Groundhog database schema.
372 mkPersist tsn_codegen_config [groundhog|
380 - name: unique_odds_casino
382 fields: [casino_client_id]
389 - name: unique_odds_team
399 - name: unique_odds_game
406 odds_tests :: TestTree
410 [ test_pickle_of_unpickle_is_identity,
411 test_unpickle_succeeds ]
414 -- | Warning, succeess of this test does not mean that unpickling
416 test_pickle_of_unpickle_is_identity :: TestTree
417 test_pickle_of_unpickle_is_identity =
418 testCase "pickle composed with unpickle is the identity" $ do
419 let path = "test/xml/Odds_XML.xml"
420 (expected :: [Message], actual) <- pickle_unpickle "message" path
424 test_unpickle_succeeds :: TestTree
425 test_unpickle_succeeds =
426 testCase "unpickling succeeds" $ do
427 let path = "test/xml/Odds_XML.xml"
428 actual <- unpickleable path pickle_message