aboutsummaryrefslogtreecommitdiff
path: root/src/Model/Date.hs
blob: dd8a09f6a755c8cb3c8ffe022e77fc15bed4c3a5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
{-# LANGUAGE OverloadedStrings #-}

module Model.Date
  ( Date(..)
  , SuccessiveDates
  , renderDate
  , getCurrentDate
  , getNextWeek
  , getWeekDay
  , plusDays
  , sameDayAndMonth
  , dayAndMonthInRange
  , isBeforeOrEqualDayAndMonth
  , yearsGap
  , daysGap
  , isValid
  ) where

import Text.Printf (printf)

import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (isJust, listToMaybe)

import Time (formatCurrentLocale)

data Date = Date
  { day :: Int
  , month :: Int
  , year :: Int
  } deriving (Eq, Show)

renderDate :: Date -> Text
renderDate (Date d m y) =
  T.concat
    [ T.pack $ printf "%02d" d
    , "/"
    , T.pack $ printf "%02d" m
    , "/"
    , T.pack . show $ y
    ]

getCurrentDate :: IO Date
getCurrentDate = do
  now <- getCurrentTime
  timezone <- getCurrentTimeZone
  let zoneNow = utcToLocalTime timezone now
  return . dateFromDay $ localDay zoneNow

type SuccessiveDates = [Date]

getNextWeek :: IO SuccessiveDates
getNextWeek = do
  currentDate <- getCurrentDate
  currentDayNumberOfWeek <- (read . T.unpack <$> formatCurrentLocale "%u") :: IO Int
  return $ map (plusDays currentDate) $ take 7 [(8 - currentDayNumberOfWeek)..]

getWeekDay :: Date -> Text
getWeekDay = T.toLower . T.pack . formatTime defaultTimeLocale "%A" . dateToDay

plusDays :: Date -> Int -> Date
plusDays date n = dateFromDay . addDays (toInteger n) . dateToDay $ date

dateToDay :: Date -> Day
dateToDay (Date d m y) = fromGregorian (toInteger y) m d

dateFromDay :: Day -> Date
dateFromDay dayTime =
  let (y, m, d) = toGregorian dayTime
  in  Date d m (fromIntegral y)

sameDayAndMonth :: Date -> Date -> Bool
sameDayAndMonth d1 d2 =
  (  day d1 == day d2
  && month d1 == month d2
  )

isBeforeOrEqualDayAndMonth :: Date -> Date -> Bool
isBeforeOrEqualDayAndMonth d1 d2 =
  (  month d1 < month d2
  || (  month d1 == month d2
     && day d1 <= day d2
     )
  )

yearsGap :: Date -> Date -> Int
yearsGap d1 d2 = abs (year d2 - year d1)

daysGap :: Date -> Date -> Int
daysGap d1 d2 = abs . fromIntegral $ (dateToDay d1) `diffDays` (dateToDay d2)

isValid :: Date -> Bool
isValid (Date d m y) = isJust $ fromGregorianValid (toInteger y) m d

dayAndMonthInRange :: [Date] -> Date -> Maybe Date
dayAndMonthInRange dates date = listToMaybe . filter (sameDayAndMonth date) $ dates