Add the 'xp_attr_option' pickler and use it to fix tests broken by HXT.

[dead/htsn-import.git] / src / TSN / Picklers.hs

diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs
index 6f131a75b921f4aac3490a39214a5106db0f6160..3135d6ae194d483f3704755d46063cc513393808 100644 (file)
--- a/src/TSN/Picklers.hs
+++ b/src/TSN/Picklers.hs
@@ -1,9 +1,12 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- | (Un)picklers for data types present in The Sports Network XML
 --   feed.
 --
 module TSN.Picklers (
   pickler_tests,
   xp_ambiguous_time,
+  xp_attr_option,
   xp_date,
   xp_date_padded,
   xp_datetime,
@@ -23,7 +26,7 @@ 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 Data.Tree.NTree.TypeDefs ( NTree(..) )
 import System.Locale ( TimeLocale( wDays, months ), defaultTimeLocale )
@@ -270,8 +273,8 @@ xp_datetime =
 --
 --   >>> import Data.Maybe ( fromJust )
 --   >>> :{
---         let parse_date :: String -> Maybe UTCTime;
---         parse_date = parseTime defaultTimeLocale date_format;
+--         let parse_date :: String -> Maybe UTCTime
+--             parse_date = parseTime defaultTimeLocale date_format
 --       :}
 --
 --   >>> let dates = [ "1/" ++ (d : "/1970") | d <- ['1'..'9'] ]
@@ -454,29 +457,33 @@ xp_tba_time =
 --
 --   \<time_stamp\> January 6, 2014, at 10:11 PM ET \</time_stamp\>
 --
---   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 "
---   >>> unpickleDoc xp_time_stamp tn
---   Just 2014-01-07 03:11:00 UTC
+--   >>> 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)
-
+    -- | We have to re-pad the time_stamp_format with a leading and
+    --   trailing space; see the documentation of 'time_stamp_format'
+    --   for more information.
     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
@@ -565,6 +572,23 @@ xp_early_line_date =
         fmt = "%A, %B %-d" ++ upper_suffix ++ " (" ++ date_format_padded ++ ")"
 
 
+-- | This is a replacement for @xpOption xpFoo@ within an 'xpAttr'.
+--   There's a bug <https://github.com/UweSchmidt/hxt/issues/39> in
+--   newer versions of HXT that prevents us from using the usual
+--   'xpOption' solution, so this is our stopgap. It should work on
+--   any type that can be unpickled with a plain read/show.
+--
+xp_attr_option ::  forall a. (Read a, Show a) => PU (Maybe a)
+xp_attr_option =
+  (to_a, from_a) `xpWrap` xpText
+  where
+    to_a :: String -> Maybe a
+    to_a = readMaybe
+
+    from_a :: Maybe a -> String
+    from_a Nothing  = ""
+    from_a (Just x) = show x
+
 
 -- | Create an 'XmlTree' containing only the given text. This is
 --   useful for testing (un)picklers, where we don't want to have to