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 5e620699bbfdc43e53181511493be47f433349ba..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,
@@ -569,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