Resolve.hs

module Data.FuzzyTime.Resolve
  ( resolveZonedTime
  , resolveLocalTime
  , resolveLocalTimeOne
  , resolveLocalTimeOther
  , resolveLocalTimeBoth
  , morning
  , evening
  , resolveTimeOfDay
  , resolveTimeOfDayWithDiff
  , normaliseTimeOfDay
  , resolveDay
  ) where

import Data.Fixed
import Data.Maybe
import Data.Time
import Data.Time.Calendar.WeekDate

import Data.FuzzyTime.Types

resolveZonedTime :: ZonedTime -> FuzzyZonedTime -> ZonedTime
resolveZonedTime zt ZonedNow = zt

resolveLocalTime :: LocalTime -> FuzzyLocalTime -> AmbiguousLocalTime
resolveLocalTime lt (FuzzyLocalTime sft) =
  case sft of
    One fd -> OnlyDaySpecified $ resolveLocalTimeOne lt fd
    Other ftod -> BothTimeAndDay $ resolveLocalTimeOther lt ftod
    Both fd ftod -> BothTimeAndDay $ resolveLocalTimeBoth lt fd ftod

resolveLocalTimeOne :: LocalTime -> FuzzyDay -> Day
resolveLocalTimeOne (LocalTime ld _) fd = resolveDay ld fd

resolveLocalTimeOther :: LocalTime -> FuzzyTimeOfDay -> LocalTime
resolveLocalTimeOther (LocalTime ld ltod) ftod =
  let (d, tod) = resolveTimeOfDayWithDiff ltod ftod
   in LocalTime (addDays d ld) tod

resolveLocalTimeBoth :: LocalTime -> FuzzyDay -> FuzzyTimeOfDay -> LocalTime
resolveLocalTimeBoth (LocalTime ld ltod) fd ftod =
  let withDiff = resolveTimeOfDayWithDiff ltod ftod
      withoutDiff = (0, resolveTimeOfDay ltod ftod)
      (d, tod) =
        case fd of
          Now -> withDiff
          Today -> withDiff
          _ -> withoutDiff
   in LocalTime (addDays d $ resolveDay ld fd) tod

resolveTimeOfDay :: TimeOfDay -> FuzzyTimeOfDay -> TimeOfDay
resolveTimeOfDay tod ftod = snd $ resolveTimeOfDayWithDiff tod ftod

resolveTimeOfDayWithDiff :: TimeOfDay -> FuzzyTimeOfDay -> (Integer, TimeOfDay)
resolveTimeOfDayWithDiff tod@(TimeOfDay h m s) ftod =
  case ftod of
    SameTime -> (0, tod)
    Noon -> next midday
    Midnight -> next midnight
    Morning -> next morning
    Evening -> next evening
    AtHour h_ -> next $ TimeOfDay h_ 0 0
    AtMinute h_ m_ -> next $ TimeOfDay h_ m_ 0
    AtExact tod_ -> next tod_
    HoursDiff hd -> normaliseTimeOfDay $ TimeOfDay (h + fromIntegral hd) m s
    MinutesDiff md -> normaliseTimeOfDay $ TimeOfDay h (m + fromIntegral md) s
    SecondsDiff sd -> normaliseTimeOfDay $ TimeOfDay h m (s + sd)
  where
    next tod_ = (skipIf (>= tod_), tod_)
    skipIf p =
      if p tod
        then 1
        else 0

normaliseTimeOfDay :: TimeOfDay -> (Integer, TimeOfDay)
normaliseTimeOfDay (TimeOfDay h m s) =
  let s' = s `mod'` 60
      totalM = m + (round $ s - s') `div` 60
      m' = totalM `mod` 60
      totalH = h + (totalM - m') `div` 60
      h' = totalH `mod` 24
      totalD = (totalH - h') `div` 24
   in (fromIntegral totalD, TimeOfDay h' m' s')

morning :: TimeOfDay
morning = TimeOfDay 6 0 0

evening :: TimeOfDay
evening = TimeOfDay 18 0 0

resolveDay :: Day -> FuzzyDay -> Day
resolveDay d fd =
  case fd of
    Yesterday -> addDays (-1) d
    Now -> d
    Today -> d
    Tomorrow -> addDays 1 d
    OnlyDay di -> nextDayOnDay d di
    DayInMonth mi di -> nextDayOndayInMonth d mi di
    DiffDays ds -> addDays (fromIntegral ds) d
    DiffWeeks ws -> addDays (7 * fromIntegral ws) d
    DiffMonths ms -> addDays (30 * fromIntegral ms) d
    NextDayOfTheWeek dow -> nextDayOfTheWeek d dow
    ExactDay d_ -> d_

nextDayOnDay :: Day -> Int -> Day
nextDayOnDay d di =
  let (y_, m_, _) = toGregorian d
      go :: Integer -> [(Month, Int)] -> Day
      go y [] =
        let y' = y + 1
         in go y' (daysInMonth y')
      go y ((month, mds):rest) =
        if mds >= di
          then let d' = fromGregorian y (monthNum month) di
                in if d' >= d
                     then d'
                     else go y rest
          else go y rest
   in go y_ (drop (m_ - 1) $ daysInMonth y_)

nextDayOndayInMonth :: Day -> Int -> Int -> Day
nextDayOndayInMonth d mi di =
  let (y_, _, _) = toGregorian d
      go y =
        let mds = fromJust $ lookup (numMonth mi) (daysInMonth y)
         in if mds >= di
              then let d' = fromGregorian y mi di
                    in if d' >= d
                         then d'
                         else go (y + 1)
              else go (y + 1)
   in go y_

nextDayOfTheWeek :: Day -> DayOfTheWeek -> Day
nextDayOfTheWeek d dow =
  let (_, _, i_) = toWeekDate d
      down = dayOfTheWeekNum dow
      diff = fromIntegral $ down - i_
      diff' =
        if diff <= 0
          then diff + 7
          else diff
   in addDays diff' d