foo.hs

module Time.DateConversions
    (
    T.Day
    -- current day from system
    , today

    -- average
    , averageDaysBetween

    -- beginning of period
    , beginningOfWeek
    , beginningOfMonth
    , beginningOfQuarter
    , beginningOfYear

    -- end of period
    , endOfWeek
    , endOfMonth
    , endOfQuarter
    , endOfYear

    -- current ranges - beginning of X until now
    , thisWeek
    , thisMonth
    , thisQuarter
    , thisYear

    -- previous ranges
    , lastWeek
    , lastMonth
    , lastQuarter
    , lastYear

    -- entire range of X
    , allWeek
    , allMonth
    , allQuarter
    , allYear

    -- start-of predicates
    , isBeginningOfWeek
    , isBeginningOfMonth
    , isBeginningOfQuarter
    , isBeginningOfYear

    -- date math (subtractive)
    , daysAgo
    , weeksAgo
    , monthsAgo
    , yearsAgo

    -- date math (additive)
    , daysFromNow
    , weeksFromNow
    , monthsFromNow
    , yearsFromNow
    ) where

import qualified Data.Dates as D
import qualified Data.List as L
import qualified Data.Time as T
import           Control.Monad (ap)
import           Control.Arrow ((&&&))

today :: IO T.Day
today = T.utctDay <$> T.getCurrentTime

averageDaysBetween :: [T.Day] -> Integer
averageDaysBetween [] = 0
averageDaysBetween ds =
    if averagesLength == 0
        then 0
        else div dayAverages averagesLength
  where
    (dayAverages, averagesLength) = (sum &&& toInteger . length) $ daysDiff $ L.nub ds

daysDiff :: [T.Day] -> [Integer]
daysDiff [] = []
daysDiff ls = zipWith T.diffDays (tail ls) ls

beginningOfWeek :: T.Day -> T.Day
beginningOfWeek d =
    if T.addDays 1 d == nextMonday d
        then d
        else T.addDays (-8) $ nextMonday d
  where
    nextMonday = D.dateTimeToDay . D.nextMonday . D.dayToDateTime

beginningOfMonth :: T.Day -> T.Day
beginningOfMonth d = T.fromGregorian year month 1
  where
    (year, month, _) = T.toGregorian d

beginningOfQuarter :: T.Day -> T.Day
beginningOfQuarter d = T.fromGregorian year (quarter * 3 + 1) 1
  where
    (year, month, _) = T.toGregorian d
    quarter = div (month - 1) 3

beginningOfYear :: T.Day -> T.Day
beginningOfYear d = T.fromGregorian year 1 1
  where
    (year, _, _) = T.toGregorian d

endOfWeek :: T.Day -> T.Day
endOfWeek = T.addDays 6 . beginningOfWeek

endOfMonth :: T.Day -> T.Day
endOfMonth = T.addDays (-1) . T.addGregorianMonthsClip 1 . beginningOfMonth

endOfQuarter :: T.Day -> T.Day
endOfQuarter = T.addDays (-1) . T.addGregorianMonthsClip 3 . beginningOfQuarter

endOfYear :: T.Day -> T.Day
endOfYear = T.addDays (-1) . T.addGregorianYearsClip 1 . beginningOfYear

thisWeek :: T.Day -> [T.Day]
thisWeek = dateRange beginningOfWeek id

thisMonth :: T.Day -> [T.Day]
thisMonth = dateRange beginningOfMonth id

thisQuarter :: T.Day -> [T.Day]
thisQuarter = dateRange beginningOfQuarter id

thisYear :: T.Day -> [T.Day]
thisYear = dateRange beginningOfYear id

lastWeek :: T.Day -> [T.Day]
lastWeek = allWeek . T.addDays (-1) . beginningOfWeek

lastMonth :: T.Day -> [T.Day]
lastMonth = allMonth . T.addDays (-1) . beginningOfMonth

lastQuarter :: T.Day -> [T.Day]
lastQuarter = allQuarter . T.addDays (-1) . beginningOfQuarter

lastYear :: T.Day -> [T.Day]
lastYear = allYear . T.addDays (-1) . beginningOfYear

allWeek :: T.Day -> [T.Day]
allWeek = dateRange beginningOfWeek endOfWeek

allMonth :: T.Day -> [T.Day]
allMonth = dateRange beginningOfMonth endOfMonth

allQuarter :: T.Day -> [T.Day]
allQuarter = dateRange beginningOfQuarter endOfQuarter

allYear :: T.Day -> [T.Day]
allYear = dateRange beginningOfYear endOfYear

isBeginningOfWeek :: T.Day -> Bool
isBeginningOfWeek = ap (==) beginningOfWeek

isBeginningOfMonth :: T.Day -> Bool
isBeginningOfMonth = ap (==) beginningOfMonth

isBeginningOfQuarter :: T.Day -> Bool
isBeginningOfQuarter = ap (==) beginningOfQuarter

isBeginningOfYear :: T.Day -> Bool
isBeginningOfYear = ap (==) beginningOfYear

daysAgo :: Integer -> T.Day -> T.Day
daysAgo = T.addDays . negate

weeksAgo :: Integer -> T.Day -> T.Day
weeksAgo = T.addDays . negate . (*7)

monthsAgo :: Integer -> T.Day -> T.Day
monthsAgo = T.addGregorianMonthsClip . negate

yearsAgo :: Integer -> T.Day -> T.Day
yearsAgo = T.addGregorianYearsClip . negate

daysFromNow :: Integer -> T.Day -> T.Day
daysFromNow = T.addDays

weeksFromNow :: Integer -> T.Day -> T.Day
weeksFromNow = T.addDays . (*7)

monthsFromNow :: Integer -> T.Day -> T.Day
monthsFromNow = T.addGregorianMonthsClip

yearsFromNow :: Integer -> T.Day -> T.Day
yearsFromNow = T.addGregorianYearsClip

dateRange :: (T.Day -> T.Day) -> (T.Day -> T.Day) -> T.Day -> [T.Day]
dateRange f1 f2 d = [(f1 d)..(f2 d)]