Heuristic Date Parsing in Haskell

parseDate.hs

module ParseDate where

import Data.Monoid
import qualified Data.Foldable as F
import Control.Newtype

import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Format
import System.Locale

defaultParseTime :: ParseTime t => String -> String -> Maybe t
defaultParseTime = parseTime defaultTimeLocale

data Error = NoParse String
  deriving (Show)

data Date = LocalTimeMain LocalTime | TimeOfDayMain TimeOfDay
  deriving (Show, Ord, Eq)

date :: (LocalTime -> a) -> (TimeOfDay -> a) -> Date -> a
date l t d =
  case d of
    LocalTimeMain lt -> l lt
    TimeOfDayMain tod -> t tod

dateToUTC :: Date -> UTCTime
dateToUTC = date (localTimeToUTC utc) (const oldUTC)

fmapCompose :: (Functor f) => (b -> c) -> (a -> f b) -> a -> f c
fmapCompose f m x = f `fmap` m x

{- HH:Mm
-  HH:MM:ss
-  MM.DD.YY.HH:mm:ss
-  YYYYMMDD-HHmmss *
-
-- |Normally, ISO-8601 just defines YYYY-MM-DD
-- but we can add a time spec.

iso8601DateFormat :: Maybe String -> String
iso8601DateFormat mTimeFmt =
    "%Y-%m-%d" ++ case mTimeFmt of
             Nothing  -> "" 
             Just fmt -> 'T' : fmt
-}
-- TODO: brute force components of time with plist, feature to prefer dates in the past, present, "current", future
-- T is sometimes the separator instead of space between date and time
parseDate :: String -> Either Error Date
parseDate s =
  let parses = map ($ s) parseFns
      parseFns = [
                 fmapCompose LocalTimeMain (defaultParseTime yYYYMMDDHHmmssFormat),
                 fmapCompose LocalTimeMain (defaultParseTime yYYYMMDDHHmmssFormat2),
                 fmapCompose TimeOfDayMain (defaultParseTime hhmmFormat),
                 fmapCompose TimeOfDayMain (defaultParseTime hhmmssFormat),
                 fmapCompose LocalTimeMain (defaultParseTime mMDDYYHHmmssFormat),
                 fmapCompose LocalTimeMain (defaultParseTime mMDDYYHHmmssFormat3),
                 fmapCompose LocalTimeMain (defaultParseTime mMDDYYHHmmssFormat5),
                 fmapCompose LocalTimeMain (defaultParseTime dDMMYYYYHHmmFormat)
                 ]
      firstParse = ala First F.foldMap parses
      hhmmFormat = "%R"
      hhmmssFormat = "%T"
      mMDDYYHHmmssFormat = "%m.%d.%y " ++ hhmmssFormat
      mMDDYYHHmmssFormat3 = "%m.%d.%Y " ++ hhmmFormat
      mMDDYYHHmmssFormat5 = "%m.%d.%y." ++ hhmmssFormat
      yYYYMMDDHHmmssFormat = "%Y%m%d-%H%M%S"
      yYYYMMDDHHmmssFormat2 = "%Y-%m-%d %H:%M:%S"
      yYYYMMDDHHmmssFormat3 = "%Y-%m-%d %H:%M:%S %z"
      yYYYMMDDHHmmssFormat4 = "%Y-%m-%dT%H:%M:%S %z"
      yYYYMMDDHHmmssFormat5 = "%Y-%m-%dT%H:%M:%S%z"
      dDMMYYYYHHmmFormat = "%d.%m.%Y% %H:%M"
  in maybe
      (Left $ NoParse s)
      Right
      firstParse

oneYearAgo :: IO UTCTime
oneYearAgo =
  let -- average seconds in a year
      seconds = negate . fromIntegral . round $ 3.15e7
  in addUTCTime seconds `fmap` getCurrentTime

oneMonthBeforeLT :: TimeZone -> LocalTime -> LocalTime
oneMonthBeforeLT = localTimeThroughUTC oneMonthBefore

localTimeThroughUTC :: (UTCTime -> UTCTime) -> TimeZone -> LocalTime -> LocalTime
localTimeThroughUTC f tz = utcToLocalTime tz . f . localTimeToUTC tz

oneWeekFuture :: UTCTime -> UTCTime
oneWeekFuture =
  let -- average seconds in a day
      seconds = fromIntegral 604800
  in addUTCTime seconds

oneWeekUntil :: IO UTCTime
oneWeekUntil = oneWeekFuture `fmap` getCurrentTime

oneMonthBefore :: UTCTime -> UTCTime
oneMonthBefore =
  let -- average seconds in a month
      seconds = negate . fromIntegral . round $ 2.628e6
  in addUTCTime seconds

oneMonthAgo :: IO UTCTime
oneMonthAgo = oneMonthBefore `fmap` getCurrentTime

colorEitherDate :: UTCTime -> Either Error Date -> (Int, Int, Int)
colorEitherDate today e =
  either
    (const black)
    (\d -> date
            (\localtime -> colorDate today localtime)
            (const gray)
            d)
    e
  where black = (0, 0, 0)
        gray = (128,128,128)

-- (formatTime defaultTimeLocale "%c" . truncateToHour) `fmap` getCurrentTime
-- >>> "Sat Aug 30 00:00:00 UTC 2014"
truncateToHour :: UTCTime -> UTCTime
truncateToHour (UTCTime day seconds) =
  let hour = (`div` 3600) . floor $ seconds
  in UTCTime day (fromIntegral . (3600 *) $ hour)

truncateToHourLT :: LocalTime -> LocalTime
truncateToHourLT (LocalTime d (TimeOfDay hour _ _)) = LocalTime d (TimeOfDay hour 0 0)

oldUTC :: UTCTime
oldUTC = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)

utcTimeInCurrentTimeZone :: IO (UTCTime -> LocalTime)
utcTimeInCurrentTimeZone = do
  tz <- getCurrentTimeZone
  return $ utcToLocalTime tz

colorDate :: UTCTime -> LocalTime -> (Int, Int, Int)
colorDate today lt =
  let red = (255, 0, 0)
      green = (0, 255, 0)
      blue = (0, 0, 255)
      yellow = (255, 255, 0)
      -- average seconds in a month
      oneMonthAgoDiff = negate . fromIntegral . round $ 2.628e6
      oneWeek = 604800
      redThreshold = addUTCTime (oneMonthAgoDiff) today -- today - 1 months
      yellowThreshold = addUTCTime oneWeek redThreshold -- today - 1 months + 1 week
      blueThreshold = today -- today
      dateUTC = localTimeToUTC utc lt
  in if dateUTC < redThreshold then
        red
     else if dateUTC < yellowThreshold then
        yellow
     else if dateUTC < blueThreshold then
        green
     else
        blue