X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=a4fddb97f81597dd35676d37820eba968ced3062;hb=c792c3bb79e83b5bb8d65984de51f2416b7a2d8e;hp=bbfff251a8874f5d84bceac38a935df7a50c989c;hpb=bbe8b110b9468b022457457af808af678e1927f9;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index bbfff25..a4fddb9 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, @@ -58,151 +59,243 @@ import TSN.Codegen ( tsn_codegen_config, tsn_db_field_namer ) import TSN.DbImport ( DbImport(..), ImportResult(..) ) -import Xml ( ToFromXml(..), pickle_unpickle, unpickleable ) +import TSN.XmlImport ( XmlImport(..) ) +import Xml ( FromXml(..), 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) -data OddsHomeTeam = - OddsHomeTeam { + +-- | 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 { + casino_client_id :: Int, + casino_name :: String } + deriving (Eq, Show) + +instance FromXml OddsCasinoXml where + type Db OddsCasinoXml = OddsCasino + + -- 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 + +instance XmlImport OddsCasinoXml + + +data OddsHomeTeamXml = + OddsHomeTeamXml { xml_home_team_id :: Int, xml_home_rotation_number :: Int, xml_home_abbr :: String, xml_home_team_name :: String, - xml_home_casinos :: [OddsCasino] } + xml_home_casinos :: [OddsCasinoXml] } + deriving (Eq, Show) + +instance FromXml OddsHomeTeamXml where + type Db OddsHomeTeamXml = OddsTeam + from_xml OddsHomeTeamXml{..} = OddsTeam + xml_home_team_id + xml_home_abbr + xml_home_team_name + +instance XmlImport OddsHomeTeamXml where + + +data OddsTeam = + OddsTeam { + db_team_id :: Int, + db_abbr :: String, + db_team_name :: String } deriving (Eq, Show) -data OddsAwayTeam = - OddsAwayTeam { +data OddsAwayTeamXml = + OddsAwayTeamXml { xml_away_team_id :: Int, xml_away_rotation_number :: Int, xml_away_abbr :: String, xml_away_team_name :: String, - xml_away_casinos :: [OddsCasino] } + xml_away_casinos :: [OddsCasinoXml] } deriving (Eq, Show) +instance FromXml OddsAwayTeamXml where + type Db OddsAwayTeamXml = OddsTeam + from_xml OddsAwayTeamXml{..} = OddsTeam + xml_away_team_id + xml_away_abbr + xml_away_team_name + +instance XmlImport OddsAwayTeamXml where + -- | Can't use a newtype with Groundhog. data OddsOverUnder = - OddsOverUnder [OddsCasino] + OddsOverUnder [OddsCasinoXml] deriving (Eq, Show) data OddsGame = OddsGame { + db_game_id :: Int, + db_game_date :: String, -- TODO + db_game_time :: String, -- TODO + db_game_away_team_id :: DefaultKey OddsTeam, + db_game_away_team_rotation_number :: Int, + db_game_home_team_id :: DefaultKey OddsTeam, + db_game_home_team_rotation_number :: Int } +deriving instance Eq OddsGame +deriving instance Show OddsGame + +data OddsGameXml = + OddsGameXml { 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_away_team :: OddsAwayTeamXml, + xml_game_home_team :: OddsHomeTeamXml, xml_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 } -data MessageXml = - MessageXml { +-- | 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 :: OddsGameXml } + deriving (Eq, Show) + +-- | 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 -> [OddsGameXml] +xml_games m = map game (xml_games_with_notes m) -instance ToFromXml Message where - type Xml Message = MessageXml - type Container Message = () - - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (Message {..}) = - MessageXml - def - def - def - db_sport - db_title - db_line_time - db_notes1 - def - db_notes2 - def - def +instance FromXml Message where + type Db Message = Odds -- 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 + +instance XmlImport Message +instance DbImport Message where + dbmigrate _= undefined + dbimport = undefined -pickle_casino :: PU OddsCasino +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 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 :: PU OddsHomeTeamXml 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) - - -instance XmlPickler OddsHomeTeam where + from_tuple = uncurryN OddsHomeTeamXml + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsHomeTeamXml{..} = (xml_home_team_id, + xml_home_rotation_number, + xml_home_abbr, + xml_home_team_name, + xml_home_casinos) + +instance XmlPickler OddsHomeTeamXml where xpickle = pickle_home_team -pickle_away_team :: PU OddsAwayTeam +pickle_away_team :: PU OddsAwayTeamXml 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) + from_tuple = uncurryN OddsAwayTeamXml + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsAwayTeamXml{..} = (xml_away_team_id, + xml_away_rotation_number, + xml_away_abbr, + xml_away_team_name, + xml_away_casinos) -instance XmlPickler OddsAwayTeam where +instance XmlPickler OddsAwayTeamXml where xpickle = pickle_away_team @@ -219,72 +312,95 @@ instance XmlPickler OddsOverUnder where xpickle = pickle_over_under -pickle_game :: PU OddsGame +pickle_game :: PU OddsGameXml 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 pickle_home_team pickle_over_under where - from_tuple = uncurryN OddsGame - to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z) - -instance XmlPickler OddsGame where + from_tuple = uncurryN OddsGameXml + -- Use record wildcards to avoid unused field warnings. + to_tuple OddsGameXml{..} = (xml_game_id, + xml_game_date, + xml_game_time, + xml_game_away_team, + xml_game_home_team, + xml_game_over_under) + +instance XmlPickler OddsGameXml 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 +-- * Groundhog database schema. +mkPersist tsn_codegen_config [groundhog| +- entity: Odds + +- entity: OddsCasino + dbName: odds_casinos + constructors: + - name: OddsCasino + uniques: + - name: unique_odds_casino + type: constraint + fields: [casino_client_id] + +- entity: OddsTeam + dbName: odds_teams + constructors: + - name: OddsTeam + uniques: + - name: unique_odds_team + type: constraint + fields: [db_team_id] + + +- entity: OddsGame + dbName: odds_games + constructors: + - name: OddsGame + uniques: + - name: unique_odds_game + type: constraint + fields: [db_game_id] +|] + -- * Tasty Tests odds_tests :: TestTree @@ -301,7 +417,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