From a53f1a77e6d24d8a4771be4dd365f2738c50bf6f Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 1 Jan 2014 20:08:28 -0500 Subject: [PATCH] Add TSN.XML.Odds which can (only, for the moment) parse Odds_XML.xml. --- src/Main.hs | 3 + src/TSN/XML/Odds.hs | 240 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 243 insertions(+) create mode 100644 src/TSN/XML/Odds.hs diff --git a/src/Main.hs b/src/Main.hs index 924a699..e8c1356 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -46,6 +46,7 @@ import qualified TSN.XML.Heartbeat as Heartbeat ( verify ) import qualified TSN.XML.Injuries as Injuries ( Listing ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( PlayerListing ) import qualified TSN.XML.News as News ( Message ) +import qualified TSN.XML.Odds as Odds ( Message ) import Xml ( DtdName(..), parse_opts ) @@ -154,6 +155,8 @@ import_file cfg path = do | dtd == "newsxml.dtd" = dbimport (undefined :: News.Message) + | dtd == "Odds_XML.dtd" = undefined + | otherwise = \_ -> do -- Dummy arg simplifies the other cases. let infomsg = "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs new file mode 100644 index 0000000..1cdba55 --- /dev/null +++ b/src/TSN/XML/Odds.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module TSN.XML.Odds ( + Message ) +where + + +-- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains +-- a root element \ that contains a bunch of other +-- unorganized crap. +-- + +import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf ) +import Data.List.Utils ( join, split ) +import Data.Tuple.Curry ( uncurryN ) +import Data.Typeable ( Typeable ) +import Database.Groundhog ( + defaultMigrationLogger, + insert, + migrate, + runMigration ) +import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.TH ( + groundhog, + mkPersist ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) +import Text.XML.HXT.Core ( + PU, + XmlPickler(..), + unpickleDoc, + xp5Tuple, + xp6Tuple, + xp11Tuple, + xpAttr, + xpElem, + xpInt, + xpList, + xpOption, + xpPair, + xpPrim, + xpText, + xpText0, + xpTriple, + xpWrap ) + +import TSN.Codegen ( + tsn_codegen_config, + tsn_db_field_namer ) +import TSN.DbImport ( DbImport(..), ImportResult(..) ) +import Xml ( ToFromXml(..), pickle_unpickle ) + + + +data OddsCasino = + OddsCasino { + xml_casino_client_id :: Int, + xml_casino_name :: String, + xml_casino_line :: Maybe Float } + deriving (Eq, Show) + +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] } + 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] } + deriving (Eq, Show) + +-- | Can't use a newtype with Groundhog. +data OddsOverUnder = + OddsOverUnder [OddsCasino] + 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 } + deriving (Eq, Show) + +data Message = Message + +data MessageXml = + MessageXml { + 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_time_stamp :: String } + deriving (Eq, Show) + + +pickle_casino :: PU OddsCasino +pickle_casino = + xpElem "Casino" $ + xpWrap (from_tuple, to_tuple) $ + xpTriple + (xpAttr "ClientID" xpInt) + (xpAttr "Name" xpText) + (xpOption xpPrim) + where + from_tuple = uncurryN OddsCasino + to_tuple (OddsCasino x y z) = (x, y, z) + +instance XmlPickler OddsCasino 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) + where + from_tuple = uncurryN OddsHomeTeam + to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z) + + +instance XmlPickler OddsHomeTeam where + xpickle = pickle_home_team + + +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) + where + from_tuple = uncurryN OddsAwayTeam + to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z) + + +instance XmlPickler OddsAwayTeam where + xpickle = pickle_away_team + + +pickle_over_under :: PU OddsOverUnder +pickle_over_under = + xpElem "Over_Under" $ + xpWrap (to_newtype, from_newtype) $ + xpList pickle_casino + where + from_newtype (OddsOverUnder cs) = cs + to_newtype = OddsOverUnder + +instance XmlPickler OddsOverUnder where + xpickle = pickle_over_under + + +pickle_game :: PU OddsGame +pickle_game = + xpElem "Game" $ + xpWrap (from_tuple, to_tuple) $ + xp6Tuple + (xpElem "GameID" xpPrim) + (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 + xpickle = pickle_game + + +pickle_message :: PU MessageXml +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) + where + from_tuple = uncurryN MessageXml + to_tuple m = undefined + + 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 + xpickle = pickle_message + -- 2.43.2