diff --git a/doc/dbschema/game_info.png b/doc/dbschema/game_info.png Binary files a/doc/dbschema/game_info.png and b/doc/dbschema/game_info.png differ diff --git a/htsn-import.cabal b/htsn-import.cabal --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -1,5 +1,5 @@ name: htsn-import -version: 0.0.9 +version: 0.1.0 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky diff --git a/schema/Matchup_NBA_NHL_XML.dtd b/schema/Matchup_NBA_NHL_XML.dtd --- a/schema/Matchup_NBA_NHL_XML.dtd +++ b/schema/Matchup_NBA_NHL_XML.dtd @@ -1,42 +1,31 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/schemagen/Matchup_NBA_NHL_XML/20901524.xml b/schemagen/Matchup_NBA_NHL_XML/20901524.xml new file mode 100644 --- /dev/null +++ b/schemagen/Matchup_NBA_NHL_XML/20901524.xml @@ -0,0 +1,1 @@ +20901524ADX%MATCHUP-CLB-TAMStatisticsNHL1882718827ColumbusTampa Bay148144NHL Matchup - Columbus at Tampa BayColumbus Blue Jackets (42-31-7) at Tampa Bay Lightning (44-27-9), 7:30 p.m.Columbus 2-0 (2-0 at Clb; 0-0 at TB)NoneTampa Bay 2-0 (1-0 at Clb; 1-0 at TB)Tampa Bay 1-0 (0-0 at Clb; 1-0 at TB)Columbus 22-15-4; Tampa Bay 24-10-6Columbus 20-16-3; Tampa Bay 20-17-3Columbus 13-7-2Tampa Bay 11-8-3Columbus 29-20-3; Tampa Bay 30-16-612/03 - Columbus, 1-0 (at Clb)01/13 - Columbus, 3-2 (at Clb)12/17 - Tampa Bay, 3-2 (at Clb)01/24 - Tampa Bay, 4-2 (at TB)01/18 - Tampa Bay, 3-2 so (at TB)03/30 - Columbus, 3-2 (at Clb)03/24 - Tampa Bay, 2-1 ot (at TB)03/09 - Columbus, 5-3 (at Clb)01/13 - Tampa Bay, 4-2 (at TB)10/23 - Tampa Bay, 1-0 (at Clb)01/02 - Columbus, 2-0 (at TB)10/23 - Tied, 2-2 ot (at Clb)12/06 - Tampa Bay, 1-0 (at TB)Columbus has won three straight and six of its last seven road games.Tampa Bay is 14-1-2 when leading after two periods at home this season.Columbus has won two straight after losing the last three meetings.Tampa Bay has won four of seven and five of the last nine meetings.Tampa Bay is 8-5-1 in the last 14 meetings.Columbus has lost four straight at Tampa Bay.Columbus has lost six of the seven meetings at Tampa Bay.Tampa Bay has lost two straight and four of its last five at Columbus.Tampa Bay is 2-5-1 in the eight meetings at Columbus.04/03 - W at Philadelphia, 2-004/04 - L vs. Chicago, 3-404/06 - W vs. NY Islanders, 4-004/08 - W vs. Phoenix, 4-3 (OT)04/09 - W at Dallas, 3-104/01 - W vs. Montreal, 3-104/03 - L vs. Calgary, 1-404/05 - L vs. Dallas, 2-504/08 - W vs. Toronto, 3-004/10 - W vs. Philadelphia, 4-2 April 11, 2014, at 12:20 PM ET diff --git a/schemagen/Matchup_NBA_NHL_XML/Matchup_NBA_NHL_XML.xml b/schemagen/Matchup_NBA_NHL_XML/Matchup_NBA_NHL_XML.xml deleted file mode 100644 --- a/schemagen/Matchup_NBA_NHL_XML/Matchup_NBA_NHL_XML.xml +++ /dev/null @@ -1,139 +0,0 @@ - - - -235677 -ADX%MATCHUP-COL-VAN -Statistics -NHL -NHL Matchup - Colorado at Vancouver - -Colorado Avalanche (34-17-12-5) at Vancouver Canucks (36-20-8-4), 10 p.m. - - -Vancouver 2-1-2 (2-0-1 at Col; 0-1-1 at Van) - - -Vancouver 3-2 (1-1 at Col; 2-1 at Van) - - -Colorado 3-2 (2-1 at Col; 1-1 at Van) - - -Colorado 3-2 (2-0 at Col; 1-2 at Van) - -Colorado 17-13-5-1; Vancouver 17-10-5-0 -Colorado 17-4-7-4; Vancouver 19-10-3-4 - - -Colorado 10-7-4-0; Vancouver 8-6-5-1 - -Colorado 26-13-9-5; Vancouver 27-16-7-1 - - -12/11 - Tied, 1-1 ot (at Van) -12/29 - Vancouver, 3-2 (at Col) -01/02 - Colorado, 4-2 (at Van) -02/16 - Vancouver, 1-0 (at Col) -03/03 - Tied, 5-5 ot (at Col) - - -10/31 - Colorado, 5-1 (at Van) -11/04 - Vancouver, 4-2 (at Col) -12/11 - Vancouver, 3-1 (at Van) -12/23 - Colorado, 5-3 (at Col) -02/13 - Vancouver, 2-1 ot (at Van) - - -10/09 - Colorado, 5-4 (at Col) -10/13 - Vancouver, 4-0 (at Van) -10/25 - Colorado, 4-1 (at Col) -11/30 - Colorado, 5-2 (at Van) -04/09 - Vancouver, 2-1 (at Col) - - - -Vancouver is unbeaten (1-0-1) in the last two meetings. - - -Vancouver is 3-1-2 in the last six meetings. - - -Vancouver is 5-2-2 in the last nine and 6-3-2 in the last 11 meetings. - - -Vancouver is 7-6-2 in the last 15 meetings. - - -These two teams are 9-9-2 in the last 20 meetings. - - -Colorado is 15-10-4 in the last 29 meetings. - - -Colorado snapped a three-game series road winless streak on 01/02/04. - - -Colorado is unbeaten (1-0-1) in its last two at Vancouver. - - -Colorado is 1-2-1 in its last four at Vancouver. - - -Colorado is 3-2-1 in its last six at Vancouver. - - -Colorado is 3-5-1 in its last nine at Vancouver. - - -Colorado is 7-5-2 in its last 14 at Vancouver. - - -Vancouver is unbeaten (2-0-1) in its last three at Colorado. - - -Vancouver is 4-1-1 in its last six at Colorado. - - -Vancouver is 4-5-1 in its last 10 and 5-8-2 in its last 15 at Colorado. - - -Vancouver is 6-13-4 in its last 23 at Colorado. - - -Colorado is 1-3-2-1 in its last seven and 2-6-2-1 in its last 11 games. - - -Colorado is 8-1-2-2 in its last 13 road games. - - -Colorado is 23-2-3 when leading after two periods this season. - - -Vancouver is 4-1-1 in its last six and 5-2-1-1 in its last nine games. - - -Vancouver has won three straight after losing its last three home games. - - -Vancouver has won six of its last nine home games. - - -Vancouver is 22-2-0 when leading after two periods this season. - - - -02/28 - L at Columbus, 4-5 ot -03/01 - L vs. Tampa Bay, 0-3 -03/03 - T vs. Vancouver, 5-5 ot -03/05 - W vs. San Jose, 5-1 -03/07 - L vs. Calgary, 1-7 - - -02/26 - W vs. San Jose, 3-2 ot -02/28 - W vs. St. Louis, 2-0 -03/03 - T at Colorado, 5-5 ot -03/05 - L at Detroit, 1-3 -03/06 - W at Columbus, 4-0 - - March 8, 2004, at 12:51 PM ET - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -45,6 +45,7 @@ report_info, report_error ) import TSN.DbImport ( DbImport(..), ImportResult(..) ) +import TSN.Parse ( format_parse_error ) import qualified TSN.XML.AutoRacingResults as AutoRacingResults ( dtd, pickle_message ) @@ -250,7 +251,7 @@ case either_m of -- This might give us a slightly better error -- message than the default 'errmsg'. - Left err -> return $ ImportFailed err + Left err -> return $ ImportFailed (format_parse_error err) Right m -> migrate_and_import m | dtd `elem` SportInfo.dtds = do @@ -258,7 +259,7 @@ case either_m of -- This might give us a slightly better error -- message than the default 'errmsg'. - Left err -> return $ ImportFailed err + Left err -> return $ ImportFailed (format_parse_error err) Right m -> migrate_and_import m | otherwise = do diff --git a/src/TSN/Parse.hs b/src/TSN/Parse.hs --- a/src/TSN/Parse.hs +++ b/src/TSN/Parse.hs @@ -1,5 +1,10 @@ module TSN.Parse ( + ParseError, + format_parse_error, + parse_game_id, parse_message, + parse_schedule_id, + parse_tests, parse_time_stamp, parse_xml_time_stamp, parse_xmlfid, @@ -11,6 +16,8 @@ import Data.Time.Clock ( UTCTime ) import Data.Time.Format ( parseTime ) import System.Locale ( defaultTimeLocale ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) import Text.Read ( readMaybe ) import Text.XML.HXT.Core ( XmlTree, @@ -21,17 +28,49 @@ hasName, runLA ) +-- Local imports +import Xml ( unsafe_read_document ) --- | Parse the \"message\" element out of a document tree and return --- it as an 'XmlTree'. We use an Either for consistency. + +-- | When parsing an element from an XML document (like the +-- XML_File_ID), there are a few things that can happen. First of +-- all, it can work. Good for you. -- --- Note: It's more trouble than it's worth to attempt to use this as --- the basis for parse_xmlfid and parse_xml_time_stamp. +-- Or, you may find nothing. Like, the element is missing. We +-- represent that with a 'ParseNotFound' containing the name of +-- thing thing not-found as a 'String'. -- -parse_message :: XmlTree -> Either String XmlTree +-- Finally, you could find something, but be unable to interpret it +-- as the type you were expecting. For example, if you parse +-- \"WHATSUP\" out of a \ which is supposed to contain +-- integers. We represent this case with a 'ParseMismatch' +-- containing the name of the thing that you were looking for, the +-- value that had the unexpected type, and finally the name of the +-- expected type (used in error messages). +-- +data ParseError = + ParseNotFound String | ParseMismatch String String String + deriving (Eq, Show) + + +-- | Take a 'ParseError' and turn it into a human-readable description +-- of the problem. +-- +format_parse_error :: ParseError -> String +format_parse_error (ParseNotFound item) = + "No " ++ item ++ " elements found." +format_parse_error (ParseMismatch item val expected_type) = + "Could not parse " ++ item ++ " " ++ val ++ " as " ++ expected_type ++ "." + + + +-- | Parse the \"message\" element out of a document tree and return +-- it as an 'XmlTree'. We use an 'Either' for consistency. +-- +parse_message :: XmlTree -> Either ParseError XmlTree parse_message xmltree = case elements of - [] -> Left "No message elements found." + [] -> Left $ ParseNotFound "message" (x:_) -> Right x where parse :: XmlTree -> [XmlTree] @@ -41,55 +80,110 @@ --- | Extract the \"XML_File_ID\" element from a document. If we fail --- to parse an XML_File_ID, we return the reason wrapped in a 'Left' --- constructor. The reason should be one of two things: --- --- 1. No XML_File_ID elements were found. --- --- 2. An XML_File_ID element was found, but it could not be read --- into an Integer. --- --- We use an Either rather than a Maybe because we do expect some --- non-integer XML_File_IDs. In the examples, you will see --- NHL_DepthChart_XML.XML with an XML_File_ID of \"49618.61\" and --- CFL_Boxscore_XML1.xml with an XML_File_ID of --- \"R28916\". According to Brijesh Patel of TSN, these are special --- category files and not part of the usual feed. + + +-- | Parse an 'Int' from a direct descendent of the (top-level) +-- \ element in an XmlTree. This is used to implement the +-- XML_File_ID, game_id, and schedule_id (the last two are specific +-- to "TSN.XML.GameInfo") parsers. -- --- TODO: This should eventually be combined with XML.parse_xmlfid --- from the htsn package. +-- If the parse fails, we return the corresponding 'ParseError' +-- wrapped in a 'Left'. Otherwise the parsed value is returned in a +-- 'Right'. -- -parse_xmlfid :: XmlTree -> Either String Integer -parse_xmlfid xmltree = +parse_message_int :: String -> XmlTree -> Either ParseError Int +parse_message_int child xmltree = case parse_results of - [] -> Left "No XML_File_ID elements found." + [] -> Left $ ParseNotFound child (x:_) -> x where parse :: XmlTree -> [String] parse = runLA $ hasName "/" /> hasName "message" - /> hasName "XML_File_ID" + /> hasName child >>> getChildren >>> getText - read_either_integer :: String -> Either String Integer - read_either_integer s = - let msg = "Could not parse XML_File_ID " ++ s ++ " as an integer." - in - maybeToEither msg (readMaybe s) + read_either_int :: String -> Either ParseError Int + read_either_int s = + maybeToEither (ParseMismatch child s "integer") (readMaybe s) elements = parse xmltree - parse_results = map read_either_integer elements + parse_results = map read_either_int elements +-- | Parse an optional 'Int' from a direct descendent of the +-- (top-level) \ element in an XmlTree. This is just like +-- 'parse_message_int', except we expect the element/value to be +-- missing sometimes. +-- +-- To handle the fact that the element/value is optional, we pattern +-- match on the 'ParseError' that comes back in case of failure. If +-- we didn't find anything, we turn that into a \"successful +-- nothing\". But if we find a value and it can't be parsed, we let +-- the error propagate, because that shouldn't happen. Of course, if +-- the parse worked, that's nice too: we wrap the parsed value in a +-- 'Just' and return that wrapped in a 'Right' +-- +parse_message_int_optional :: String + -> XmlTree + -> Either ParseError (Maybe Int) +parse_message_int_optional child xmltree = + case (parse_message_int child xmltree) of + Left (ParseNotFound _) -> Right Nothing + Left pm@(ParseMismatch {}) -> Left pm + Right whatever -> Right (Just whatever) + + + +-- | Extract the \"XML_File_ID\" element from a document. If we fail +-- to parse an XML_File_ID, we return an appropriate 'ParseError' +-- wrapped in a 'Left' constructor. The reason should be one of two +-- things: +-- +-- 1. No XML_File_ID elements were found. +-- +-- 2. An XML_File_ID element was found, but it could not be read +-- into an Int. +-- +-- In general we expect some non-integer XML_File_IDs, because they +-- appear on the feed. But the htsn daemon refuses to save them at +-- the moment, so if we ever see an XML_File_ID that we can't parse, +-- it's truly an error. +-- +parse_xmlfid :: XmlTree -> Either ParseError Int +parse_xmlfid = parse_message_int "XML_File_ID" + + + +-- | Extract the \ element from within the top-level +-- \ of a document. These appear in the "TSN.XML.GameInfo" +-- documents. Unlike the \ elements, the \ +-- can be missing from GameInfo documents, so for our implementation +-- we use 'parse_message_int_optional' instead. +-- +parse_game_id :: XmlTree -> Either ParseError (Maybe Int) +parse_game_id = parse_message_int_optional "game_id" + + + +-- | Extract the \ element from within the top-level +-- \ of a document. Identical to 'parse_game_id' except +-- for the element name. +-- +parse_schedule_id :: XmlTree -> Either ParseError (Maybe Int) +parse_schedule_id = parse_message_int_optional "schedule_id" + + + -- | The format string for times appearing in the feed. -- time_format :: String time_format = "%I:%M %p" + -- | The format string for a time_stamp. We keep the leading/trailing -- space so that parseTime and formatTime are inverses are one -- another, even though there is some confusion as to how these two @@ -112,23 +206,23 @@ --- | Extract the \"time_stamp\" element from a document. If we fail --- to parse a time_stamp, we return the reason wrapped in a 'Left' --- constructor. The reason should be one of two things: +-- | Extract the \"time_stamp\" element from a document. If we fail to +-- parse a time_stamp, we return an appropriate 'ParseError'. The +-- reason should be one of two things: -- -- 1. No time_Stamp elements were found. -- -- 2. A time_stamp element was found, but it could not be read -- into a UTCTime. -- --- Unline 'parse_xmlfid', we don't expect to run into any time_stamps --- that we can't parse. But since parse_xmlfid returns an Either, we --- do for consistency. +-- We don't expect to run into any time_stamps that we can't parse, +-- and they can never be missing, so both conditions are truly +-- errors. -- -parse_xml_time_stamp :: XmlTree -> Either String UTCTime +parse_xml_time_stamp :: XmlTree -> Either ParseError UTCTime parse_xml_time_stamp xmltree = case parse_results of - [] -> Left "No time_stamp elements found." + [] -> Left $ ParseNotFound "time_stamp" (x:_) -> x where parse :: XmlTree -> [String] @@ -138,11 +232,88 @@ >>> getChildren >>> getText - read_either_utctime :: String -> Either String UTCTime + read_either_utctime :: String -> Either ParseError UTCTime read_either_utctime s = - let msg = "Could not parse time_stamp " ++ s ++ " as a date/time." - in - maybeToEither msg (parse_time_stamp s) + maybeToEither (ParseMismatch "time_stamp" s "date/time") + (parse_time_stamp s) elements = parse xmltree parse_results = map read_either_utctime elements + + + +-- +-- * Tests +-- + +-- | A list of all tests for this module. +-- +parse_tests :: TestTree +parse_tests = + testGroup + "TSN.Parse tests" + [ test_parse_game_id, + test_parse_missing_game_id, + test_parse_missing_schedule_id, + test_parse_schedule_id, + test_parse_xmlfid ] + where + sample_path :: String + sample_path = "test/xml/gameinfo/CBASK_Lineup_XML.xml" + + desc :: String -> String + desc child = "a known " ++ child ++ " is parsed correctly" + + + -- | Actual implementation of the test for parse_xmlfid, + -- parse_game_id, and parse_schedule_id. + -- + test_child :: String -> Int -> TestTree + test_child child expected = + testCase (desc child) $ do + xmltree <- unsafe_read_document sample_path + let actual = parse_message_int child xmltree + actual @?= (Right expected) + + + -- | Make sure we can parse a game_id into the expected value. + -- + test_parse_game_id :: TestTree + test_parse_game_id = test_child "game_id" 97865 + + + -- | Make sure we can parse a schedule_id (different from the + -- game_id) into the expected value. + -- + test_parse_schedule_id :: TestTree + test_parse_schedule_id = test_child "schedule_id" 10199 + + + -- | Make sure we can parse an XML_File_ID into the expected value. + -- + test_parse_xmlfid :: TestTree + test_parse_xmlfid = test_child "XML_File_ID" 17 + + + +-- | The game_id element can be missing, so we test that too. +-- +test_parse_missing_game_id :: TestTree +test_parse_missing_game_id = + testCase "missing game_id is not an error" $ do + xmltree <- unsafe_read_document "test/xml/gameinfo/MLB_Matchup_XML.xml" + let actual = parse_game_id xmltree + let expected = Right Nothing + actual @?= expected + + +-- | The schedule_id element can be missing, so we test that too. +-- +test_parse_missing_schedule_id :: TestTree +test_parse_missing_schedule_id = + testCase "missing schedule_id is not an error" $ do + let path = "test/xml/gameinfo/recapxml-no-game-schedule-ids.xml" + xmltree <- unsafe_read_document path + let actual = parse_schedule_id xmltree + let expected = Right Nothing + actual @?= expected diff --git a/src/TSN/Team.hs b/src/TSN/Team.hs --- a/src/TSN/Team.hs +++ b/src/TSN/Team.hs @@ -14,6 +14,7 @@ -- module TSN.Team ( HTeam(..), + FromXmlFkTeams(..), Team(..), VTeam(..), -- * WARNING: these are private but exported to silence warnings @@ -22,12 +23,16 @@ -- System imports import Database.Groundhog () -- Required for some String instance +import Database.Groundhog.Core ( PersistEntity(..) ) import Database.Groundhog.TH ( defaultCodegenConfig, groundhog, mkPersist ) +-- Local imports +import Xml ( Child(..), Db(..) ) + -- * Team -- | The database representation of a team. The 'team_id' is a @@ -76,3 +81,20 @@ type: constraint fields: [team_id] |] + + + +-- | A further refinement of 'FromXmlFk'. These types need not only a +-- foreign key to a parent in order to make the XML -> DB +-- conversion, but also two foreign keys to away/home teams (as +-- represented in "TSN.Team"). +-- +class (Child a, ToDb a) => FromXmlFkTeams a where + -- | The function that produces a @Db a@ out of a parent foreign + -- key, two team foreign keys, and an @a@. The parameter order makes + -- it easier to map this function over a bunch of things. + from_xml_fk_teams :: DefaultKey (Parent a) + -> DefaultKey Team -- ^ The away team FK + -> DefaultKey Team -- ^ The home team FK + -> a + -> Db a diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -584,7 +584,7 @@ -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree -test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $ +test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" "test/xml/AutoRacingResultsXML.xml", @@ -600,7 +600,7 @@ -- | Make sure we can actually unpickle these things. -- test_unpickle_succeeds :: TestTree -test_unpickle_succeeds = testGroup "unpickle tests" $ +test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/AutoRacingResultsXML.xml", @@ -618,7 +618,7 @@ -- record. -- test_on_delete_cascade :: TestTree -test_on_delete_cascade = testGroup "cascading delete tests" $ +test_on_delete_cascade = testGroup "cascading delete tests" [ check "deleting auto_racing_results deletes its children" "test/xml/AutoRacingResultsXML.xml", diff --git a/src/TSN/XML/GameInfo.hs b/src/TSN/XML/GameInfo.hs --- a/src/TSN/XML/GameInfo.hs +++ b/src/TSN/XML/GameInfo.hs @@ -46,7 +46,10 @@ ImportResult(..), run_dbmigrate ) import TSN.Parse ( + ParseError, + parse_game_id, parse_message, + parse_schedule_id, parse_xmlfid, parse_xml_time_stamp ) import Xml ( unsafe_read_document ) @@ -84,10 +87,24 @@ -- | This serves as both the database and XML representation of a -- GameInfo \. -- +-- The 'game_id' and 'schedule_id' fields are foreign keys, but they +-- key into multiple tables and key on records which may not exist +-- when we import the GameInfo document. We therefore don't declare +-- them as foreign keys; i.e. we don't require them to point +-- anywhere in particular. But if they do, that's nice. +-- data GameInfo = GameInfo { dtd :: String, xml_file_id :: Int, + game_id :: Maybe Int, -- ^ These are optional because they are missing + -- from at least the MLB_Matchup_XML.dtd documents. + -- They provide foreign keys into any tables storing + -- games with their IDs. + + schedule_id :: Maybe Int, -- ^ Optional key into any table storing a + -- schedule along with its ID. We've noticed + -- them missing in e.g. recapxml.dtd documents. time_stamp :: UTCTime, xml :: String } deriving (Eq, Show) @@ -96,15 +113,23 @@ -- | Attempt to parse a 'GameInfo' from an 'XmlTree'. If we cannot, -- we fail with an error message. -- -parse_xml :: String -> XmlTree -> Either String GameInfo +parse_xml :: String -> XmlTree -> Either ParseError GameInfo parse_xml dtdname xmltree = do xmlfid <- parse_xmlfid xmltree + game_id <- parse_game_id xmltree + schedule_id <- parse_schedule_id xmltree timestamp <- parse_xml_time_stamp xmltree message <- parse_message xmltree - return $ GameInfo dtdname (fromInteger xmlfid) timestamp (xshow [message]) + return $ GameInfo + dtdname + xmlfid + game_id + schedule_id + timestamp + (xshow [message]) -- --- Database code +-- * Database code -- instance DbImport GameInfo where @@ -163,10 +188,14 @@ let ex2 = 21201550 let a3 = show $ time_stamp t let ex3 = "2014-05-31 15:13:00 UTC" - let a4 = take 9 (xml t) - let ex4 = "" - let actual = (a1,a2,a3,a4) - let expected = (ex1,ex2,ex3,ex4) + let a4 = game_id t + let ex4 = Just 39978 + let a5 = schedule_id t + let ex5 = Just 39978 + let a6 = take 9 (xml t) + let ex6 = "" + let actual = (a1,a2,a3,a4,a5,a6) + let expected = (ex1,ex2,ex3,ex4,ex5,ex6) actual @?= expected diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs --- a/src/TSN/XML/JFile.hs +++ b/src/TSN/XML/JFile.hs @@ -70,14 +70,17 @@ xp_time, xp_time_dots, xp_time_stamp ) -import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) +import TSN.Team ( + FromXmlFkTeams(..), + HTeam(..), + Team(..), + VTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -65,12 +65,11 @@ tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) -import TSN.Team ( Team(..) ) +import TSN.Team ( FromXmlFkTeams(..), Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs --- a/src/TSN/XML/Scores.hs +++ b/src/TSN/XML/Scores.hs @@ -61,12 +61,15 @@ import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) import TSN.Picklers ( xp_time_stamp ) -import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) +import TSN.Team ( + FromXmlFkTeams(..), + HTeam(..), + Team(..), + VTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, diff --git a/src/TSN/XML/SportInfo.hs b/src/TSN/XML/SportInfo.hs --- a/src/TSN/XML/SportInfo.hs +++ b/src/TSN/XML/SportInfo.hs @@ -50,6 +50,7 @@ ImportResult(..), run_dbmigrate ) import TSN.Parse ( + ParseError, parse_message, parse_xmlfid, parse_xml_time_stamp ) @@ -208,12 +209,12 @@ -- | Attempt to parse a 'SportInfo' from an 'XmlTree'. If we cannot, -- we fail with an error message. -- -parse_xml :: String -> XmlTree -> Either String SportInfo +parse_xml :: String -> XmlTree -> Either ParseError SportInfo parse_xml dtdname xmltree = do xmlfid <- parse_xmlfid xmltree timestamp <- parse_xml_time_stamp xmltree message <- parse_message xmltree - return $ SportInfo dtdname (fromInteger xmlfid) timestamp (xshow [message]) + return $ SportInfo dtdname xmlfid timestamp (xshow [message]) -- diff --git a/src/TSN/XmlImport.hs b/src/TSN/XmlImport.hs --- a/src/TSN/XmlImport.hs +++ b/src/TSN/XmlImport.hs @@ -20,12 +20,11 @@ -- Local imports. -import TSN.Team ( Team(..) ) +import TSN.Team ( FromXmlFkTeams(..), Team(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), - FromXmlFkTeams(..), ToDb(..) ) diff --git a/src/Xml.hs b/src/Xml.hs --- a/src/Xml.hs +++ b/src/Xml.hs @@ -8,7 +8,6 @@ DtdName(..), FromXml(..), FromXmlFk(..), - FromXmlFkTeams(..), ToDb(..), parse_opts, pickle_unpickle, @@ -39,10 +38,7 @@ yes ) --- Local imports. -import TSN.Team ( Team(..) ) - -- | Common associated type shared by 'FromXml' and 'FromXmlFk'. This -- basically just forces the client to define the \"database -- version\" of his type. @@ -70,8 +66,7 @@ -- | A class for XML representations which are children of other -- elements. The foal is to associate a child XML element with its -- parent element's database type. This is required to construct the --- database analogue of @a@ in the 'FromXmlFk' and 'FromXmlFkTeams' --- classes. +-- database analogue of @a@ in 'FromXmlFk'. -- class Child a where -- | The type of our parent object, i.e. to the type to whom our @@ -90,21 +85,6 @@ -- over a bunch of things. from_xml_fk :: DefaultKey (Parent a) -> a -> Db a - --- | A further refinement of 'FromXmlFk'. These types need not only a --- foreign key to a parent in order to make the XML -> DB --- conversion, but also two foreign keys to away/home teams (as --- represented in "TSN.Team"). --- -class (Child a, ToDb a) => FromXmlFkTeams a where - -- | The function that produces a @Db a@ out of a parent foreign - -- key, two team foreign keys, and an @a@. The parameter order makes - -- it easier to map this function over a bunch of things. - from_xml_fk_teams :: DefaultKey (Parent a) - -> DefaultKey Team -- ^ The away team FK - -> DefaultKey Team -- ^ The home team FK - -> a - -> Db a -- | Represents the DTD filename (\"SYSTEM\") part of the DOCTYPE diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,5 +1,6 @@ import Test.Tasty ( TestTree, defaultMain, testGroup ) +import TSN.Parse ( parse_tests ) import TSN.Picklers ( pickler_tests ) import TSN.XML.AutoRacingResults ( auto_racing_results_tests ) import TSN.XML.AutoRacingSchedule ( auto_racing_schedule_tests ) @@ -31,6 +32,7 @@ mlb_early_line_tests, news_tests, odds_tests, + parse_tests, pickler_tests, schedule_changes_tests, scores_tests, diff --git a/test/xml/gameinfo/Matchup_NBA_NHL_XML.dtd b/test/xml/gameinfo/Matchup_NBA_NHL_XML.dtd --- a/test/xml/gameinfo/Matchup_NBA_NHL_XML.dtd +++ b/test/xml/gameinfo/Matchup_NBA_NHL_XML.dtd @@ -1,42 +1,31 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/xml/gameinfo/Matchup_NBA_NHL_XML.xml b/test/xml/gameinfo/Matchup_NBA_NHL_XML.xml --- a/test/xml/gameinfo/Matchup_NBA_NHL_XML.xml +++ b/test/xml/gameinfo/Matchup_NBA_NHL_XML.xml @@ -1,139 +1,1 @@ - - - -235677 -ADX%MATCHUP-COL-VAN -Statistics -NHL -NHL Matchup - Colorado at Vancouver - -Colorado Avalanche (34-17-12-5) at Vancouver Canucks (36-20-8-4), 10 p.m. - - -Vancouver 2-1-2 (2-0-1 at Col; 0-1-1 at Van) - - -Vancouver 3-2 (1-1 at Col; 2-1 at Van) - - -Colorado 3-2 (2-1 at Col; 1-1 at Van) - - -Colorado 3-2 (2-0 at Col; 1-2 at Van) - -Colorado 17-13-5-1; Vancouver 17-10-5-0 -Colorado 17-4-7-4; Vancouver 19-10-3-4 - - -Colorado 10-7-4-0; Vancouver 8-6-5-1 - -Colorado 26-13-9-5; Vancouver 27-16-7-1 - - -12/11 - Tied, 1-1 ot (at Van) -12/29 - Vancouver, 3-2 (at Col) -01/02 - Colorado, 4-2 (at Van) -02/16 - Vancouver, 1-0 (at Col) -03/03 - Tied, 5-5 ot (at Col) - - -10/31 - Colorado, 5-1 (at Van) -11/04 - Vancouver, 4-2 (at Col) -12/11 - Vancouver, 3-1 (at Van) -12/23 - Colorado, 5-3 (at Col) -02/13 - Vancouver, 2-1 ot (at Van) - - -10/09 - Colorado, 5-4 (at Col) -10/13 - Vancouver, 4-0 (at Van) -10/25 - Colorado, 4-1 (at Col) -11/30 - Colorado, 5-2 (at Van) -04/09 - Vancouver, 2-1 (at Col) - - - -Vancouver is unbeaten (1-0-1) in the last two meetings. - - -Vancouver is 3-1-2 in the last six meetings. - - -Vancouver is 5-2-2 in the last nine and 6-3-2 in the last 11 meetings. - - -Vancouver is 7-6-2 in the last 15 meetings. - - -These two teams are 9-9-2 in the last 20 meetings. - - -Colorado is 15-10-4 in the last 29 meetings. - - -Colorado snapped a three-game series road winless streak on 01/02/04. - - -Colorado is unbeaten (1-0-1) in its last two at Vancouver. - - -Colorado is 1-2-1 in its last four at Vancouver. - - -Colorado is 3-2-1 in its last six at Vancouver. - - -Colorado is 3-5-1 in its last nine at Vancouver. - - -Colorado is 7-5-2 in its last 14 at Vancouver. - - -Vancouver is unbeaten (2-0-1) in its last three at Colorado. - - -Vancouver is 4-1-1 in its last six at Colorado. - - -Vancouver is 4-5-1 in its last 10 and 5-8-2 in its last 15 at Colorado. - - -Vancouver is 6-13-4 in its last 23 at Colorado. - - -Colorado is 1-3-2-1 in its last seven and 2-6-2-1 in its last 11 games. - - -Colorado is 8-1-2-2 in its last 13 road games. - - -Colorado is 23-2-3 when leading after two periods this season. - - -Vancouver is 4-1-1 in its last six and 5-2-1-1 in its last nine games. - - -Vancouver has won three straight after losing its last three home games. - - -Vancouver has won six of its last nine home games. - - -Vancouver is 22-2-0 when leading after two periods this season. - - - -02/28 - L at Columbus, 4-5 ot -03/01 - L vs. Tampa Bay, 0-3 -03/03 - T vs. Vancouver, 5-5 ot -03/05 - W vs. San Jose, 5-1 -03/07 - L vs. Calgary, 1-7 - - -02/26 - W vs. San Jose, 3-2 ot -02/28 - W vs. St. Louis, 2-0 -03/03 - T at Colorado, 5-5 ot -03/05 - L at Detroit, 1-3 -03/06 - W at Columbus, 4-0 - - March 8, 2004, at 12:51 PM ET - +20901524ADX%MATCHUP-CLB-TAMStatisticsNHL1882718827ColumbusTampa Bay148144NHL Matchup - Columbus at Tampa BayColumbus Blue Jackets (42-31-7) at Tampa Bay Lightning (44-27-9), 7:30 p.m.Columbus 2-0 (2-0 at Clb; 0-0 at TB)NoneTampa Bay 2-0 (1-0 at Clb; 1-0 at TB)Tampa Bay 1-0 (0-0 at Clb; 1-0 at TB)Columbus 22-15-4; Tampa Bay 24-10-6Columbus 20-16-3; Tampa Bay 20-17-3Columbus 13-7-2Tampa Bay 11-8-3Columbus 29-20-3; Tampa Bay 30-16-612/03 - Columbus, 1-0 (at Clb)01/13 - Columbus, 3-2 (at Clb)12/17 - Tampa Bay, 3-2 (at Clb)01/24 - Tampa Bay, 4-2 (at TB)01/18 - Tampa Bay, 3-2 so (at TB)03/30 - Columbus, 3-2 (at Clb)03/24 - Tampa Bay, 2-1 ot (at TB)03/09 - Columbus, 5-3 (at Clb)01/13 - Tampa Bay, 4-2 (at TB)10/23 - Tampa Bay, 1-0 (at Clb)01/02 - Columbus, 2-0 (at TB)10/23 - Tied, 2-2 ot (at Clb)12/06 - Tampa Bay, 1-0 (at TB)Columbus has won three straight and six of its last seven road games.Tampa Bay is 14-1-2 when leading after two periods at home this season.Columbus has won two straight after losing the last three meetings.Tampa Bay has won four of seven and five of the last nine meetings.Tampa Bay is 8-5-1 in the last 14 meetings.Columbus has lost four straight at Tampa Bay.Columbus has lost six of the seven meetings at Tampa Bay.Tampa Bay has lost two straight and four of its last five at Columbus.Tampa Bay is 2-5-1 in the eight meetings at Columbus.04/03 - W at Philadelphia, 2-004/04 - L vs. Chicago, 3-404/06 - W vs. NY Islanders, 4-004/08 - W vs. Phoenix, 4-3 (OT)04/09 - W at Dallas, 3-104/01 - W vs. Montreal, 3-104/03 - L vs. Calgary, 1-404/05 - L vs. Dallas, 2-504/08 - W vs. Toronto, 3-004/10 - W vs. Philadelphia, 4-2 April 11, 2014, at 12:20 PM ET diff --git a/test/xml/gameinfo/recapxml-no-game-schedule-ids.xml b/test/xml/gameinfo/recapxml-no-game-schedule-ids.xml new file mode 100644 --- /dev/null +++ b/test/xml/gameinfo/recapxml-no-game-schedule-ids.xml @@ -0,0 +1,1 @@ + 21246048 AAD;RECAP-SEA-TAM-P1 Recaps MLB American League Game Summary - Seattle at Tampa Bay Seattle

St. Petersburg, FL (SportsNetwork.com) - Endy Chavez's two-out single broke a scoreless tie and started a five-run ninth inning that helped the Seattle Mariners beat the Tampa Bay Rays, 5-0, in the rubber match of a three-game series at Tropicana Field on Sunday.

Brad Miller smacked a two-out triple into the right-field corner on an 0-2 slider from Grant Balfour (0-2). After a Willie Bloomquist walk, Chavez's sharp grounder on another 0-2 pitch went under the glove of diving shortstop Yunel Escobar. James Jones then tripled over the head of right fielder Kevin Kiermaier, who was playing shallow, to make it a 3-0 advantage.

Robinson Cano was walked on four pitches before Kyle Seager's two-run double to right increased the cushion to five for the Mariners, winners in seven of their last eight contests.

Yoervis Medina (3-1) walked one in the eighth inning to earn the win after taking over for Seattle starter Felix Hernandez. King Felix struck out a career-high 15 batters and allowed just four hits in seven innings in a no- decision.

June 8, 2014, at 05:00 PM ET