Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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)]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment