Add TSN.XML.Odds which can (only, for the moment) parse Odds_XML.xml.

diff --git a/src/Main.hs b/src/Main.hs
index 924a699674c27b118ae57783af1467cc18ce361a..e8c1356b6dd40234046b9f8f44be4188f8f6c4b4 100644 (file)
--- 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 (file)
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 \<message\> 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
+