TimeAgo.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}

module Text.Time.Pretty.TimeAgo
  ( daysAgo,
    daysAgoToDays,
    DaysAgo (..),
    timeAgo,
    timeAgoToDiffTime,
    TimeAgo (..),
  )
where

import Data.Time
import Data.Validity
import GHC.Generics (Generic)
import Text.Time.Pretty.Constants

data DaysAgo = DaysAgo
  { daysAgoSign :: Ordering,
    daysAgoYears :: Integer,
    daysAgoMonths :: Integer,
    daysAgoWeeks :: Integer,
    daysAgoDays :: Integer
  }
  deriving (Show, Eq, Generic)

instance Validity DaysAgo where
  validate da@DaysAgo {..} =
    mconcat
      [ genericValidate da,
        check
          ( case daysAgoSign of
              EQ ->
                and
                  [ daysAgoDays == 0,
                    daysAgoWeeks == 0,
                    daysAgoMonths == 0,
                    daysAgoYears == 0
                  ]
              _ ->
                any
                  (> 0)
                  [daysAgoDays, daysAgoWeeks, daysAgoMonths, daysAgoYears]
          )
          "the sign makes sense",
        check (daysAgoYears >= 0) "years are positive",
        check
          ( daysAgoDays + daysPerWeek * daysAgoWeeks
              + approximateDaysPerMonth * daysAgoMonths
              < approximateDaysPerYear
          )
          "days, weeks and months do not sum to a year",
        check (daysAgoMonths < 12) "months < 12",
        check (daysAgoMonths >= 0) "months are positive",
        check
          (daysAgoDays + daysPerWeek * daysAgoWeeks < approximateDaysPerMonth)
          "days and weeks do not sum to a month",
        check (daysAgoWeeks < 5) "weeks < 5",
        check (daysAgoWeeks >= 0) "weeks are positive",
        check (daysAgoDays < 7) "days < 7",
        check (daysAgoDays >= 0) "days are positive"
      ]

daysAgo :: Integer -> DaysAgo
daysAgo i = DaysAgo {..}
  where
    totalDays = abs i
    daysAgoSign = compare i 0
    daysAgoYears = totalDays `div` approximateDaysPerYear
    daysLeftAfterYears = totalDays - daysAgoYears * approximateDaysPerYear
    daysAgoMonths = daysLeftAfterYears `div` approximateDaysPerMonth
    daysLeftAfterMonths =
      daysLeftAfterYears - daysAgoMonths * approximateDaysPerMonth
    daysAgoWeeks = daysLeftAfterMonths `div` daysPerWeek
    daysLeftAfterWeeks = daysLeftAfterMonths - daysAgoWeeks * daysPerWeek
    daysAgoDays = daysLeftAfterWeeks

daysAgoToDays :: DaysAgo -> Integer
daysAgoToDays DaysAgo {..} =
  ( case daysAgoSign of
      EQ -> const 0
      GT -> id
      LT -> negate
  )
    $ daysAgoDays + daysPerWeek * daysAgoWeeks
      + approximateDaysPerMonth * daysAgoMonths
      + approximateDaysPerYear * daysAgoYears

data TimeAgo = TimeAgo
  { timeAgoSign :: Ordering,
    timeAgoDaysAgo :: DaysAgo,
    timeAgoHours :: Integer,
    timeAgoMinutes :: Integer,
    timeAgoSeconds :: Integer,
    timeAgoPicoSeconds :: Integer
  }
  deriving (Show, Eq, Generic)

instance Validity TimeAgo where
  validate ta@TimeAgo {..} =
    mconcat
      [ genericValidate ta,
        check
          ( case timeAgoSign of
              EQ ->
                and
                  [ daysAgoToDays timeAgoDaysAgo == 0,
                    timeAgoHours == 0,
                    timeAgoMinutes == 0,
                    timeAgoSeconds == 0,
                    timeAgoPicoSeconds == 0
                  ]
              _ ->
                any
                  (> 0)
                  [ daysAgoToDays timeAgoDaysAgo,
                    timeAgoHours,
                    timeAgoMinutes,
                    timeAgoSeconds,
                    timeAgoPicoSeconds
                  ]
          )
          "the sign makes sense",
        check (daysAgoSign timeAgoDaysAgo /= LT) "The days ago are not negative",
        check (timeAgoHours < hoursPerDay) "hours < 24",
        check (timeAgoHours >= 0) "hours are positive",
        check (timeAgoMinutes < minutesPerHour) "minutes < 60",
        check (timeAgoMinutes >= 0) "minutes are positive",
        check (timeAgoSeconds < secondsPerMinute) "seconds < 60",
        check (timeAgoSeconds >= 0) "seconds are positive",
        check (timeAgoPicoSeconds < picoSecondsPerSecond) "picoseconds < 1E12",
        check (timeAgoPicoSeconds >= 0) "picoseconds are positive"
      ]

timeAgo :: NominalDiffTime -> TimeAgo
timeAgo dt = TimeAgo {..}
  where
    timeAgoSign = compare dt 0
    timeAgoPicoSeconds =
      totalPicoSecondsAgo - picoSecondsPerSecond * totalSecondsAgo
    timeAgoSeconds = totalSecondsAgo - secondsPerMinute * totalMinutesAgo
    timeAgoMinutes = totalMinutesAgo - minutesPerHour * totalHoursAgo
    timeAgoHours = totalHoursAgo - hoursPerDay * totalDaysAgo
    timeAgoDaysAgo = daysAgo totalDaysAgo
    totalPicoSecondsAgo =
      floor $ absDt * fromIntegral (picoSecondsPerSecond :: Integer)
    totalSecondsAgo = floor absDt :: Integer
    totalMinutesAgo = floor $ absDt / fromIntegral (secondsPerMinute :: Integer)
    totalHoursAgo =
      floor $
        absDt / fromIntegral (minutesPerHour * secondsPerMinute :: Integer)
    totalDaysAgo =
      floor $
        absDt
          / fromIntegral (hoursPerDay * minutesPerHour * secondsPerMinute :: Integer)
    absDt = abs dt

timeAgoToDiffTime :: TimeAgo -> NominalDiffTime
timeAgoToDiffTime TimeAgo {..} =
  (/ fromIntegral (picoSecondsPerSecond :: Integer)) $
    realToFrac $
      ( case timeAgoSign of
          EQ -> const 0
          GT -> id
          LT -> negate
      )
        ( timeAgoPicoSeconds
            + picoSecondsPerSecond
            * ( timeAgoSeconds
                  + secondsPerMinute
                  * ( timeAgoMinutes
                        + minutesPerHour
                        * (timeAgoHours + hoursPerDay * daysAgoToDays timeAgoDaysAgo)
                    )
              )
        )