1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 {-# 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 System.Console.CmdArgs.Default ( Default(..) )
36 import Test.Tasty ( TestTree, testGroup )
37 import Test.Tasty.HUnit ( (@?=), testCase )
38 import Text.XML.HXT.Core (
60 import TSN.DbImport ( DbImport(..), ImportResult(..) )
61 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
67 xml_casino_client_id :: Int,
68 xml_casino_name :: String,
69 xml_casino_line :: Maybe Float }
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] }
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] }
90 -- | Can't use a newtype with Groundhog.
92 OddsOverUnder [OddsCasino]
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 }
109 db_line_time :: String,
111 db_notes2 :: String }
115 xml_xml_file_id :: Int,
116 xml_heading :: String,
117 xml_category :: 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 }
129 instance ToFromXml Message where
130 type Xml Message = MessageXml
131 type Container Message = ()
133 -- Use a record wildcard here so GHC doesn't complain that we never
134 -- used our named fields.
135 to_xml (Message {..}) =
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 _ _) =
155 pickle_casino :: PU OddsCasino
158 xpWrap (from_tuple, to_tuple) $
160 (xpAttr "ClientID" xpInt)
161 (xpAttr "Name" xpText)
164 from_tuple = uncurryN OddsCasino
165 to_tuple (OddsCasino x y z) = (x, y, z)
167 instance XmlPickler OddsCasino where
168 xpickle = pickle_casino
171 pickle_home_team :: PU OddsHomeTeam
174 xpWrap (from_tuple, to_tuple) $
176 (xpElem "HomeTeamID" xpPrim)
177 (xpElem "HomeRotationNumber" xpPrim)
178 (xpElem "HomeAbbr" xpText)
179 (xpElem "HomeTeamName" xpText)
180 (xpList pickle_casino)
182 from_tuple = uncurryN OddsHomeTeam
183 to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z)
186 instance XmlPickler OddsHomeTeam where
187 xpickle = pickle_home_team
190 pickle_away_team :: PU OddsAwayTeam
193 xpWrap (from_tuple, to_tuple) $
195 (xpElem "AwayTeamID" xpPrim)
196 (xpElem "AwayRotationNumber" xpPrim)
197 (xpElem "AwayAbbr" xpText)
198 (xpElem "AwayTeamName" xpText)
199 (xpList pickle_casino)
201 from_tuple = uncurryN OddsAwayTeam
202 to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z)
205 instance XmlPickler OddsAwayTeam where
206 xpickle = pickle_away_team
209 pickle_over_under :: PU OddsOverUnder
211 xpElem "Over_Under" $
212 xpWrap (to_newtype, from_newtype) $
215 from_newtype (OddsOverUnder cs) = cs
216 to_newtype = OddsOverUnder
218 instance XmlPickler OddsOverUnder where
219 xpickle = pickle_over_under
222 pickle_game :: PU OddsGame
225 xpWrap (from_tuple, to_tuple) $
227 (xpElem "GameID" xpPrim)
228 (xpElem "Game_Date" xpText)
229 (xpElem "Game_Time" xpText)
234 from_tuple = uncurryN OddsGame
235 to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z)
237 instance XmlPickler OddsGame where
238 xpickle = pickle_game
241 pickle_message :: PU MessageXml
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)
255 (xpElem "time_stamp" xpText)
257 from_tuple = uncurryN MessageXml
258 to_tuple m = (xml_xml_file_id m,
270 pickle_notes :: PU String
272 xpWrap (to_string, from_string) $
273 xpList (xpElem "Notes" xpText)
275 from_string :: String -> [String]
276 from_string = split "\n"
278 to_string :: [String] -> String
279 to_string = join "\n"
281 instance XmlPickler MessageXml where
282 xpickle = pickle_message
290 odds_tests :: TestTree
294 [ test_pickle_of_unpickle_is_identity,
295 test_unpickle_succeeds ]
298 -- | Warning, succeess of this test does not mean that unpickling
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
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