From: Michael Orlitzky <michael@orlitzky.com>
Date: Wed, 23 Jul 2014 03:01:07 +0000 (-0400)
Subject: Add a pickler for the weirdo EarlyLine date format.
X-Git-Tag: 0.0.9~15
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=84b0b8621593800f0fba275b86ad9f9961a07530;p=dead%2Fhtsn-import.git

Add a pickler for the weirdo EarlyLine date format.
Refactor a little bit in TSN.Picklers.
---

diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs
index a64db8a..232f357 100644
--- a/src/TSN/Picklers.hs
+++ b/src/TSN/Picklers.hs
@@ -7,6 +7,7 @@ module TSN.Picklers (
   xp_date,
   xp_date_padded,
   xp_datetime,
+  xp_early_line_date,
   xp_earnings,
   xp_gamedate,
   xp_tba_time,
@@ -16,13 +17,15 @@ module TSN.Picklers (
 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.Format ( formatTime, parseTime )
 import Data.Tree.NTree.TypeDefs ( NTree(..) )
-import System.Locale ( defaultTimeLocale )
+import System.Locale ( TimeLocale( wDays, months ), defaultTimeLocale )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Arrow.Pickle (
@@ -211,6 +214,47 @@ xp_datetime =
     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:
+--
+--   >>> :{
+--         let parse_date :: String -> Maybe UTCTime;
+--         parse_date = parseTime defaultTimeLocale date_format;
+--       :}
+--
+--   >>> let (Just d1) = parse_date "1/1/1970"
+--   >>> date_suffix d1
+--   "st"
+--
+--   >>> let (Just d2) = parse_date "1/2/1970"
+--   >>> date_suffix d2
+--   "nd"
+--
+--   >>> let (Just d3) = parse_date "1/3/1970"
+--   >>> date_suffix d3
+--   "rd"
+--
+--   >>> let (Just d4) = parse_date "1/4/1970"
+--   >>> date_suffix d4
+--   "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,
 --
@@ -240,29 +284,19 @@ xp_gamedate =
         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"
 
 
 
@@ -433,6 +467,60 @@ xp_ambiguous_time =
       formatTime defaultTimeLocale ambiguous_time_format
 
 
+-- | Pickle a date value from a \<date\> 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)") []]
+--
+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.