aboutsummaryrefslogtreecommitdiff
path: root/src/Model
diff options
context:
space:
mode:
Diffstat (limited to 'src/Model')
-rw-r--r--src/Model/Birthdate.hs11
-rw-r--r--src/Model/BirthdateParser.hs19
-rw-r--r--src/Model/Date.hs19
-rw-r--r--src/Model/Mail.hs5
4 files changed, 50 insertions, 4 deletions
diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs
index 32bd6a4..f871860 100644
--- a/src/Model/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -2,8 +2,10 @@
module Model.Birthdate
( Birthdate(..)
+ , renderBirthdate
, fullname
, age
+ , ageNextWeek
, filterBirthdayAt
, filterBirthdayBetween
) where
@@ -19,6 +21,15 @@ data Birthdate = Birthdate
, lastname :: Text
} deriving (Eq, Show)
+renderBirthdate :: Birthdate -> Text
+renderBirthdate birthdate =
+ T.concat
+ [ fullname birthdate
+ , " ("
+ , renderDate (date birthdate)
+ , ")"
+ ]
+
fullname :: Birthdate -> Text
fullname d = T.concat [firstname d, " ", lastname d]
diff --git a/src/Model/BirthdateParser.hs b/src/Model/BirthdateParser.hs
index c9ac3b9..8e8489b 100644
--- a/src/Model/BirthdateParser.hs
+++ b/src/Model/BirthdateParser.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Model.BirthdateParser
( parseBirthdates
) where
@@ -14,9 +16,20 @@ import Model.Date
parseBirthdates :: Text -> Either Text [Birthdate]
parseBirthdates input =
- left
- (T.pack . show)
- (parse birthdatesParser "" (T.unpack input))
+ left (T.pack . show) (parse birthdatesParser "" (T.unpack input)) >>= validateBirthdates
+
+validateBirthdates :: [Birthdate] -> Either Text [Birthdate]
+validateBirthdates birthdates =
+ let invalid = filter (not . isValid . date) birthdates
+ in if null invalid
+ then
+ Right birthdates
+ else
+ Left $
+ T.concat
+ [ "Invalid birthdates: "
+ , T.intercalate ", " (map renderBirthdate invalid)
+ ]
birthdatesParser :: Parser [Birthdate]
birthdatesParser = many (many newline >> birthdateParser <* many newline)
diff --git a/src/Model/Date.hs b/src/Model/Date.hs
index e095cc6..60108e9 100644
--- a/src/Model/Date.hs
+++ b/src/Model/Date.hs
@@ -2,6 +2,7 @@
module Model.Date
( Date(..)
+ , renderDate
, getCurrentDate
, getNextWeek
, plusDays
@@ -9,12 +10,17 @@ module Model.Date
, isBeforeOrEqualDayAndMonth
, yearsGap
, daysGap
+ , isValid
) where
+import Text.Printf (printf)
+
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.LocalTime
+import Data.Text (Text)
import qualified Data.Text as T
+import Data.Maybe (isJust)
import Time (formatCurrentLocale)
@@ -24,6 +30,16 @@ data Date = Date
, 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
@@ -69,3 +85,6 @@ 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
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
index 19ebaeb..2ae8df4 100644
--- a/src/Model/Mail.hs
+++ b/src/Model/Mail.hs
@@ -97,7 +97,10 @@ mailBodyPart event currDate (line, birthdate) =
""
, fullname birthdate
, if event == Today then " is " else " will be "
- , T.pack . show $ age currDate birthdate
+ , T.pack . show $
+ if event == Today
+ then age currDate birthdate
+ else ageNextWeek currDate birthdate
, " years old"
, if line == SingleLine || line == LastLine then "." else ""
]