X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FPicklers.hs;h=a64db8a2023760375ac467d888b45f96294d7322;hb=acd67d75aab3f2350b488fe6402bc0a20e476a18;hp=f697b8ca48196fadebdfc6cd92a912f113ab0e2f;hpb=9320bfe4aa73724f5988f88f13d5882d9119be39;p=dead%2Fhtsn-import.git diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs index f697b8c..a64db8a 100644 --- a/src/TSN/Picklers.hs +++ b/src/TSN/Picklers.hs @@ -2,6 +2,8 @@ -- feed. -- module TSN.Picklers ( + pickler_tests, + xp_ambiguous_time, xp_date, xp_date_padded, xp_datetime, @@ -19,12 +21,21 @@ import Data.List.Split ( chunksOf ) import Data.String.Utils ( replace ) import Data.Time.Clock ( NominalDiffTime, UTCTime, addUTCTime ) import Data.Time.Format ( formatTime, parseTime ) +import Data.Tree.NTree.TypeDefs ( NTree(..) ) import System.Locale ( defaultTimeLocale ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) 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 +69,21 @@ date_format_padded = "%0m/%0d/%Y" -- | (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 +98,12 @@ xp_date = -- | (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 +-- xp_date_padded :: PU UTCTime xp_date_padded = (to_date, from_date) `xpWrapMaybe` xpText @@ -108,6 +140,7 @@ format_commas :: Int -> String 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 +150,16 @@ format_commas x = -- -- * \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,14 +177,26 @@ xp_earnings = from_earnings (Just i) = format_commas i + -- | (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 = @@ -159,12 +214,19 @@ xp_datetime = -- | (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 @@ -207,7 +269,22 @@ xp_gamedate = --- | (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 = @@ -224,9 +301,22 @@ xp_time = -- '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/: +-- +-- A standard example of the correct form: -- --- * \11:30 A.M.\ +-- >>> 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 = @@ -249,6 +339,31 @@ xp_time_dots = -- | (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,13 +380,20 @@ xp_tba_time = -- | (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. -- +-- Examples: +-- +-- >>> let tn = text_node " January 6, 2014, at 10:11 PM ET " +-- >>> unpickleDoc xp_time_stamp tn +-- Just 2014-01-07 03:11:00 UTC +-- xp_time_stamp :: PU UTCTime xp_time_stamp = (parse_time_stamp, from_time_stamp) `xpWrapMaybe` xpText @@ -285,3 +407,70 @@ xp_time_stamp = from_time_stamp :: UTCTime -> String from_time_stamp = formatTime defaultTimeLocale time_stamp_format . subtract_five + + +-- | (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 + + +-- | 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