]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blobdiff - src/TSN/XML/Odds.hs
Begin reworking TSN.XML.Odds for the new inferred DTDs.
[dead/htsn-import.git] / src / TSN / XML / Odds.hs
index 1cdba551b42225e84da5b3e1c7ae425c7a02e05e..b05385071482346406cfd936e6346048e10e6c5c 100644 (file)
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -10,7 +9,9 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module TSN.XML.Odds (
-  Message )
+  Odds,
+  Message,
+  odds_tests )
 where
 
 
@@ -32,6 +33,7 @@ import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
+import System.Console.CmdArgs.Default ( Default(..) )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
@@ -40,7 +42,7 @@ import Text.XML.HXT.Core (
   unpickleDoc,
   xp5Tuple,
   xp6Tuple,
-  xp11Tuple,
+  xp8Tuple,
   xpAttr,
   xpElem,
   xpInt,
@@ -57,98 +59,192 @@ import TSN.Codegen (
   tsn_codegen_config,
   tsn_db_field_namer )
 import TSN.DbImport ( DbImport(..), ImportResult(..) )
-import Xml ( ToFromXml(..), pickle_unpickle )
+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 }
 
-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 <Notes>...</Notes> 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)
+
+-- | 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 Odds where
+  type Xml Odds = Message
+  type Container Odds = ()
+
+  -- Use record wildcards to avoid unused field warnings.
+  to_xml (Odds {..}) =
+    Message
+      def
+      def
+      def
+      db_sport
+      db_title
+      db_line_time
+      def
+      def
+
+  -- We don't need the key argument (from_xml_fk) since the XML type
+  -- contains more information in this case.
+  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
@@ -157,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
@@ -191,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
@@ -199,42 +300,73 @@ 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
-    to_tuple m = undefined
+    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_games_with_notes m,
+                  xml_time_stamp m)
+
+
+instance XmlPickler Message where
+  xpickle = pickle_message
 
-    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
 
+
+
+-- * Tasty Tests
+odds_tests :: TestTree
+odds_tests =
+  testGroup
+    "Odds tests"
+    [ test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+
+-- | Warning, succeess of this test does not mean that unpickling
+--   succeeded.
+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 :: [Message], actual) <- pickle_unpickle "message" path
+    actual @?= expected
+
+
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+  testCase "unpickling succeeds" $ do
+  let path = "test/xml/Odds_XML.xml"
+  actual <- unpickleable path pickle_message
+  let expected = True
+  actual @?= expected