1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE TemplateHaskell #-}
10 {-# LANGUAGE TypeFamilies #-}
17 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
18 -- a root element \<message\> that contains a bunch of other
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,
31 import Database.Groundhog.Core ( DefaultKey )
32 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
59 import TSN.DbImport ( DbImport(..), ImportResult(..) )
60 import Xml ( ToFromXml(..), pickle_unpickle )
66 xml_casino_client_id :: Int,
67 xml_casino_name :: String,
68 xml_casino_line :: Maybe Float }
73 xml_home_team_id :: Int,
74 xml_home_rotation_number :: Int,
75 xml_home_abbr :: String,
76 xml_home_team_name :: String,
77 xml_home_casinos :: [OddsCasino] }
82 xml_away_team_id :: Int,
83 xml_away_rotation_number :: Int,
84 xml_away_abbr :: String,
85 xml_away_team_name :: String,
86 xml_away_casinos :: [OddsCasino] }
89 -- | Can't use a newtype with Groundhog.
91 OddsOverUnder [OddsCasino]
97 xml_game_date :: String, -- TODO
98 xml_game_time :: String, -- TODO
99 xml_game_away_team :: OddsAwayTeam,
100 xml_game_home_team :: OddsHomeTeam,
101 xml_game_over_under :: OddsOverUnder }
104 data Message = Message
108 xml_xml_file_id :: Int,
109 xml_heading :: String,
110 xml_category :: String,
113 xml_line_time :: String, -- The DTD goes crazy here.
114 xml_notes1 :: String,
115 xml_games1 :: [OddsGame],
116 xml_notes2 :: String,
117 xml_games2 :: [OddsGame],
118 xml_time_stamp :: String }
122 pickle_casino :: PU OddsCasino
125 xpWrap (from_tuple, to_tuple) $
127 (xpAttr "ClientID" xpInt)
128 (xpAttr "Name" xpText)
131 from_tuple = uncurryN OddsCasino
132 to_tuple (OddsCasino x y z) = (x, y, z)
134 instance XmlPickler OddsCasino where
135 xpickle = pickle_casino
138 pickle_home_team :: PU OddsHomeTeam
141 xpWrap (from_tuple, to_tuple) $
143 (xpElem "HomeTeamID" xpPrim)
144 (xpElem "HomeRotationNumber" xpPrim)
145 (xpElem "HomeAbbr" xpText)
146 (xpElem "HomeTeamName" xpText)
147 (xpList pickle_casino)
149 from_tuple = uncurryN OddsHomeTeam
150 to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z)
153 instance XmlPickler OddsHomeTeam where
154 xpickle = pickle_home_team
157 pickle_away_team :: PU OddsAwayTeam
160 xpWrap (from_tuple, to_tuple) $
162 (xpElem "AwayTeamID" xpPrim)
163 (xpElem "AwayRotationNumber" xpPrim)
164 (xpElem "AwayAbbr" xpText)
165 (xpElem "AwayTeamName" xpText)
166 (xpList pickle_casino)
168 from_tuple = uncurryN OddsAwayTeam
169 to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z)
172 instance XmlPickler OddsAwayTeam where
173 xpickle = pickle_away_team
176 pickle_over_under :: PU OddsOverUnder
178 xpElem "Over_Under" $
179 xpWrap (to_newtype, from_newtype) $
182 from_newtype (OddsOverUnder cs) = cs
183 to_newtype = OddsOverUnder
185 instance XmlPickler OddsOverUnder where
186 xpickle = pickle_over_under
189 pickle_game :: PU OddsGame
192 xpWrap (from_tuple, to_tuple) $
194 (xpElem "GameID" xpPrim)
195 (xpElem "Game_Date" xpText)
196 (xpElem "Game_Time" xpText)
201 from_tuple = uncurryN OddsGame
202 to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z)
204 instance XmlPickler OddsGame where
205 xpickle = pickle_game
208 pickle_message :: PU MessageXml
211 xpWrap (from_tuple, to_tuple) $
212 xp11Tuple (xpElem "XML_File_ID" xpPrim)
213 (xpElem "heading" xpText)
214 (xpElem "category" xpText)
215 (xpElem "sport" xpText)
216 (xpElem "Title" xpText)
217 (xpElem "Line_Time" xpText)
219 (xpList $ pickle_game)
221 (xpList $ pickle_game)
222 (xpElem "time_stamp" xpText)
224 from_tuple = uncurryN MessageXml
225 to_tuple m = undefined
227 pickle_notes :: PU String
229 xpWrap (to_string, from_string) $
230 (xpList $ xpElem "Notes" xpText)
232 from_string :: String -> [String]
233 from_string = split "\n"
235 to_string :: [String] -> String
236 to_string = join "\n"
238 instance XmlPickler MessageXml where
239 xpickle = pickle_message