]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - Odds.hs
7143c459a4d9fbba182d9ef877c259d6ace59e45
[dead/htsn-import.git] / 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