Add a new pickler for Double values that have no leading integer.

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

diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs
index 3d7215a07744436055a7eff73a8169201d394301..6f131a75b921f4aac3490a39214a5106db0f6160 100644 (file)
--- a/src/TSN/Picklers.hs
+++ b/src/TSN/Picklers.hs
@@ -9,6 +9,7 @@ module TSN.Picklers (
   xp_datetime,
   xp_early_line_date,
   xp_earnings,
+  xp_fracpart_only_double,
   xp_gamedate,
   xp_tba_time,
   xp_time,
@@ -28,6 +29,7 @@ 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,
@@ -148,6 +150,7 @@ format_commas x =
   reverse (intercalate "," $ chunksOf 3 $ reverse $ show x)
 
 
+
 -- | Parse \<Earnings\> from an 'AutoRaceResultsListing'. These are
 --   essentially 'Int's, but they look like,
 --
@@ -185,6 +188,45 @@ xp_earnings =
 
 
 
+-- | Pickle a 'Double' that can be missing its leading zero (for
+--   values less than one). For example, we've seen,
+--
+--   <TrackLength KPH=".805">0.5</TrackLength>
+--
+--   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
 --   \<RaceDate\> elements in an 'AutoRaceResults' message.
 --