diff --git a/doc/TODO b/doc/TODO
--- a/doc/TODO
+++ b/doc/TODO
@@ -36,11 +36,9 @@
* CBATeamScheduleXML
* CFLTeamScheduleXML
* CFLTotalTeamScheduleXML
- * earlylineXML
* Minor_Baseball_TeamScheduleXML
* MinorLeagueHockeyTeamScheduleXML
* MLB_Boxscore_XML
- * MLB_earlylineXML
* MLB_IndividualStats_XML
* MLB_Probable_Pitchers_XML
* MLB_Roster_XML
@@ -65,3 +63,8 @@
5. Consolidate all of the make_game_time functions which take a
date/time and produce a combined time.
+
+6. Factor out test code where possible; a lot of them differ only in
+ the filename.
+
+7. Combine test XML files where possible.
diff --git a/doc/dbschema/MLB_earlylineXML.png b/doc/dbschema/MLB_earlylineXML.png
new file mode 100644
Binary files /dev/null and b/doc/dbschema/MLB_earlylineXML.png differ
diff --git a/doc/dbschema/earlylineXML.png b/doc/dbschema/earlylineXML.png
new file mode 100644
Binary files /dev/null and b/doc/dbschema/earlylineXML.png differ
diff --git a/doc/man1/htsn-import.1 b/doc/man1/htsn-import.1
--- a/doc/man1/htsn-import.1
+++ b/doc/man1/htsn-import.1
@@ -106,6 +106,26 @@
should be considered a bug if they are incorrect. The diagrams are
created using the pgModeler
+associated with each . Moreover, each has a bunch of
+ children that are supposed to be associated with the s,
+but the document structure indicates no explicit relationship. For
+example,
+
+.nf
+
+ ...
+ ...
+ ...
+ ...
+ ...
+
+.fi
+
+Here the first is inferred to apply to the two s that
+follow it, and the second applies to the single that
+follows it. But this is very fragile to parse. Instead, we use a hack
+to facilitate (un)pickling, and then drop the notes entirely during
+the database conversion.
+
+A similar workaround is implemented for Odds_XML.dtd.
+
+.IP \[bu]
\fIOdds_XML.dtd\fR
The elements here are supposed to be associated with a set of
@@ -316,6 +363,144 @@
offending document can be removed if desired. An example is provided
as test/xml/weatherxml-backwards-teams.xml.
+.SH DATE/TIME ISSUES
+
+Dates and times appear in a number of places on the feed. The date
+portions are usually, fine, but the times often lack important
+information such as the time zone, or whether \(dq8 o'clock\(dq means
+a.m. or p.m.
+
+The most pervasive issue occurs with the timestamps that are included
+in every message. A typical timestamp looks like,
+
+.nf
+ May 24, 2014, at 04:18 PM ET
+.fi
+
+The \(dqtime zone\(dq is given as \(dqET\(dq, but unfortunately
+\(dqET\(dq is not a valid time zone. It stands for \(dqEastern
+Time\(dq, which can belong to either of two time zones, EST or EDT,
+based on the time of the year (that is, whether or not daylight
+savings time is in effect) and one's location (for example, Arizona
+doesn't observe daylight savings time). It's not much more useful to
+be off by one hour than it is to be off by five hours, and since we
+can't determine the true offset from the timestamp, we always parse
+and store these as UTC.
+
+Here's a list of the ones that may cause surprises:
+
+.IP \[bu] 2
+\fIAutoRacingResultsXML.dtd\fR
+
+The elements contain a full date and time, but no time zone
+information:
+
+.nf
+5/24/2014 2:45:00 PM
+.fi
+
+We parse them as UTC, which will be wrong when stored,
+but \(dqcorrect\(dq if the new UTC time zone is ignored.
+
+.IP \[bu]
+\fIAuto_Racing_Schedule_XML.dtd\fR
+
+The and elements are combined into on field in
+the database, but no time zone information is given. For example,
+
+.nf
+02/16/2013
+08:10 PM
+.fi
+
+As a result, we parse and store the times as UTC. The race times are
+not always present in the database, but when they are missing, they
+are presented as \(dqTBA\(dq (to be announced):
+
+.nf
+TBA
+.fi
+
+Since the dates do not appear to be optional, we store only the race
+date in that case.
+
+.IP \[bu]
+\fIearlylineXML.dtd\fR
+
+The elements in the early lines contain neither a time zone nor
+an am/pm identifier:
+
+.nf
+8:30
+.fi
+
+The times are parsed and stored as UTC, since we
+don't have any other information upon which to base a guess. Even if
+one ignores the UTC time zone, the time can possibly be off by 12
+hours (due to the a.m./p.m. issue).
+
+.IP \[bu]
+\fIjfilexml.dtd\fR
+
+The and elements are combined into on field in
+the database, but no time zone information is given. For example,
+
+.nf
+06/15/2014
+08:00 PM
+.fi
+
+As a result, we parse and store the times as UTC.
+
+The elements suffer a similar problem, sans the
+date:
+
+.nf
+11:30 A.M.
+.fi
+
+They are also stored as UTC.
+
+.IP \[bu]
+\fIMLB_earlylineXML.dtd\fR
+
+See earlylineXML.dtd.
+
+.IP \[bu]
+\fIOdds_XML.dtd\fR
+
+The and elements are combined into on field in
+the database, but no time zone information is given. For example,
+
+.nf
+01/04/2014
+04:35 PM
+.fi
+
+As a result, we parse and store the times as UTC.
+
+.IP \[bu]
+\fISchedule_Changes_XML.dtd\fR
+
+The and elements are combined into on field in
+the database, but no time zone information is given. For example,
+
+.nf
+06/06/2014
+04:00 PM
+.fi
+
+As a result, we parse and store the times as UTC. The game times are
+not always present in the database, but when they are missing, they
+are presented as \(dqTBA\(dq (to be announced):
+
+.nf
+TBA
+.fi
+
+Since the dates do not appear to be optional, we store only the game
+date in that case.
+
.SH DEPLOYMENT
.P
When deploying for the first time, the target database will most
@@ -448,6 +633,8 @@
.IP \[bu]
Auto_Racing_Schedule_XML.dtd
.IP \[bu]
+earlylineXML.dtd
+.IP \[bu]
Heartbeat.dtd
.IP \[bu]
Injuries_Detail_XML.dtd
@@ -455,6 +642,8 @@
injuriesxml.dtd
.IP \[bu]
jfilexml.dtd
+.IP \[bu]
+MLB_earlylineXML.dtd
.IP \[bu]
newsxml.dtd
.IP \[bu]
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.8
+version: 0.0.9
cabal-version: >= 1.8
author: Michael Orlitzky
maintainer: Michael Orlitzky
@@ -48,6 +48,7 @@
schemagen/Cbask_Tourn_MVP_XML/*.xml
schemagen/Cbask_Tourn_Records_XML/*.xml
schemagen/cflpreviewxml/*.xml
+ schemagen/earlylineXML/*.xml
schemagen/Heartbeat/*.xml
schemagen/Injuries_Detail_XML/*.xml
schemagen/injuriesxml/*.xml
@@ -75,6 +76,7 @@
schemagen/MLB_Matchup_XML/*.xml
schemagen/mlbonbasepctxml/*.xml
schemagen/MLBOPSXML/*.xml
+ schemagen/MLB_earlylineXML/*.xml
schemagen/MLB_Pitching_Appearances_Leaders/*.xml
schemagen/MLB_Pitching_Balks_Leaders/*.xml
schemagen/MLB_Pitching_CG_Leaders/*.xml
@@ -273,11 +275,13 @@
TSN.XmlImport
TSN.XML.AutoRacingResults
TSN.XML.AutoRacingSchedule
+ TSN.XML.EarlyLine
TSN.XML.GameInfo
TSN.XML.Heartbeat
TSN.XML.Injuries
TSN.XML.InjuriesDetail
TSN.XML.JFile
+ TSN.XML.MLBEarlyLine
TSN.XML.News
TSN.XML.Odds
TSN.XML.ScheduleChanges
diff --git a/makefile b/makefile
--- a/makefile
+++ b/makefile
@@ -17,13 +17,21 @@
--prefix=/
runghc Setup.hs build
-doc: $(PN).cabal $(SRCS)
+dist/doc: $(PN).cabal $(SRCS)
runghc Setup.hs configure --user --prefix=/
runghc Setup.hs hscolour --all
runghc Setup.hs haddock --all \
--hyperlink-source \
--haddock-options="--ignore-all-exports"
+doc: dist/doc
+
+
+# The MLB schema is identical to the regular one.
+doc/dbschema/MLB_earlylineXML.png: doc/dbschema/earlylineXML.png
+ cp $< $@
+
+
#
# Testing.
#
@@ -41,9 +49,13 @@
#
# Misc.
#
-dist:
+
+# Only generate MLB_earlylineXML.png long enough to create
+# the tarball.
+dist: doc/dbschema/MLB_earlylineXML.png
runghc Setup.hs configure --prefix=/
TAR_OPTIONS="--format=ustar" runghc Setup.hs sdist
+ rm $<
hlint:
hlint --ignore="Use camelCase" \
diff --git a/schema/MLB_earlylineXML.dtd b/schema/MLB_earlylineXML.dtd
new file mode 100644
--- /dev/null
+++ b/schema/MLB_earlylineXML.dtd
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/schema/earlylineXML.dtd b/schema/earlylineXML.dtd
new file mode 100644
--- /dev/null
+++ b/schema/earlylineXML.dtd
@@ -0,0 +1,20 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/schemagen/MLB_earlylineXML/21160887.xml b/schemagen/MLB_earlylineXML/21160887.xml
new file mode 100644
--- /dev/null
+++ b/schemagen/MLB_earlylineXML/21160887.xml
@@ -0,0 +1,1 @@
+
21160887
AAO;MLB-EARLY-LINE
Odds
MLB
Major League Baseball Overnight Line
National League
3:05
D.Haren
-130
D.Buchanan
8.5o
4:10
J.Nicasio
M.Minor
-130
7.5p
4:10
W.Peralta
J.Turner
-105
8p
4:10
J.Collmenter
Z.Wheeler
-120
7.5p
7:15
J.Garcia
T.Cingrani
-105
7o
7:15
S.Strasburg
G.Cole
-105
6.5o
10:10
T.Wood
B.Buckner
off
off
American League
1:07
J.Chavez
-120
R.Dickey
9p
2:10
V.Nuno
J.Danks
-105
9.5p
4:08
N.Martinez
R.Porcello
-170
9u
4:10
J.Peavy
D.Price
-135
7o
Time change
12:35
C.Kluber
U.Jimenez
-110
8.5u
7:15
J.Shields
-110
M.Shoemaker
7.5u
10:10
B.Oberholtzer
B.Maurer
off
off
Inter League
10:05
S.Deduno
R.Vogelsong
off
off
May 24, 2014, at 09:23 AM ET
diff --git a/schemagen/earlylineXML/21166989.xml b/schemagen/earlylineXML/21166989.xml
new file mode 100644
--- /dev/null
+++ b/schemagen/earlylineXML/21166989.xml
@@ -0,0 +1,1 @@
+
21166989
ACO;NBA-EARLY-LINE
Odds
NBA
National Basketball Association Overnight Line
Western Conference Finals - San Antonio leads 2-0
8:30
San Antonio
Oklahoma City
208
Eastern Conference Finals - Miami leads 2-1
8:30
Indiana
Miami
off
May 25, 2014, at 09:06 AM ET
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -51,12 +51,18 @@
import qualified TSN.XML.AutoRacingSchedule as AutoRacingSchedule (
dtd,
pickle_message )
+import qualified TSN.XML.EarlyLine as EarlyLine (
+ dtd,
+ pickle_message )
import qualified TSN.XML.GameInfo as GameInfo ( dtds, parse_xml )
import qualified TSN.XML.Heartbeat as Heartbeat ( dtd, verify )
import qualified TSN.XML.Injuries as Injuries ( dtd, pickle_message )
import qualified TSN.XML.InjuriesDetail as InjuriesDetail (
dtd,
pickle_message )
+import qualified TSN.XML.MLBEarlyLine as MLBEarlyLine (
+ dtd,
+ pickle_message )
import qualified TSN.XML.JFile as JFile ( dtd, pickle_message )
import qualified TSN.XML.News as News (
dtd,
@@ -194,12 +200,18 @@
| dtd == AutoRacingSchedule.dtd =
go AutoRacingSchedule.pickle_message
+ | dtd == EarlyLine.dtd =
+ go EarlyLine.pickle_message
+
-- GameInfo and SportInfo appear last in the guards
| dtd == Injuries.dtd = go Injuries.pickle_message
| dtd == InjuriesDetail.dtd = go InjuriesDetail.pickle_message
| dtd == JFile.dtd = go JFile.pickle_message
+
+ | dtd == MLBEarlyLine.dtd =
+ go MLBEarlyLine.pickle_message
| dtd == News.dtd =
-- Some of the newsxml docs are busted in predictable ways.
diff --git a/src/TSN/Parse.hs b/src/TSN/Parse.hs
--- a/src/TSN/Parse.hs
+++ b/src/TSN/Parse.hs
@@ -8,7 +8,7 @@
where
import Data.Either.Utils ( maybeToEither )
-import Data.Time.Clock ( NominalDiffTime, UTCTime, addUTCTime )
+import Data.Time.Clock ( UTCTime )
import Data.Time.Format ( parseTime )
import System.Locale ( defaultTimeLocale )
import Text.Read ( readMaybe )
@@ -89,27 +89,27 @@
time_format :: String
time_format = "%I:%M %p"
--- | The format string for a time_stamp. This omits the leading and
--- trailing space.
+
+-- | 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
+-- functions should behave:
+--
+--
+--
time_stamp_format :: String
-time_stamp_format = "%B %-d, %Y, at " ++ time_format ++ " ET"
+time_stamp_format = " %B %-d, %Y, at " ++ time_format ++ " ET "
--- | Parse a time stamp from a 'String' (maybe).
---
--- TSN doesn't provide a proper time zone name, so we assume that
--- it's always Eastern Standard Time. EST is UTC-5, so we
--- add five hours to convert to UTC.
+
+-- | Parse a time stamp from a 'String' (maybe). TSN doesn't provide a
+-- proper time zone name, so we parse it as UTC, and maybe our
+-- eventual consumer can figure out a way to deduce the time zone.
--
parse_time_stamp :: String -> Maybe UTCTime
parse_time_stamp =
- fmap add_five . parseTime defaultTimeLocale time_stamp_format
- where
- five_hours :: NominalDiffTime
- five_hours = 5 * 60 * 60
+ parseTime defaultTimeLocale time_stamp_format
- add_five :: UTCTime -> UTCTime
- add_five = addUTCTime five_hours
-- | Extract the \"time_stamp\" element from a document. If we fail
diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs
--- a/src/TSN/Picklers.hs
+++ b/src/TSN/Picklers.hs
@@ -2,10 +2,14 @@
-- feed.
--
module TSN.Picklers (
+ pickler_tests,
+ xp_ambiguous_time,
xp_date,
xp_date_padded,
xp_datetime,
+ xp_early_line_date,
xp_earnings,
+ xp_fracpart_only_double,
xp_gamedate,
xp_tba_time,
xp_time,
@@ -14,17 +18,29 @@
where
-- System imports.
+import Data.Char ( toUpper )
import Data.List ( intercalate )
import Data.List.Split ( chunksOf )
+import Data.Maybe ( catMaybes, listToMaybe )
import Data.String.Utils ( replace )
-import Data.Time.Clock ( NominalDiffTime, UTCTime, addUTCTime )
+import Data.Time.Clock ( UTCTime )
import Data.Time.Format ( formatTime, parseTime )
-import System.Locale ( defaultTimeLocale )
+import Data.Tree.NTree.TypeDefs ( NTree(..) )
+import System.Locale ( TimeLocale( wDays, months ), defaultTimeLocale )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.Read ( readMaybe )
import Text.XML.HXT.Arrow.Pickle (
xpText,
xpWrap,
xpWrapMaybe )
import Text.XML.HXT.Arrow.Pickle.Xml ( PU )
+import Text.XML.HXT.Core (
+ XmlTree,
+ XNode( XTag, XText ),
+ mkName,
+ pickleDoc,
+ unpickleDoc )
-- Local imports.
import TSN.Parse (
@@ -58,6 +74,21 @@
-- | (Un)pickle a UTCTime without the time portion.
--
+-- /Examples/:
+--
+-- This should parse:
+--
+-- >>> let tn = text_node "2/15/1983"
+-- >>> unpickleDoc xp_date tn
+-- Just 1983-02-15 00:00:00 UTC
+--
+-- But for some reason, it can also parse a leading zero in the
+-- month. Whatever. This isn't required behavior.
+--
+-- >>> let tn = text_node "02/15/1983"
+-- >>> unpickleDoc xp_date tn
+-- Just 1983-02-15 00:00:00 UTC
+--
xp_date :: PU UTCTime
xp_date =
(to_date, from_date) `xpWrapMaybe` xpText
@@ -72,6 +103,16 @@
-- | (Un)pickle a UTCTime without the time portion. The day/month are
-- padded to two characters with zeros.
--
+-- Examples:
+--
+-- >>> let tn = text_node "02/15/1983"
+-- >>> unpickleDoc xp_date_padded tn
+-- Just 1983-02-15 00:00:00 UTC
+--
+-- >>> let tn = text_node "06/07/2014"
+-- >>> unpickleDoc xp_date_padded tn
+-- Just 2014-06-07 00:00:00 UTC
+--
xp_date_padded :: PU UTCTime
xp_date_padded =
(to_date, from_date) `xpWrapMaybe` xpText
@@ -108,6 +149,8 @@
format_commas x =
reverse (intercalate "," $ chunksOf 3 $ reverse $ show x)
+
+
-- | Parse \ from an 'AutoRaceResultsListing'. These are
-- essentially 'Int's, but they look like,
--
@@ -117,6 +160,16 @@
--
-- * \TBA\
--
+-- Examples:
+--
+-- >>> let tn = text_node "1,000,191"
+-- >>> unpickleDoc xp_earnings tn
+-- Just (Just 1000191)
+--
+-- >>> let tn = text_node "TBA"
+-- >>> unpickleDoc xp_earnings tn
+-- Just Nothing
+--
xp_earnings :: PU (Maybe Int)
xp_earnings =
(to_earnings, from_earnings) `xpWrap` xpText
@@ -134,15 +187,66 @@
from_earnings (Just i) = format_commas i
+
+-- | Pickle a 'Double' that can be missing its leading zero (for
+-- values less than one). For example, we've seen,
+--
+-- 0.5
+--
+-- Which 'xpPrim' can't handle without the leading
+-- zero. Unfortunately there's no way pickle/unpickle can be
+-- inverses of each other here, since \"0.5\" and \".5\" should
+-- unpickle to the same 'Double'.
+--
+-- Examples:
+--
+-- >>> let tn = text_node "0.5"
+-- >>> unpickleDoc xp_fracpart_only_double tn
+-- Just 0.5
+--
+-- >>> let tn = text_node ".5"
+-- >>> unpickleDoc xp_fracpart_only_double tn
+-- Just 0.5
+--
+-- >>> let tn = text_node "foo"
+-- >>> unpickleDoc xp_fracpart_only_double tn
+-- Nothing
+--
+xp_fracpart_only_double :: PU Double
+xp_fracpart_only_double =
+ (to_double, from_double) `xpWrapMaybe` xpText
+ where
+ -- | Convert a 'String' to a 'Double', maybe. We always prepend a
+ -- zero, since it will fix the fraction-only values, and not hurt
+ -- the ones that already have a leading integer.
+ to_double :: String -> Maybe Double
+ to_double s = readMaybe ("0" ++ s)
+
+ from_double :: Double -> String
+ from_double = show
+
+
+
-- | (Un)pickle an unpadded 'UTCTime'. Used for example on the
-- \ elements in an 'AutoRaceResults' message.
--
-- Examples:
--
--- * \6/1/2014 1:00:00 PM\
+-- >>> let tn = text_node "6/1/2014 1:00:00 PM"
+-- >>> unpickleDoc xp_datetime tn
+-- Just 2014-06-01 13:00:00 UTC
--
--- * \5/24/2014 2:45:00 PM\
+-- >>> let tn = text_node "5/24/2014 2:45:00 PM"
+-- >>> unpickleDoc xp_datetime tn
+-- Just 2014-05-24 14:45:00 UTC
--
+-- Padded! For some reason it works with only one zero in front. I
+-- dunno man. NOT required (or even desired?) behavior.
+--
+-- >>> let tn = text_node "05/24/2014 2:45:00 PM"
+-- >>> unpickleDoc xp_datetime tn
+-- Just 2014-05-24 14:45:00 UTC
+--
xp_datetime :: PU UTCTime
xp_datetime =
(to_datetime, from_datetime) `xpWrapMaybe` xpText
@@ -156,15 +260,53 @@
from_datetime = formatTime defaultTimeLocale format
+
+-- | Takes a 'UTCTime', and returns the English suffix that would be
+-- appropriate after the day of the month. For example, if we have a
+-- UTCTime representing Christmas, this would return \"th\" because
+-- \"th\" is the right suffix of \"December 25th\".
+--
+-- Examples:
+--
+-- >>> import Data.Maybe ( fromJust )
+-- >>> :{
+-- let parse_date :: String -> Maybe UTCTime;
+-- parse_date = parseTime defaultTimeLocale date_format;
+-- :}
+--
+-- >>> let dates = [ "1/" ++ (d : "/1970") | d <- ['1'..'9'] ]
+-- >>> let suffixes = map (date_suffix . fromJust . parse_date) dates
+-- >>> suffixes
+-- ["st","nd","rd","th","th","th","th","th","th"]
+--
+date_suffix :: UTCTime -> String
+date_suffix t =
+ case (reverse daystr) of
+ [] -> []
+ ('1':_) -> "st"
+ ('2':_) -> "nd"
+ ('3':_) -> "rd"
+ _ -> "th"
+ where
+ daystr = formatTime defaultTimeLocale "%d" t
+
+
-- | (Un)pickle a UTCTime from a weather forecast's gamedate. Example
-- input looks like,
--
--- \
---
-- When unpickling we get rid of the suffixes \"st\", \"nd\", \"rd\", and
-- \"th\". During pickling, we add them back based on the last digit
-- of the date.
--
+-- Examples:
+--
+-- >>> let tn = text_node "Monday, December 30th"
+-- >>> let (Just gd) = unpickleDoc xp_gamedate tn
+-- >>> gd
+-- 1970-12-30 00:00:00 UTC
+-- >>> pickleDoc xp_gamedate gd
+-- NTree (XTag "/" []) [NTree (XText "Wednesday, December 30th") []]
+--
xp_gamedate :: PU UTCTime
xp_gamedate =
(to_gamedate, from_gamedate) `xpWrapMaybe` xpText
@@ -178,37 +320,42 @@
s' = case (reverse s) of
(c2:c1:cs) -> let suffix = [c1,c2]
in
- case suffix of
- "st" -> reverse cs
- "nd" -> reverse cs
- "rd" -> reverse cs
- "th" -> reverse cs
- _ -> s -- Unknown suffix, leave it alone.
+ if suffix `elem` ["st","nd","rd","th"]
+ then reverse cs
+ else s -- Unknown suffix, leave it alone.
+
_ -> s -- The String is less than two characters long,
-- leave it alone.
from_gamedate :: UTCTime -> String
- from_gamedate d = s ++ (suffix s)
+ from_gamedate d = s ++ (date_suffix d)
where
s = formatTime defaultTimeLocale format d
- suffix :: String -> String
- suffix cs =
- case (reverse cs) of
- [] -> []
- ('1':_) -> "st"
- ('2':_) -> "nd"
- ('3':_) -> "rd"
- _ -> "th"
--- | (Un)pickle a UTCTime without the date portion.
+-- | (Un)pickle a UTCTime without the date portion. Doesn't work if
+-- the fields aren't zero-padded to two characters.
--
+-- /Examples/:
+--
+-- Padded, should work:
+--
+-- >>> let tn = text_node "04:35 PM"
+-- >>> unpickleDoc xp_time tn
+-- Just 1970-01-01 16:35:00 UTC
+--
+-- Unpadded, should fail:
+--
+-- >>> let tn = text_node "4:35 PM"
+-- >>> unpickleDoc xp_time tn
+-- Nothing
+--
xp_time :: PU UTCTime
xp_time =
(to_time, from_time) `xpWrapMaybe` xpText
@@ -224,10 +371,23 @@
-- 'xp_time' in that it uses periods in the AM/PM part, i.e. \"A.M.\"
-- and \"P.M.\" It also doesn't use padding for the \"hours\" part.
--
--- Examples:
+-- /Examples/:
--
--- * \11:30 A.M.\
+-- A standard example of the correct form:
--
+-- >>> let tn = text_node "11:30 A.M."
+-- >>> let (Just result) = unpickleDoc xp_time_dots tn
+-- >>> result
+-- 1970-01-01 11:30:00 UTC
+-- >>> pickleDoc xp_time_dots result
+-- NTree (XTag "/" []) [NTree (XText "11:30 A.M.") []]
+--
+-- Another miracle, it still parses with a leading zero!
+--
+-- >>> let tn = text_node "01:30 A.M."
+-- >>> unpickleDoc xp_time_dots tn
+-- Just 1970-01-01 01:30:00 UTC
+--
xp_time_dots :: PU UTCTime
xp_time_dots =
(to_time, from_time) `xpWrapMaybe` xpText
@@ -249,6 +409,31 @@
-- | (Un)pickle a UTCTime without the date portion, allowing for a
-- value of \"TBA\" (which gets translated to 'Nothing').
--
+-- /Examples/:
+--
+-- A failed parse will return 'Nothing':
+--
+-- >>> let tn = text_node "YO"
+-- >>> unpickleDoc xp_tba_time tn
+-- Just Nothing
+--
+-- And so will parsing a \"TBA\":
+--
+-- >>> let tn = text_node "TBA"
+-- >>> unpickleDoc xp_tba_time tn
+-- Just Nothing
+--
+-- But re-pickling 'Nothing' gives only \"TBA\":
+--
+-- >>> pickleDoc xp_tba_time Nothing
+-- NTree (XTag "/" []) [NTree (XText "TBA") []]
+--
+-- A normal time is also parsed successfully, of course:
+--
+-- >>> let tn = text_node "08:10 PM"
+-- >>> unpickleDoc xp_tba_time tn
+-- Just (Just 1970-01-01 20:10:00 UTC)
+--
xp_tba_time :: PU (Maybe UTCTime)
xp_tba_time =
(to_time, from_time) `xpWrap` xpText
@@ -265,23 +450,161 @@
-- | (Un)pickle the \ element format to/from a 'UTCTime'.
+-- The time_stamp elements look something like,
--
--- Example: \ January 6, 2014, at 10:11 PM ET \
+-- \ January 6, 2014, at 10:11 PM ET \
--
--- TSN doesn't provide a proper time zone name, so we assume that
--- it's always Eastern Standard Time. EST is UTC-5, so we
--- add/subtract 5 hours to convert to/from UTC.
+-- TSN doesn't provide a proper time zone name, only \"ET\" for
+-- \"Eastern Time\". But \"Eastern Time\" changes throughout the
+-- year, depending on one's location, for daylight-savings
+-- time. It's really not any more useful to be off by one hour than
+-- it is to be off by 5 hours, so rather than guess at EDT/EST, we
+-- just store the timestamp as UTC.
--
+-- Examples:
+--
+-- >>> let tn = text_node " January 6, 2014, at 10:11 PM ET "
+-- >>> let (Just tstamp) = unpickleDoc xp_time_stamp tn
+-- >>> tstamp
+-- 2014-01-06 22:11:00 UTC
+-- >>> pickleDoc xp_time_stamp tstamp
+-- NTree (XTag "/" []) [NTree (XText " January 6, 2014, at 10:11 PM ET ") []]
+--
xp_time_stamp :: PU UTCTime
xp_time_stamp =
(parse_time_stamp, from_time_stamp) `xpWrapMaybe` xpText
where
- five_hours :: NominalDiffTime
- five_hours = 5 * 60 * 60
-
- subtract_five :: UTCTime -> UTCTime
- subtract_five = addUTCTime (-1 * five_hours)
-
from_time_stamp :: UTCTime -> String
from_time_stamp =
- formatTime defaultTimeLocale time_stamp_format . subtract_five
+ formatTime defaultTimeLocale time_stamp_format
+
+
+
+-- | (Un)pickle an ambiguous 12-hour AM/PM time, which is ambiguous
+-- because it's missing the AM/PM part.
+--
+-- Examples:
+--
+-- >>> let tn = text_node "8:00"
+-- >>> unpickleDoc xp_ambiguous_time tn
+-- Just 1970-01-01 08:00:00 UTC
+--
+xp_ambiguous_time :: PU UTCTime
+xp_ambiguous_time =
+ (to_time, from_time) `xpWrapMaybe` xpText
+ where
+ ambiguous_time_format :: String
+ ambiguous_time_format = "%-I:%M"
+
+ to_time :: String -> Maybe UTCTime
+ to_time = parseTime defaultTimeLocale ambiguous_time_format
+
+ from_time :: UTCTime -> String
+ from_time =
+ formatTime defaultTimeLocale ambiguous_time_format
+
+
+-- | Pickle a date value from a \ element as they appear in the
+-- early lines. This is a particularly wacky format, but then so is
+-- the associated time (see 'xp_ambiguous_time').
+--
+-- Examples:
+--
+-- >>> let tn = text_node "SUNDAY, MAY 25TH (05/25/2014)"
+-- >>> let (Just result) = unpickleDoc xp_early_line_date tn
+-- >>> result
+-- 2014-05-25 00:00:00 UTC
+-- >>> pickleDoc xp_early_line_date result
+-- NTree (XTag "/" []) [NTree (XText "SUNDAY, MAY 25TH (05/25/2014)") []]
+--
+-- >>> let tn = text_node "SATURDAY, JUNE 7TH (06/07/2014)"
+-- >>> let (Just result) = unpickleDoc xp_early_line_date tn
+-- >>> result
+-- 2014-06-07 00:00:00 UTC
+-- >>> pickleDoc xp_early_line_date result
+-- NTree (XTag "/" []) [NTree (XText "SATURDAY, JUNE 7TH (06/07/2014)") []]
+--
+xp_early_line_date :: PU UTCTime
+xp_early_line_date =
+ (to_time, from_time) `xpWrapMaybe` xpText
+ where
+ -- | We need to create our own time locale that talks IN ALL CAPS.
+ -- Actually, 'parseTime' doesn't seem to care about the
+ -- case. But when we spit it back out again ('formatTime'),
+ -- we'll want it to be in all caps.
+ --
+ caps_time_locale :: TimeLocale
+ caps_time_locale =
+ defaultTimeLocale { wDays = caps_days, months = caps_months }
+
+ caps_days :: [(String,String)]
+ caps_days = map both_to_upper (wDays defaultTimeLocale)
+
+ caps_months :: [(String,String)]
+ caps_months = map both_to_upper (months defaultTimeLocale)
+
+ both_to_upper :: (String,String) -> (String,String)
+ both_to_upper (s1,s2) = (map toUpper s1, map toUpper s2)
+
+ wacko_date_formats :: [String]
+ wacko_date_formats =
+ ["%A, %B %-d" ++ suffix ++ " (" ++ date_format_padded ++ ")" |
+ suffix <- ["ST", "ND", "RD","TH"] ]
+
+ to_time :: String -> Maybe UTCTime
+ to_time s =
+ listToMaybe $ catMaybes possible_parses
+ where
+ possible_parses = [ parseTime caps_time_locale fmt s |
+ fmt <- wacko_date_formats ]
+
+ from_time :: UTCTime -> String
+ from_time t =
+ formatTime caps_time_locale fmt t
+ where
+ upper_suffix = map toUpper (date_suffix t)
+ fmt = "%A, %B %-d" ++ upper_suffix ++ " (" ++ date_format_padded ++ ")"
+
+
+
+-- | Create an 'XmlTree' containing only the given text. This is
+-- useful for testing (un)picklers, where we don't want to have to
+-- bother to create a dummy XML document.
+--
+-- Examples:
+--
+-- >>> text_node "8:00"
+-- NTree (XText "8:00") []
+--
+text_node :: String -> XmlTree
+text_node s = NTree (XText s) []
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module. This primary exists to
+-- eliminate the unused import/export warnings for 'unpickleDoc' and
+-- 'text_node' which are otherwise only used in the doctests.
+--
+pickler_tests :: TestTree
+pickler_tests =
+ testGroup
+ "Pickler tests"
+ [ test_pickle_of_unpickle_is_identity ]
+
+
+-- | If we unpickle something and then pickle it, we should wind up
+-- with the same thing we started with (plus an additional root
+-- element).
+--
+test_pickle_of_unpickle_is_identity :: TestTree
+test_pickle_of_unpickle_is_identity =
+ testCase "pickle composed with unpickle is (almost) the identity" $ do
+ let tn = text_node "8:00"
+ let (Just utctime) = unpickleDoc xp_ambiguous_time tn
+ let actual = pickleDoc xp_ambiguous_time utctime
+ let expected = NTree (XTag (mkName "/") []) [tn]
+ actual @?= expected
diff --git a/src/TSN/Team.hs b/src/TSN/Team.hs
--- a/src/TSN/Team.hs
+++ b/src/TSN/Team.hs
@@ -51,7 +51,7 @@
-- | A wrapper around 'Team' that lets us distinguish between home and
-- away teams. See also 'HTeam'. \"V\" (visiting) was chosen instead
--- of \"A\" (away) simply because \"vteam" looks better than
+-- of \"A\" (away) simply because \"vteam\" looks better than
-- \"ateam\". This is purely for type-safety.
--
newtype VTeam = VTeam { vteam :: Team } deriving (Eq, Show)
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
@@ -57,10 +57,13 @@
xpWrap )
-- Local imports.
-import TSN.Codegen (
- tsn_codegen_config )
+import TSN.Codegen ( tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_earnings, xp_datetime, xp_time_stamp )
+import TSN.Picklers (
+ xp_earnings,
+ xp_fracpart_only_double,
+ xp_datetime,
+ xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
Child(..),
@@ -352,9 +355,9 @@
----
---- Database stuff.
----
+--
+-- * Database stuff.
+--
instance DbImport Message where
dbmigrate _ =
@@ -529,7 +532,9 @@
xp11Tuple (-- I can't think of another way to get both the
-- TrackLength and its KPH attribute. So we shove them
-- both in a 2-tuple. This should probably be an embedded type!
- xpElem "TrackLength" $ xpPair xpText (xpAttr "KPH" xpPrim) )
+ xpElem "TrackLength" $
+ xpPair xpText
+ (xpAttr "KPH" xp_fracpart_only_double) )
(xpElem "Laps" xpInt)
(xpOption $ xpElem "AverageSpeedMPH" xpPrim)
(xpOption $ xpElem "AverageSpeedKPH" xpPrim)
@@ -561,7 +566,7 @@
xml_most_laps_leading m)
--
--- Tasty Tests
+-- * Tasty Tests
--
-- | A list of all tests for this module.
@@ -579,24 +584,33 @@
-- 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/AutoRacingResultsXML.xml"
- (expected, actual) <- pickle_unpickle pickle_message path
- actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $
+ [ check "pickle composed with unpickle is the identity"
+ "test/xml/AutoRacingResultsXML.xml",
+ check "pickle composed with unpickle is the identity (fractional KPH)"
+ "test/xml/AutoRacingResultsXML-fractional-kph.xml" ]
+ where
+ check desc path = testCase desc $ do
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds =
- testCase "unpickling succeeds" $ do
- let path = "test/xml/AutoRacingResultsXML.xml"
- actual <- unpickleable path pickle_message
+test_unpickle_succeeds = testGroup "unpickle tests" $
+ [ check "unpickling succeeds"
+ "test/xml/AutoRacingResultsXML.xml",
- let expected = True
- actual @?= expected
+ check "unpickling succeeds (fractional KPH)"
+ "test/xml/AutoRacingResultsXML-fractional-kph.xml" ]
+ where
+ check desc path = testCase desc $ do
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
@@ -604,24 +618,29 @@
-- record.
--
test_on_delete_cascade :: TestTree
-test_on_delete_cascade =
- testCase "deleting auto_racing_results deletes its children" $ do
- let path = "test/xml/AutoRacingResultsXML.xml"
- results <- unsafe_unpickle path pickle_message
- let a = undefined :: AutoRacingResults
- let b = undefined :: AutoRacingResultsListing
- let c = undefined :: AutoRacingResultsRaceInformation
+test_on_delete_cascade = testGroup "cascading delete tests" $
+ [ check "deleting auto_racing_results deletes its children"
+ "test/xml/AutoRacingResultsXML.xml",
- actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
- migrate a
- migrate b
- migrate c
- _ <- dbimport results
- deleteAll a
- count_a <- countAll a
- count_b <- countAll b
- count_c <- countAll c
- return $ sum [count_a, count_b, count_c]
- let expected = 0
- actual @?= expected
+ check "deleting auto_racing_results deletes its children (fractional KPH)"
+ "test/xml/AutoRacingResultsXML-fractional-kph.xml" ]
+ where
+ check desc path = testCase desc $ do
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: AutoRacingResults
+ let b = undefined :: AutoRacingResultsListing
+ let c = undefined :: AutoRacingResultsRaceInformation
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ migrate c
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ return $ sum [count_a, count_b, count_c]
+ let expected = 0
+ actual @?= expected
diff --git a/src/TSN/XML/AutoRacingSchedule.hs b/src/TSN/XML/AutoRacingSchedule.hs
--- a/src/TSN/XML/AutoRacingSchedule.hs
+++ b/src/TSN/XML/AutoRacingSchedule.hs
@@ -363,7 +363,7 @@
constructors:
- name: AutoRacingSchedule
uniques:
- - name: unique_auto_racing_schedule
+ - name: unique_auto_racing_schedules
type: constraint
# Prevent multiple imports of the same message.
fields: [db_xml_file_id]
diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs
new file mode 100644
--- /dev/null
+++ b/src/TSN/XML/EarlyLine.hs
@@ -0,0 +1,627 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Parse TSN XML for the DTD \"earlylineXML.dtd\". For that DTD,
+-- each \ element contains a bunch of \s, and those
+-- \s contain a single \. In the database, we merge
+-- the date info into the games, and key the games to the messages.
+--
+-- Real life is not so simple, however. There is another module,
+-- "TSN.XML.MLBEarlyLine" that is something of a subclass of this
+-- one. It contains early lines, but only for MLB games. The data
+-- types and XML schema are /almost/ the same, but TSN like to make
+-- things difficult.
+--
+-- A full list of the differences is given in that module. In this
+-- one, we mention where data types have been twerked a little to
+-- support the second document type.
+--
+module TSN.XML.EarlyLine (
+ EarlyLine, -- Used in TSN.XML.MLBEarlyLine
+ EarlyLineGame, -- Used in TSN.XML.MLBEarlyLine
+ dtd,
+ pickle_message,
+ -- * Tests
+ early_line_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ EarlyLineConstructor(..),
+ EarlyLineGameConstructor(..) )
+where
+
+-- System imports.
+import Control.Monad ( join )
+import Data.Time ( UTCTime(..) )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ insert_,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Database.Groundhog.TH (
+ groundhog,
+ mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+ PU,
+ xp4Tuple,
+ xp6Tuple,
+ xp7Tuple,
+ xpAttr,
+ xpElem,
+ xpInt,
+ xpList,
+ xpOption,
+ xpPair,
+ xpText,
+ xpWrap )
+
+-- Local imports.
+import TSN.Codegen ( tsn_codegen_config )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers (
+ xp_ambiguous_time,
+ xp_early_line_date,
+ xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml (
+ FromXml(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "earlylineXML.dtd"
+
+--
+-- * DB/XML data types
+--
+
+-- * EarlyLine/Message
+
+-- | Database representation of a 'Message'. It lacks the \
+-- elements since they're really properties of the games that they
+-- contain.
+--
+data EarlyLine =
+ EarlyLine {
+ db_xml_file_id :: Int,
+ db_heading :: String,
+ db_category :: String,
+ db_sport :: String,
+ db_title :: String,
+ db_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+
+
+-- | XML Representation of an 'EarlyLine'. It has the same
+-- fields, but in addition contains the 'xml_dates'.
+--
+data Message =
+ Message {
+ xml_xml_file_id :: Int,
+ xml_heading :: String,
+ xml_category :: String,
+ xml_sport :: String,
+ xml_title :: String,
+ xml_dates :: [EarlyLineDate],
+ xml_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+
+instance ToDb Message where
+ -- | The database analogue of a 'Message' is an 'EarlyLine'.
+ --
+ type Db Message = EarlyLine
+
+
+-- | The 'FromXml' instance for 'Message' is required for the
+-- 'XmlImport' instance.
+--
+instance FromXml Message where
+ -- | To convert a 'Message' to an 'EarlyLine', we just drop
+ -- the 'xml_dates'.
+ --
+ from_xml Message{..} =
+ EarlyLine {
+ db_xml_file_id = xml_xml_file_id,
+ db_heading = xml_heading,
+ db_category = xml_category,
+ db_sport = xml_sport,
+ db_title = xml_title,
+ db_time_stamp = xml_time_stamp }
+
+
+-- | This allows us to insert the XML representation 'Message'
+-- directly.
+--
+instance XmlImport Message
+
+
+
+-- * EarlyLineDate / EarlyLineGameWithNote
+
+-- | This is a very sad data type. It exists so that we can
+-- successfully unpickle/pickle the MLB_earlylineXML.dtd documents
+-- and get back what we started with. In that document type, the
+-- dates all have multiple \s associated with them (as
+-- children). But the dates also have multiple \s as
+-- children, and we're supposed to figure out which notes go with
+-- which games based on the order that they appear in the XML
+-- file. Yeah, right.
+--
+-- In any case, instead of expecting the games and notes in some
+-- nice order, we use this data type to expect \"a game and maybe a
+-- note\" multiple times. This will pair the notes with only one
+-- game, rather than all of the games that TSN think it should go
+-- with. But it allows us to pickle and unpickle correctly at least.
+--
+data EarlyLineGameWithNote =
+ EarlyLineGameWithNote {
+ date_note :: Maybe String,
+ date_game :: EarlyLineGameXml }
+ deriving (Eq, Show)
+
+
+-- | XML representation of a \. It has a \"value\" attribute
+-- containing the actual date string. As children it contains a
+-- (non-optional) note, and a game. The note and date value are
+-- properties of the game as far as I can tell.
+--
+data EarlyLineDate =
+ EarlyLineDate {
+ date_value :: UTCTime,
+ date_games_with_notes :: [EarlyLineGameWithNote] }
+ deriving (Eq, Show)
+
+
+
+-- * EarlyLineGame / EarlyLineGameXml
+
+-- | Database representation of a \ in earlylineXML.dtd and
+-- MLB_earlylineXML.dtd. We've had to make a sacrifice here to
+-- support both document types. Since it's not possible to pair the
+-- \s with \s reliably in MLB_earlylineXML.dtd, we
+-- have omitted the notes entirely. This is sad, but totally not our
+-- fault.
+--
+-- In earlylineXML.dtd, each \ and thus each \ is
+-- paired with exactly one \, so if we only cared about that
+-- document type, we could have retained the notes.
+--
+-- In earlylinexml.DTD, the over/under is required, but in
+-- MLB_earlylinexml.DTD it is not. So another compromise is to have
+-- it optional here.
+--
+-- The 'db_game_time' should be the combined date/time using the
+-- date value from the \ element's containing
+-- \. That's why EarlyLineGame isn't an instance of
+-- 'FromXmlFk': the foreign key isn't enough to construct one, we
+-- also need the date.
+--
+data EarlyLineGame =
+ EarlyLineGame {
+ db_early_lines_id :: DefaultKey EarlyLine,
+ db_game_time :: UTCTime, -- ^ Combined date/time
+ db_away_team :: EarlyLineGameTeam,
+ db_home_team :: EarlyLineGameTeam,
+ db_over_under :: Maybe String }
+
+
+-- | XML representation of a 'EarlyLineGame'. Comparatively, it lacks
+-- only the foreign key to the parent message.
+--
+data EarlyLineGameXml =
+ EarlyLineGameXml {
+ xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
+ xml_away_team :: EarlyLineGameTeamXml,
+ xml_home_team :: EarlyLineGameTeamXml,
+ xml_over_under :: Maybe String }
+ deriving (Eq, Show)
+
+
+
+-- * EarlyLineGameTeam / EarlyLineGameTeamXml
+
+-- | Database representation of an EarlyLine team, used in both
+-- earlylineXML.dtd and MLB_earlylineXML.dtd. It doubles as an
+-- embedded type within the DB representation 'EarlyLineGame'.
+--
+-- The team name is /not/ optional. However, since we're overloading
+-- the XML representation, we're constructing 'db_team_name' name
+-- from two Maybes, 'xml_team_name_attr' and
+-- 'xml_team_name_text'. To ensure type safety (and avoid a runtime
+-- crash), we allow the database field to be optional as well.
+--
+data EarlyLineGameTeam =
+ EarlyLineGameTeam {
+ db_rotation_number :: Int,
+ db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
+ db_team_name :: Maybe String, -- ^ NOT optional, see the data type docs.
+ db_pitcher :: Maybe String -- ^ Optional in MLB_earlylineXML.dtd,
+ -- always absent in earlylineXML.dtd.
+ }
+
+
+-- | This here is an abomination. What we've got is an XML
+-- representation, not for either earlylineXML.dtd or
+-- MLB_earlylineXML.dtd, but one that will work for /both/. Even
+-- though they represent the teams totally differently! Argh!
+--
+-- The earlylineXML.dtd teams look like,
+--
+-- \Miami\
+--
+-- While the MLB_earlylineXML.dtd teams look like,
+--
+--
+-- D.Haren
+-- -130
+--
+--
+-- So that's cool. This data type has placeholders that should allow
+-- the name/line to appear either as an attribute or as a text
+-- node. We'll sort it all out in the conversion to
+-- EarlyLineGameTeam.
+--
+data EarlyLineGameTeamXml =
+ EarlyLineGameTeamXml {
+ xml_rotation_number :: Int,
+ xml_line_attr :: Maybe String,
+ xml_team_name_attr :: Maybe String,
+ xml_team_name_text :: Maybe String,
+ xml_pitcher :: Maybe String,
+ xml_line_elem :: Maybe String }
+ deriving (Eq, Show)
+
+
+
+instance ToDb EarlyLineGameTeamXml where
+ -- | The database analogue of a 'EarlyLineGameTeamXml' is an
+ -- 'EarlyLineGameTeam', although the DB type is merely embedded
+ -- in another type.
+ --
+ type Db EarlyLineGameTeamXml = EarlyLineGameTeam
+
+
+-- | The 'FromXml' instance for 'EarlyLineGameTeamXml' lets us convert
+-- it to a 'EarlyLineGameTeam' easily.
+--
+instance FromXml EarlyLineGameTeamXml where
+ -- | To convert a 'EarlyLineGameTeamXml' to an 'EarlyLineGameTeam',
+ -- we figure how its fields were represented and choose the ones
+ -- that are populated. For example if the \"line\" attribute was
+ -- there, we'll use it, but if now, we'll use the \
+ -- element.
+ --
+ from_xml EarlyLineGameTeamXml{..} =
+ EarlyLineGameTeam {
+ db_rotation_number = xml_rotation_number,
+ db_line = merge xml_line_attr xml_line_elem,
+ db_team_name = merge xml_team_name_attr xml_team_name_text,
+ db_pitcher = xml_pitcher }
+ where
+ merge :: Maybe String -> Maybe String -> Maybe String
+ merge Nothing y = y
+ merge x Nothing = x
+ merge _ _ = Nothing
+
+
+
+
+-- | Convert an 'EarlyLineDate' into a list of 'EarlyLineGame's. Each
+-- date has one or more games, and the fields that belong to the date
+-- should really be in the game anyway. So the database
+-- representation of a game has the combined fields of the XML
+-- date/game.
+--
+-- This function gets the games out of a date, and then sticks the
+-- date value inside the games. It also adds the foreign key
+-- reference to the games' parent message, and returns the result.
+--
+-- This would convert a single date to a single game if we only
+-- needed to support earlylineXML.dtd and not MLB_earlylineXML.dtd.
+--
+date_to_games :: (DefaultKey EarlyLine) -> EarlyLineDate -> [EarlyLineGame]
+date_to_games fk date =
+ map convert_game games_only
+ where
+ -- | Get the list of games out of a date (i.e. drop the notes).
+ --
+ games_only :: [EarlyLineGameXml]
+ games_only = (map date_game (date_games_with_notes date))
+
+ -- | Stick the date value into the given game.
+ --
+ combine_date_time :: EarlyLineGameXml -> UTCTime
+ combine_date_time elgx =
+ UTCTime (utctDay $ date_value date) (utctDayTime $ xml_game_time elgx)
+
+ -- | Convert an XML game to a database one.
+ --
+ convert_game :: EarlyLineGameXml -> EarlyLineGame
+ convert_game gx =
+ EarlyLineGame {
+ db_early_lines_id = fk,
+ db_game_time = combine_date_time gx,
+ db_away_team = from_xml (xml_away_team gx),
+ db_home_team = from_xml (xml_home_team gx),
+ db_over_under = xml_over_under gx }
+
+
+--
+-- * Database stuff
+--
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: EarlyLine)
+ migrate (undefined :: EarlyLineGame)
+
+ dbimport m = do
+ -- Insert the message and obtain its ID.
+ msg_id <- insert_xml m
+
+ -- Create a function that will turn a list of dates into a list of
+ -- games by converting each date to its own list of games, and
+ -- then concatenating all of the game lists together.
+ let convert_dates_to_games = concatMap (date_to_games msg_id)
+
+ -- Now use it to make dem games.
+ let games = convert_dates_to_games (xml_dates m)
+
+ -- And insert all of them
+ mapM_ insert_ games
+
+ return ImportSucceeded
+
+
+mkPersist tsn_codegen_config [groundhog|
+
+- entity: EarlyLine
+ dbName: early_lines
+ constructors:
+ - name: EarlyLine
+ uniques:
+ - name: unique_early_lines
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
+
+
+- entity: EarlyLineGame
+ dbName: early_lines_games
+ constructors:
+ - name: EarlyLineGame
+ fields:
+ - name: db_early_lines_id
+ reference:
+ onDelete: cascade
+ - name: db_away_team
+ embeddedType:
+ - {name: rotation_number, dbName: away_team_rotation_number}
+ - {name: line, dbName: away_team_line}
+ - {name: team_name, dbName: away_team_name}
+ - {name: pitcher, dbName: away_team_pitcher}
+ - name: db_home_team
+ embeddedType:
+ - {name: rotation_number, dbName: home_team_rotation_number}
+ - {name: line, dbName: home_team_line}
+ - {name: team_name, dbName: home_team_name}
+ - {name: pitcher, dbName: home_team_pitcher}
+
+- embedded: EarlyLineGameTeam
+ fields:
+ - name: db_rotation_number
+ dbName: rotation_number
+ - name: db_line
+ dbName: line
+ - name: db_team_name
+ dbName: team_name
+ - name: db_pitcher
+ dbName: pitcher
+|]
+
+
+
+--
+-- * Pickling
+--
+
+
+-- | Pickler for the top-level 'Message'.
+--
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp7Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpElem "title" xpText)
+ (xpList pickle_date)
+ (xpElem "time_stamp" xp_time_stamp)
+ where
+ 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_dates m,
+ xml_time_stamp m)
+
+
+
+-- | Pickler for a '\ followed by a \. We turn them into
+-- a 'EarlyLineGameWithNote'.
+--
+pickle_game_with_note :: PU EarlyLineGameWithNote
+pickle_game_with_note =
+ xpWrap (from_tuple, to_tuple) $
+ xpPair (xpOption $ xpElem "note" xpText)
+ pickle_game
+ where
+ from_tuple = uncurry EarlyLineGameWithNote
+ to_tuple m = (date_note m, date_game m)
+
+
+-- | Pickler for the \ elements within each \.
+--
+pickle_date :: PU EarlyLineDate
+pickle_date =
+ xpElem "date" $
+ xpWrap (from_tuple, to_tuple) $
+ xpPair (xpAttr "value" xp_early_line_date)
+ (xpList pickle_game_with_note)
+ where
+ from_tuple = uncurry EarlyLineDate
+ to_tuple m = (date_value m, date_games_with_notes m)
+
+
+
+-- | Pickler for the \ elements within each \.
+--
+pickle_game :: PU EarlyLineGameXml
+pickle_game =
+ xpElem "game" $
+ xpWrap (from_tuple, to_tuple) $
+ xp4Tuple (xpElem "time" xp_ambiguous_time)
+ pickle_away_team
+ pickle_home_team
+ (xpElem "over_under" (xpOption xpText))
+ where
+ from_tuple = uncurryN EarlyLineGameXml
+ to_tuple m = (xml_game_time m,
+ xml_away_team m,
+ xml_home_team m,
+ xml_over_under m)
+
+
+
+-- | Pickle an away team (\) element within a \. Most
+-- of the work (common with the home team pickler) is done by
+-- 'pickle_team'.
+--
+pickle_away_team :: PU EarlyLineGameTeamXml
+pickle_away_team = xpElem "teamA" pickle_team
+
+
+-- | Pickle a home team (\) element within a \. Most
+-- of the work (common with theaway team pickler) is done by
+-- 'pickle_team'.
+--
+pickle_home_team :: PU EarlyLineGameTeamXml
+pickle_home_team = xpElem "teamH" pickle_team
+
+
+-- | Team pickling common to both 'pickle_away_team' and
+-- 'pickle_home_team'. Handles everything inside the \ and
+-- \ elements. We try to parse the line/name as both an
+-- attribute and an element in order to accomodate
+-- MLB_earlylineXML.dtd.
+--
+-- The \"line\" and \"pitcher\" fields wind up being double-Maybes,
+-- since they can be empty even if they exist.
+--
+pickle_team :: PU EarlyLineGameTeamXml
+pickle_team =
+ xpWrap (from_tuple, to_tuple) $
+ xp6Tuple (xpAttr "rotation" xpInt)
+ (xpOption $ xpAttr "line" (xpOption xpText))
+ (xpOption $ xpAttr "name" xpText)
+ (xpOption xpText)
+ (xpOption $ xpElem "pitcher" (xpOption xpText))
+ (xpOption $ xpElem "line" (xpOption xpText))
+ where
+ from_tuple (u,v,w,x,y,z) =
+ EarlyLineGameTeamXml u (join v) w x (join y) (join z)
+
+ to_tuple (EarlyLineGameTeamXml u v w x y z) =
+ (u, double_just v, w, x, double_just y, double_just z)
+ where
+ double_just val = case val of
+ Nothing -> Nothing
+ just_something -> Just just_something
+
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+early_line_tests :: TestTree
+early_line_tests =
+ testGroup
+ "EarlyLine tests"
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
+ test_unpickle_succeeds ]
+
+-- | If we unpickle something and then pickle it, we should wind up
+-- with the same thing we started with. WARNING: success 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/earlylineXML.xml"
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+ testCase "unpickling succeeds" $ do
+ let path = "test/xml/earlylineXML.xml"
+ actual <- unpickleable path pickle_message
+
+ let expected = True
+ actual @?= expected
+
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+-- record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade =
+ testCase "deleting early_lines deletes its children" $ do
+ let path = "test/xml/earlylineXML.xml"
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: EarlyLine
+ let b = undefined :: EarlyLineGame
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ return $ sum [count_a, count_b]
+ let expected = 0
+ actual @?= expected
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
@@ -162,7 +162,7 @@
let a2 = xml_file_id t
let ex2 = 21201550
let a3 = show $ time_stamp t
- let ex3 = "2014-05-31 20:13:00 UTC"
+ let ex3 = "2014-05-31 15:13:00 UTC"
let a4 = take 9 (xml t)
let ex4 = ""
let actual = (a1,a2,a3,a4)
diff --git a/src/TSN/XML/MLBEarlyLine.hs b/src/TSN/XML/MLBEarlyLine.hs
new file mode 100644
--- /dev/null
+++ b/src/TSN/XML/MLBEarlyLine.hs
@@ -0,0 +1,136 @@
+-- | Parse TSN XML for the DTD \"MLB_earlylineXML.dtd\". This module
+-- is unique (so far) in that it is almost entirely a subclass of
+-- another module, "TSN.XML.EarlyLine". The database representations
+-- should be almost identical, and the XML schema /could/ be
+-- similar, but instead, welcome to the jungle baby. Here are the
+-- differences:
+--
+-- * In earlylineXML.dtd, each \ element contains exactly one
+-- game. In MLB_earlylineXML.dtd, they contain multiple games.
+--
+-- * As a result of the previous difference, the \s are no
+-- longer in one-to-one correspondence with the games. The
+-- \ elements are thrown in beside the \s, and we're
+-- supposed to figure out to which \s they correspond
+-- ourselves. This is the same sort of nonsense going on with
+-- 'TSN.XML.Odds.OddsGameWithNotes'.
+--
+-- * The \ element can be empty in
+-- MLB_earlylineXML.dtd (it can't in earlylineXML.dtd).
+--
+-- * Each home/away team in MLB_earlylineXML.dtd has a \
+-- that isn't present in the regular earlylineXML.dtd.
+--
+-- * In earlylineXML.dtd, the home/away team lines are given as
+-- attributes on the \ and \ elements
+-- respectively. In MLB_earlylineXML.dtd, the lines can be found
+-- in \ elements that are children of the \ and
+-- \ elements.
+--
+-- * In earlylineXML.dtd, the team names are given as text within
+-- the \ and \ elements. In MLB_earlylineXML.dtd,
+-- they are instead given as attributes on those respective
+-- elements.
+--
+-- Most of these difficulties have been worked around in
+-- "TSN.XML.EarlyLine", so this module could be kept somewhat boring.
+--
+module TSN.XML.MLBEarlyLine (
+ dtd,
+ mlb_early_line_tests,
+ module TSN.XML.EarlyLine -- This re-exports the EarlyLine and EarlyLineGame
+ -- constructors unnecessarily. Whatever.
+ )
+where
+
+-- System imports (needed only for tests)
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+
+
+-- Local imports.
+import TSN.DbImport ( DbImport( dbimport ) )
+import TSN.XML.EarlyLine ( EarlyLine, EarlyLineGame, pickle_message )
+import Xml (
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "MLB_earlylineXML.dtd"
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+mlb_early_line_tests :: TestTree
+mlb_early_line_tests =
+ testGroup
+ "MLBEarlyLine tests"
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
+ test_unpickle_succeeds ]
+
+-- | If we unpickle something and then pickle it, we should wind up
+-- with the same thing we started with. WARNING: success 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/MLB_earlylineXML.xml"
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+ testCase "unpickling succeeds" $ do
+ let path = "test/xml/MLB_earlylineXML.xml"
+ actual <- unpickleable path pickle_message
+
+ let expected = True
+ actual @?= expected
+
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+-- record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade =
+ testCase "deleting (MLB) early_lines deletes its children" $ do
+ let path = "test/xml/MLB_earlylineXML.xml"
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: EarlyLine
+ let b = undefined :: EarlyLineGame
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ return $ sum [count_a, count_b]
+ let expected = 0
+ actual @?= expected
diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -291,7 +291,7 @@
constructors:
- name: NewsTeam
uniques:
- - name: unique_news_team
+ - name: unique_news_teams
type: constraint
fields: [team_name]
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
@@ -147,16 +147,25 @@
instance XmlImport OddsGameCasinoXml
--- * OddsGameTeamXml
+-- * OddsGameTeamXml / OddsGameTeamStarterXml
+-- | The XML representation of a \"starter\". It contains both an ID
+-- and a name. The ID does not appear to be optional, but the name
+-- can be absent. When the name is absent, the ID has always been
+-- set to \"0\". This occurs even though the entire starter element
+-- is optional (see 'OddsGameTeamXml' below).
+--
+data OddsGameTeamStarterXml =
+ OddsGameTeamStarterXml {
+ xml_starter_id :: Int,
+ xml_starter_name :: Maybe String }
+ deriving (Eq, Show)
+
+
-- | The XML representation of a \ or \, as
-- found in \s. We can't use the 'Team' representation
-- directly because there are some other fields we need to parse.
--
--- The starter id/name could perhaps be combined into an embedded
--- type, but can you make an entire embedded type optional with
--- Maybe? I doubt it works.
---
data OddsGameTeamXml =
OddsGameTeamXml {
xml_team_id :: String, -- ^ The home/away team IDs
@@ -170,7 +179,7 @@
xml_team_rotation_number :: Maybe Int,
xml_team_abbr :: String,
xml_team_name :: String,
- xml_team_starter :: Maybe (Int, String), -- ^ (id, name)
+ xml_team_starter :: Maybe OddsGameTeamStarterXml,
xml_team_casinos :: [OddsGameCasinoXml] }
deriving (Eq, Show)
@@ -309,16 +318,20 @@
(xml_team_rotation_number xml_home_team),
db_away_team_starter_id =
- (fst <$> xml_team_starter xml_away_team),
+ (xml_starter_id <$> xml_team_starter xml_away_team),
- db_away_team_starter_name =
- (snd <$> xml_team_starter xml_away_team),
+ -- Sometimes the starter element is present but the name isn't,
+ -- so we combine the two maybes with join.
+ db_away_team_starter_name = join
+ (xml_starter_name <$> xml_team_starter xml_away_team),
db_home_team_starter_id =
- (fst <$> xml_team_starter xml_home_team),
+ (xml_starter_id <$> xml_team_starter xml_home_team),
- db_home_team_starter_name =
- (snd <$> xml_team_starter xml_home_team) }
+ -- Sometimes the starter element is present but the name isn't,
+ -- so we combine the two maybes with join.
+ db_home_team_starter_name = join
+ (xml_starter_name <$> xml_team_starter xml_home_team) }
-- | This lets us insert the XML representation 'OddsGameXml' directly.
@@ -437,7 +450,7 @@
constructors:
- name: OddsCasino
uniques:
- - name: unique_odds_casino
+ - name: unique_odds_casinos
type: constraint
fields: [casino_client_id]
@@ -582,9 +595,7 @@
(xpElem "HomeRotationNumber" (xpOption xpInt))
(xpElem "HomeAbbr" xpText)
(xpElem "HomeTeamName" xpText)
- (-- This is an ugly way to get both the HStarter ID attribute
- -- and contents.
- xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
+ (xpOption pickle_home_starter)
(xpList pickle_casino)
where
from_tuple = uncurryN OddsGameTeamXml
@@ -597,6 +608,32 @@
xml_team_starter,
xml_team_casinos)
+
+-- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
+-- specific to the home/away teams.
+--
+pickle_starter :: PU OddsGameTeamStarterXml
+pickle_starter =
+ xpWrap (from_tuple, to_tuple) $
+ xpPair (xpAttr "ID" xpInt) (xpOption xpText)
+ where
+ from_tuple = uncurry OddsGameTeamStarterXml
+ to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
+ xml_starter_name)
+
+-- | Pickler for an home team 'OddsGameTeamStarterXml'
+--
+pickle_home_starter :: PU OddsGameTeamStarterXml
+pickle_home_starter = xpElem "HStarter" pickle_starter
+
+
+-- | Pickler for an away team 'OddsGameTeamStarterXml'
+--
+pickle_away_starter :: PU OddsGameTeamStarterXml
+pickle_away_starter = xpElem "AStarter" pickle_starter
+
+
+
-- | Pickler for an 'OddsGameTeamXml'.
--
pickle_away_team :: PU OddsGameTeamXml
@@ -608,9 +645,7 @@
(xpElem "AwayRotationNumber" (xpOption xpInt))
(xpElem "AwayAbbr" xpText)
(xpElem "AwayTeamName" xpText)
- (-- This is an ugly way to get both the AStarter ID attribute
- -- and contents.
- xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
+ (xpOption pickle_away_starter)
(xpList pickle_casino)
where
from_tuple = uncurryN OddsGameTeamXml
@@ -721,7 +756,10 @@
"test/xml/Odds_XML-largefile.xml",
check "pickle composed with unpickle is the identity (league name)"
- "test/xml/Odds_XML-league-name.xml" ]
+ "test/xml/Odds_XML-league-name.xml",
+
+ check "pickle composed with unpickle is the identity (missing starters)"
+ "test/xml/Odds_XML-missing-starters.xml" ]
where
check desc path = testCase desc $ do
(expected, actual) <- pickle_unpickle pickle_message path
@@ -745,7 +783,10 @@
"test/xml/Odds_XML-largefile.xml",
check "unpickling succeeds (league name)"
- "test/xml/Odds_XML-league-name.xml" ]
+ "test/xml/Odds_XML-league-name.xml",
+
+ check "unpickling succeeds (missing starters)"
+ "test/xml/Odds_XML-missing-starters.xml" ]
where
check desc path = testCase desc $ do
actual <- unpickleable path pickle_message
@@ -780,6 +821,10 @@
check "deleting odds deleted its children (league name)"
"test/xml/Odds_XML-league-name.xml"
35 -- 5 casinos, 30 teams
+ ,
+ check "deleting odds deleted its children (missing starters)"
+ "test/xml/Odds_XML-missing-starters.xml"
+ 7 -- 5 casinos, 2 teams
]
where
check desc path expected = testCase desc $ do
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
@@ -275,7 +275,7 @@
let a2 = xml_file_id t
let ex2 = 2011
let a3 = show $ time_stamp t
- let ex3 = "2009-09-28 00:50:00 UTC"
+ let ex3 = "2009-09-27 19:50:00 UTC"
let a4 = take 9 (xml t)
let ex4 = ""
let actual = (a1,a2,a3,a4)
diff --git a/test/TestSuite.hs b/test/TestSuite.hs
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -1,12 +1,15 @@
import Test.Tasty ( TestTree, defaultMain, testGroup )
+import TSN.Picklers ( pickler_tests )
import TSN.XML.AutoRacingResults ( auto_racing_results_tests )
import TSN.XML.AutoRacingSchedule ( auto_racing_schedule_tests )
+import TSN.XML.EarlyLine ( early_line_tests )
import TSN.XML.GameInfo ( game_info_tests )
import TSN.XML.Heartbeat ( heartbeat_tests )
import TSN.XML.Injuries ( injuries_tests )
import TSN.XML.InjuriesDetail ( injuries_detail_tests )
import TSN.XML.JFile ( jfile_tests )
+import TSN.XML.MLBEarlyLine ( mlb_early_line_tests )
import TSN.XML.News ( news_tests )
import TSN.XML.Odds ( odds_tests )
import TSN.XML.ScheduleChanges ( schedule_changes_tests )
@@ -19,13 +22,16 @@
"All tests"
[ auto_racing_results_tests,
auto_racing_schedule_tests,
+ early_line_tests,
game_info_tests,
heartbeat_tests,
injuries_tests,
injuries_detail_tests,
jfile_tests,
+ mlb_early_line_tests,
news_tests,
odds_tests,
+ pickler_tests,
schedule_changes_tests,
scores_tests,
sport_info_tests,
diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test
--- a/test/shell/import-duplicates.test
+++ b/test/shell/import-duplicates.test
@@ -16,15 +16,15 @@
# and a newsxml that aren't really supposed to import.
find ./test/xml -maxdepth 1 -name '*.xml' | wc -l
>>>
-26
+30
>>>= 0
# Run the imports again; we should get complaints about the duplicate
-# xml_file_ids. There are 2 errors for each violation, so we expect 2*22
+# xml_file_ids. There are 2 errors for each violation, so we expect 2*26
# occurrences of the string 'ERROR'.
./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l
>>>
-44
+52
>>>= 0
# Finally, clean up after ourselves.
diff --git a/test/xml/AutoRacingResultsXML-fractional-kph.xml b/test/xml/AutoRacingResultsXML-fractional-kph.xml
new file mode 100644
--- /dev/null
+++ b/test/xml/AutoRacingResultsXML-fractional-kph.xml
@@ -0,0 +1,1 @@
+
21475733
ATX%CRAFTSMAN-FINAL-RESULTS
Statistics
NASCAR-T
1747
7/23/2014 9:00:00 PM
NASCAR - Camping World - 1-800 CarCash Mudsummer Classic - Final Results
Eldora Speedway - New Weston, OH
0
True
1
6
54
1484
Darrell Wallace Jr.
Toyota
0
150
0
Running
False
TBA
2
3
30
108
Ron Hornaday Jr.
Chevrolet
0
150
0
Running
False
TBA
3
4
29
1482
Ryan Blaney
Ford
0
150
0
Running
False
TBA
4
10
52
40
Ken Schrader
Toyota
0
150
0
Running
False
TBA
5
13
3
1061
Ty Dillon
Chevrolet
0
150
0
Running
False
TBA
6
18
8
1106
John H. Nemechek
Toyota
0
150
0
Running
False
TBA
7
2
13
1483
Jeb Burton
Toyota
0
150
0
Running
False
TBA
8
5
98
117
Johnny Sauter
Toyota
0
150
0
Running
False
TBA
9
9
88
123
Matt Crafton
Toyota
0
150
0
Running
False
TBA
10
19
2
1321
Austin Dillon
Chevrolet
0
150
0
Running
False
TBA
11
8
19
1105
Tyler Reddick
Ford
0
150
0
Running
False
TBA
12
24
77
1221
German Quiroga
Toyota
0
150
0
Running
False
TBA
13
21
31
1085
Ben Kennedy
Chevrolet
0
150
0
Running
False
TBA
14
7
21
1477
Joey Coulter
Chevrolet
0
150
0
Running
False
TBA
15
27
02
1486
Tyler Young
Chevrolet
0
150
0
Running
False
TBA
16
14
17
550
Timothy Peters
Toyota
0
150
0
Running
False
TBA
17
23
9
1509
Chase Pistone
Chevrolet
0
150
0
Running
False
TBA
18
16
63
999
J.R. Heffner
Chevrolet
0
150
0
Running
False
TBA
19
26
05
1300
John Wes Townley
Toyota
0
150
0
Running
False
TBA
20
17
20
1504
Gray Gaulding
Chevrolet
0
150
0
Running
False
TBA
21
15
50
241
T.J. Bell
Chevrolet
0
150
0
Running
False
TBA
22
12
35
1115
Mason Mingus
Toyota
0
150
0
Running
False
TBA
23
20
99
1238
Bryan Silas
Chevrolet
0
150
0
Running
False
TBA
24
25
08
1503
Korbin Forrister
Chevrolet
0
150
0
Running
False
TBA
25
30
14
1307
Michael Annett
Chevrolet
0
149
0
Running
False
TBA
26
11
32
965
Kyle Larson
Chevrolet
0
148
0
Accident
False
TBA
27
29
6
171
Norm Benning
Chevrolet
0
148
0
Running
False
TBA
28
28
80
1520
Jody Knowles
Ford
0
148
0
Running
False
TBA
29
1
51
639
Erik Jones
Toyota
0
144
0
Running
False
TBA
30
22
03
1518
Michael Affarano
Chevrolet
0
93
0
Overheating
False
TBA
0.5
150
50.195
80.764
50.195
1 Hr., 29 Mins., 39 Secs.
5.489 Seconds
7 for 33 laps
5 among 5 drivers
1484
Darrell Wallace Jr.
0
July 23, 2014, at 11:32 PM ET
diff --git a/test/xml/MLB_earlylineXML.dtd b/test/xml/MLB_earlylineXML.dtd
new file mode 100644
--- /dev/null
+++ b/test/xml/MLB_earlylineXML.dtd
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/test/xml/MLB_earlylineXML.xml b/test/xml/MLB_earlylineXML.xml
new file mode 100644
--- /dev/null
+++ b/test/xml/MLB_earlylineXML.xml
@@ -0,0 +1,1 @@
+
21161927
AAO;MLB-EARLY-LINE
Odds
MLB
Major League Baseball Overnight Line
National League
1:10
J.Nelson
R.Wolf
-105
8o
Game one of doubleheader
1:10
B.Arroyo
R.Montero
-105
7.5u
1:35
J.Beckett
-110
AJ.Burnett
1:35
D.Fister
F.Liriano
-115
7p
4:10
J.Hammel
I.Kennedy
-125
6.5p
5:10
F.Morales
J.Teheran
-160
7.5p
8:05
A.Wainwright
-140
M.Leake
6.5o
American League
1:05
C.Lewis
J.Verlander
-180
8.5u
1:05
D.Pomeranz
-125
J.Happ
9o
1:35
T.Bauer
M.Gonzalez
-120
9p
1:40
B.Workman
J.Odorizzi
-120
8p
2:10
M.Tanaka
-165
A.Rienzo
7.5o
3:35
J.Vargas
G.Richards
-155
8u
4:10
D.Keuchel
H.Iwakuma
-165
6.5o
Inter League
4:05
R.Nolasco
M.Bumgarner
-175
7.5p
Write-in game - Game two of doubleheader
4:40
Z.Spruill
D.Matsuzaka
off
off
May 24, 2014, at 03:05 PM ET
diff --git a/test/xml/Odds_XML-missing-starters.xml b/test/xml/Odds_XML-missing-starters.xml
new file mode 100644
--- /dev/null
+++ b/test/xml/Odds_XML-missing-starters.xml
@@ -0,0 +1,1 @@
+
21434211
AAO;BB-ODDS
Odds
MLB
Las Vegas Major League Baseball Line
Current Line as of 9:30 A.M. ET
Inter League
TUESDAY, JULY 15TH
85TH All Star Game - Target Field - Minneapolis, MN
42056
07/15/2014
08:00 PM
683
945
NAT
MLB-National
-103
-110
-103
684
946
AME
MLB-American
-107
-110
-107
7.5u
8u
8u
July 14, 2014, at 09:29 AM ET
diff --git a/test/xml/earlylineXML.dtd b/test/xml/earlylineXML.dtd
new file mode 100644
--- /dev/null
+++ b/test/xml/earlylineXML.dtd
@@ -0,0 +1,20 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/test/xml/earlylineXML.xml b/test/xml/earlylineXML.xml
new file mode 100644
--- /dev/null
+++ b/test/xml/earlylineXML.xml
@@ -0,0 +1,1 @@
+
21166989
ACO;NBA-EARLY-LINE
Odds
NBA
National Basketball Association Overnight Line
Western Conference Finals - San Antonio leads 2-0
8:30
San Antonio
Oklahoma City
208
Eastern Conference Finals - Miami leads 2-1
8:30
Indiana
Miami
off
May 25, 2014, at 09:06 AM ET