From: Michael Orlitzky Date: Fri, 10 Jan 2014 23:29:19 +0000 (-0500) Subject: Begin reworking TSN.XML.Odds for the new inferred DTDs. X-Git-Tag: 0.0.1~101 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=53c5550fee7f8a39a7906545978f15876a06fbd1;p=dead%2Fhtsn-import.git Begin reworking TSN.XML.Odds for the new inferred DTDs. --- diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index bbfff25..b053850 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} module TSN.XML.Odds ( + Odds, Message, odds_tests ) where @@ -41,7 +42,7 @@ import Text.XML.HXT.Core ( unpickleDoc, xp5Tuple, xp6Tuple, - xp11Tuple, + xp8Tuple, xpAttr, xpElem, xpInt, @@ -62,126 +63,188 @@ import Xml ( ToFromXml(..), pickle_unpickle, unpickleable ) -data OddsCasino = - OddsCasino { +data OddsCasinoXml = + OddsCasinoXml { xml_casino_client_id :: Int, xml_casino_name :: String, xml_casino_line :: Maybe Float } deriving (Eq, Show) +-- | The casinos should have their own table, but the lines don't +-- belong in that table. (There should be another table joining the +-- casinos and the thing the lines are for together.) +data OddsCasino = + OddsCasino { + db_casino_client_id :: Int, + db_casino_name :: String } + deriving (Eq, Show) + +instance ToFromXml OddsCasino where + type Xml OddsCasino = OddsCasinoXml + type Container OddsCasino = () -- It has one, but we don't use it. + + -- Use a record wildcard here so GHC doesn't complain that we never + -- used our named fields. + to_xml (OddsCasino {..}) = + OddsCasinoXml + db_casino_client_id + db_casino_name + def + + -- We don't need the key argument (from_xml_fk) since the XML type + -- contains more information in this case. + from_xml OddsCasinoXml{..} = + OddsCasino + xml_casino_client_id + xml_casino_name + data OddsHomeTeam = OddsHomeTeam { - xml_home_team_id :: Int, - xml_home_rotation_number :: Int, - xml_home_abbr :: String, - xml_home_team_name :: String, - xml_home_casinos :: [OddsCasino] } + home_team_id :: Int, + home_rotation_number :: Int, + home_abbr :: String, + home_team_name :: String, + home_casinos :: [OddsCasinoXml] } deriving (Eq, Show) data OddsAwayTeam = OddsAwayTeam { - xml_away_team_id :: Int, - xml_away_rotation_number :: Int, - xml_away_abbr :: String, - xml_away_team_name :: String, - xml_away_casinos :: [OddsCasino] } + away_team_id :: Int, + away_rotation_number :: Int, + away_abbr :: String, + away_team_name :: String, + away_casinos :: [OddsCasinoXml] } deriving (Eq, Show) -- | Can't use a newtype with Groundhog. data OddsOverUnder = - OddsOverUnder [OddsCasino] + OddsOverUnder [OddsCasinoXml] deriving (Eq, Show) data OddsGame = OddsGame { - xml_game_id :: Int, - xml_game_date :: String, -- TODO - xml_game_time :: String, -- TODO - xml_game_away_team :: OddsAwayTeam, - xml_game_home_team :: OddsHomeTeam, - xml_game_over_under :: OddsOverUnder } + game_id :: Int, + game_date :: String, -- TODO + game_time :: String, -- TODO + game_away_team :: OddsAwayTeam, + game_home_team :: OddsHomeTeam, + game_over_under :: OddsOverUnder } deriving (Eq, Show) -data Message = - Message { +data Odds = + Odds { db_sport :: String, db_title :: String, - db_line_time :: String, - db_notes1 :: String, - db_notes2 :: String } + db_line_time :: String } + +-- | This is our best guess at what occurs in the Odds_XML +-- documents. It looks like each consecutive set of games can +-- optionally have some notes appear before it. Each "note" comes as +-- its own ... element. +-- +-- The notes are ignored completely in the database; we only bother +-- with them to ensure that we're (un)pickling correctly. +-- +-- We can't group the notes with a "set" of 'OddsGame's, because that +-- leads to ambiguity in parsing. Since we're going to ignore the +-- notes anyway, we just stick them with an arbitrary game. C'est la +-- vie. +-- +data OddsGameWithNotes = + OddsGameWithNotes { + notes :: [String], + game :: OddsGame } + deriving (Eq, Show) -data MessageXml = - MessageXml { +-- | The XML representation of Odds. +data Message = + Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_title :: String, - xml_line_time :: String, -- The DTD goes crazy here. - xml_notes1 :: String, - xml_games1 :: [OddsGame], - xml_notes2 :: String, - xml_games2 :: [OddsGame], + xml_line_time :: String, + xml_games_with_notes :: [OddsGameWithNotes], xml_time_stamp :: String } deriving (Eq, Show) +-- | Pseudo-field that lets us get the 'OddsGame's out of +-- 'xml_games_with_notes'. +xml_games :: Message -> [OddsGame] +xml_games m = map game (xml_games_with_notes m) -instance ToFromXml Message where - type Xml Message = MessageXml - type Container Message = () +instance ToFromXml Odds where + type Xml Odds = Message + type Container Odds = () - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (Message {..}) = - MessageXml + -- Use record wildcards to avoid unused field warnings. + to_xml (Odds {..}) = + Message def def def db_sport db_title db_line_time - db_notes1 - def - db_notes2 def def -- We don't need the key argument (from_xml_fk) since the XML type -- contains more information in this case. - from_xml (MessageXml _ _ _ d e f g _ i _ _) = - Message d e f g i + from_xml (Message _ _ _ d e f _ _) = + Odds d e f + + +pickle_game_with_notes :: PU OddsGameWithNotes +pickle_game_with_notes = + xpWrap (from_pair, to_pair) $ + xpPair + (xpList $ xpElem "Notes" xpText) + pickle_game + where + from_pair = uncurry OddsGameWithNotes + to_pair OddsGameWithNotes{..} = (notes, game) + -pickle_casino :: PU OddsCasino +pickle_casino :: PU OddsCasinoXml pickle_casino = xpElem "Casino" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "ClientID" xpInt) (xpAttr "Name" xpText) - (xpOption xpPrim) + (xpOption xpPrim) -- Float where - from_tuple = uncurryN OddsCasino - to_tuple (OddsCasino x y z) = (x, y, z) + from_tuple = uncurryN OddsCasinoXml + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsCasinoXml{..} = (xml_casino_client_id, + xml_casino_name, + xml_casino_line) -instance XmlPickler OddsCasino where +instance XmlPickler OddsCasinoXml where xpickle = pickle_casino pickle_home_team :: PU OddsHomeTeam pickle_home_team = xpElem "HomeTeam" $ - xpWrap (from_tuple, to_tuple) $ - xp5Tuple - (xpElem "HomeTeamID" xpPrim) - (xpElem "HomeRotationNumber" xpPrim) - (xpElem "HomeAbbr" xpText) - (xpElem "HomeTeamName" xpText) - (xpList pickle_casino) + xpWrap (from_tuple, to_tuple) $ + xp5Tuple + (xpElem "HomeTeamID" xpInt) + (xpElem "HomeRotationNumber" xpInt) + (xpElem "HomeAbbr" xpText) + (xpElem "HomeTeamName" xpText) + (xpList pickle_casino) where from_tuple = uncurryN OddsHomeTeam - to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z) - + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsHomeTeam{..} = (home_team_id, + home_rotation_number, + home_abbr, + home_team_name, + home_casinos) instance XmlPickler OddsHomeTeam where xpickle = pickle_home_team @@ -190,16 +253,21 @@ instance XmlPickler OddsHomeTeam where pickle_away_team :: PU OddsAwayTeam pickle_away_team = xpElem "AwayTeam" $ - xpWrap (from_tuple, to_tuple) $ - xp5Tuple - (xpElem "AwayTeamID" xpPrim) - (xpElem "AwayRotationNumber" xpPrim) - (xpElem "AwayAbbr" xpText) - (xpElem "AwayTeamName" xpText) - (xpList pickle_casino) + xpWrap (from_tuple, to_tuple) $ + xp5Tuple + (xpElem "AwayTeamID" xpInt) + (xpElem "AwayRotationNumber" xpInt) + (xpElem "AwayAbbr" xpText) + (xpElem "AwayTeamName" xpText) + (xpList pickle_casino) where from_tuple = uncurryN OddsAwayTeam - to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z) + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsAwayTeam{..} = (away_team_id, + away_rotation_number, + away_abbr, + away_team_name, + away_casinos) instance XmlPickler OddsAwayTeam where @@ -224,7 +292,7 @@ pickle_game = xpElem "Game" $ xpWrap (from_tuple, to_tuple) $ xp6Tuple - (xpElem "GameID" xpPrim) + (xpElem "GameID" xpInt) (xpElem "Game_Date" xpText) (xpElem "Game_Time" xpText) pickle_away_team @@ -232,53 +300,43 @@ pickle_game = pickle_over_under where from_tuple = uncurryN OddsGame - to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z) + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsGame{..} = (game_id, + game_date, + game_time, + game_away_team, + game_home_team, + game_over_under) instance XmlPickler OddsGame where xpickle = pickle_game -pickle_message :: PU MessageXml +pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ - xp11Tuple (xpElem "XML_File_ID" xpPrim) - (xpElem "heading" xpText) - (xpElem "category" xpText) - (xpElem "sport" xpText) - (xpElem "Title" xpText) - (xpElem "Line_Time" xpText) - pickle_notes - (xpList pickle_game) - pickle_notes - (xpList pickle_game) - (xpElem "time_stamp" xpText) + xp8Tuple (xpElem "XML_File_ID" xpInt) + (xpElem "heading" xpText) + (xpElem "category" xpText) + (xpElem "sport" xpText) + (xpElem "Title" xpText) + (xpElem "Line_Time" xpText) + (xpList $ pickle_game_with_notes) + (xpElem "time_stamp" xpText) where - from_tuple = uncurryN MessageXml + from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, xml_heading m, xml_category m, xml_sport m, xml_title m, xml_line_time m, - xml_notes1 m, - xml_games1 m, - xml_notes2 m, - xml_games2 m, + xml_games_with_notes m, xml_time_stamp m) - pickle_notes :: PU String - pickle_notes = - xpWrap (to_string, from_string) $ - xpList (xpElem "Notes" xpText) - where - from_string :: String -> [String] - from_string = split "\n" - - to_string :: [String] -> String - to_string = join "\n" -instance XmlPickler MessageXml where +instance XmlPickler Message where xpickle = pickle_message @@ -301,7 +359,7 @@ test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/Odds_XML.xml" - (expected :: [MessageXml], actual) <- pickle_unpickle "message" path + (expected :: [Message], actual) <- pickle_unpickle "message" path actual @?= expected