Use next week range to compute next week age and next week day of birthdates

4 files changed, 62 insertions, 74 deletions

diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs
index f871860..96783a7 100644
--- a/src/Model/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -5,13 +5,13 @@ module Model.Birthdate
   , renderBirthdate
   , fullname
   , age
-  , ageNextWeek
   , filterBirthdayAt
-  , filterBirthdayBetween
+  , filterBirthdayInside
   ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Maybe (isJust)
 
 import Model.Date
 
@@ -36,18 +36,8 @@ fullname d = T.concat [firstname d, " ", lastname d]
 age :: Date -> Birthdate -> Int
 age currentDate birthdate = yearsGap currentDate (date birthdate)
 
-ageNextWeek :: Date -> Birthdate -> Int
-ageNextWeek currentDate birthdate =
-  (+1) $ (daysGap currentDate (date birthdate)) `div` 365
-
 filterBirthdayAt :: Date -> [Birthdate] -> [Birthdate]
 filterBirthdayAt d = filter (sameDayAndMonth d . date)
 
-filterBirthdayBetween :: Date -> Date -> [Birthdate] -> [Birthdate]
-filterBirthdayBetween begin end =
-  filter (\bd ->
-    let d = date bd
-    in  (  begin `isBeforeOrEqualDayAndMonth` d
-        && d `isBeforeOrEqualDayAndMonth` end
-        )
-  )
+filterBirthdayInside :: [Date] -> [Birthdate] -> [Birthdate]
+filterBirthdayInside dates = filter (isJust . dayAndMonthInRange dates . date)
diff --git a/src/Model/Date.hs b/src/Model/Date.hs
index 081dccc..dd8a09f 100644
--- a/src/Model/Date.hs
+++ b/src/Model/Date.hs
@@ -2,12 +2,14 @@
 
 module Model.Date
   ( Date(..)
+  , SuccessiveDates
   , renderDate
   , getCurrentDate
   , getNextWeek
   , getWeekDay
   , plusDays
   , sameDayAndMonth
+  , dayAndMonthInRange
   , isBeforeOrEqualDayAndMonth
   , yearsGap
   , daysGap
@@ -22,7 +24,7 @@ import Data.Time.LocalTime
 import Data.Time.Format (formatTime, defaultTimeLocale)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, listToMaybe)
 
 import Time (formatCurrentLocale)
 
@@ -49,13 +51,13 @@ getCurrentDate = do
   let zoneNow = utcToLocalTime timezone now
   return . dateFromDay $ localDay zoneNow
 
-getNextWeek :: IO (Date, Date)
+type SuccessiveDates = [Date]
+
+getNextWeek :: IO SuccessiveDates
 getNextWeek = do
   currentDate <- getCurrentDate
   currentDayNumberOfWeek <- (read . T.unpack <$> formatCurrentLocale "%u") :: IO Int
-  let begin = currentDate `plusDays` (8 - currentDayNumberOfWeek)
-  let end = begin `plusDays` 6
-  return (begin, end)
+  return $ map (plusDays currentDate) $ take 7 [(8 - currentDayNumberOfWeek)..]
 
 getWeekDay :: Date -> Text
 getWeekDay = T.toLower . T.pack . formatTime defaultTimeLocale "%A" . dateToDay
@@ -93,3 +95,6 @@ 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
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
index deb720a..8cc8116 100644
--- a/src/Model/Mail.hs
+++ b/src/Model/Mail.hs
@@ -7,6 +7,7 @@ module Model.Mail
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Maybe (fromMaybe)
 
 import Model.Date
 import Model.Birthdate
@@ -49,24 +50,24 @@ mailSubjectSentence event birthdates =
         , if event == Today then "today" else "next week"
         ]
 
-mailBody :: Date -> [Birthdate] -> [Birthdate] -> Text
-mailBody currentDate birthdaysToday birthdaysNextWeek =
+mailBody :: Date -> SuccessiveDates -> [Birthdate] -> [Birthdate] -> Text
+mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek =
   T.concat
     [ if not . null $ birthdaysToday
-        then mailBodySentence Today currentDate birthdaysToday
+        then mailBodySentence Today currentDate nextWeek birthdaysToday
         else ""
     , if not . null $ birthdaysNextWeek
         then
           T.concat
             [ if not . null $ birthdaysToday then " " else ""
-            , mailBodySentence NextWeek currentDate birthdaysNextWeek
+            , mailBodySentence NextWeek currentDate nextWeek birthdaysNextWeek
             ]
         else ""
     ]
 
-mailBodySentence :: Event -> Date -> [Birthdate] -> Text
-mailBodySentence event currentDate birthdates =
-  T.concat $ map (mailBodyPart event currentDate) (attachLines birthdates)
+mailBodySentence :: Event -> Date -> SuccessiveDates -> [Birthdate] -> Text
+mailBodySentence event currentDate nextWeek birthdates =
+  T.concat $ map (mailBodyPart event currentDate nextWeek) (attachLines birthdates)
 
 attachLines :: [Birthdate] -> [(Line, Birthdate)]
 attachLines birthdates =
@@ -83,32 +84,30 @@ data Line =
   | LastLine
   deriving (Eq, Show)
 
-mailBodyPart :: Event -> Date -> (Line, Birthdate) -> Text
-mailBodyPart event currDate (line, birthdate) =
-  T.concat
-    [ case line of
-        x | x `elem` [SingleLine, FirstLine] ->
-          if event == Today then "Today, " else "Next week, "
-        MiddleLine ->
-          ", "
-        LastLine ->
-          " and "
-        _ ->
-          ""
-    , fullname birthdate
-    , if event == Today then " is " else " will be "
-    , T.pack . show $
-        if event == Today
-          then age currDate birthdate
-          else ageNextWeek currDate birthdate
-    , " years old"
-    , if event == NextWeek
-        then
-          T.concat
-            [ " on "
-            , getWeekDay $ (date birthdate) { year = year currDate }
-            ]
-        else
-          ""
-    , if line == SingleLine || line == LastLine then "." else ""
-    ]
+mailBodyPart :: Event -> Date -> SuccessiveDates -> (Line, Birthdate) -> Text
+mailBodyPart event currDate nextWeek (line, birthdate) =
+  let nextWeekDay = dayAndMonthInRange nextWeek (date birthdate)
+  in  T.concat
+        [ case line of
+            x | x `elem` [SingleLine, FirstLine] ->
+              if event == Today then "Today, " else "Next week, "
+            MiddleLine ->
+              ", "
+            LastLine ->
+              " and "
+            _ ->
+              ""
+        , fullname birthdate
+        , if event == Today then " is " else " will be "
+        , T.pack . show $
+            if event == Today
+              then age currDate birthdate
+              else fromMaybe 0 $ (\d -> year d - year (date birthdate)) <$> nextWeekDay
+        , " years old"
+        , if event == NextWeek
+            then
+              fromMaybe "" $ (\d -> T.concat [" on " , getWeekDay d]) <$> nextWeekDay
+            else
+              ""
+        , if line == SingleLine || line == LastLine then "." else ""
+        ]
diff --git a/src/Notification.hs b/src/Notification.hs
index 18cd260..6e6677e 100644
--- a/src/Notification.hs
+++ b/src/Notification.hs
@@ -9,37 +9,31 @@ import qualified Data.Text as T
 import SendMail (sendMail)
 import Time (formatCurrentLocale)
 
-import Model.Date (getCurrentDate, getNextWeek)
-import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayBetween)
+import Model.Date (getCurrentDate, getNextWeek, SuccessiveDates)
+import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayInside)
 import Model.Mail (mailSubject, mailBody)
 import Model.Config
 
 notifyTodayAndNextWeek :: [Birthdate] -> Config -> IO ()
 notifyTodayAndNextWeek birthdates config = do
   currentDate <- getCurrentDate
-  birthdaysToday <- filterBirthdaysToday birthdates
-  birthdaysNextWeek <- filterBirthdaysNextWeek birthdates config
+  let birthdaysToday = filterBirthdayAt currentDate birthdates
+  nextWeek <- getNextWeek
+  birthdaysNextWeek <- filterBirthdaysNextWeek config nextWeek birthdates
   if length birthdaysToday > 0 || length birthdaysNextWeek > 0
     then
       sendMail
         (mailTo config)
         (mailFrom config)
         (mailSubject birthdaysToday birthdaysNextWeek)
-        (mailBody currentDate birthdaysToday birthdaysNextWeek)
+        (mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek)
     else
       return ()
 
-filterBirthdaysToday :: [Birthdate] -> IO [Birthdate]
-filterBirthdaysToday birthdates = do
-  currentDate <- getCurrentDate
-  return (filterBirthdayAt currentDate birthdates)
-
-filterBirthdaysNextWeek :: [Birthdate] -> Config -> IO [Birthdate]
-filterBirthdaysNextWeek birthdates config = do
-  currentDayOfWeek <- formatCurrentLocale "%A"
-  if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config)
-    then do
-      (begin, end) <- getNextWeek
-      return (filterBirthdayBetween begin end birthdates)
-    else
-      return []
+filterBirthdaysNextWeek :: Config -> SuccessiveDates -> [Birthdate] -> IO [Birthdate]
+filterBirthdaysNextWeek config nextWeek birthdates =
+  (\currentDayOfWeek ->
+    if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config)
+      then filterBirthdayInside nextWeek birthdates
+      else []
+  ) <$> formatCurrentLocale "%A"