aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Birthdate.hs50
-rw-r--r--src/BirthdateParser.hs57
-rw-r--r--src/Date.hs4
-rw-r--r--src/Mail.hs22
-rw-r--r--src/Main.hs13
5 files changed, 78 insertions, 68 deletions
diff --git a/src/Birthdate.hs b/src/Birthdate.hs
index 2ef1bcb..4c6e398 100644
--- a/src/Birthdate.hs
+++ b/src/Birthdate.hs
@@ -4,17 +4,13 @@ module Birthdate
( Birthdate(..)
, fullname
, age
- , readBirthdates
, filterBirthday
) where
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import qualified Data.Text.Read as T
-import Data.Either (partitionEithers)
-import Date (Date(Date), sameDayAndMonth, yearsGap)
+import Date (Date, sameDayAndMonth, yearsGap)
data Birthdate = Birthdate
{ date :: Date
@@ -28,49 +24,5 @@ fullname d = T.concat [firstname d, " ", lastname d]
age :: Date -> Birthdate -> Int
age currentDate birthdate = yearsGap currentDate (date birthdate)
-readBirthdates :: FilePath -> IO (Either Text [Birthdate])
-readBirthdates path = do
- eitherBirthdates <- map parseBirthdate . zip [1..] . T.lines <$> T.readFile path
- return $
- case partitionEithers eitherBirthdates of
- ([], birthdates) ->
- Right birthdates
- (errors, _) ->
- Left $ T.intercalate "\n" errors
-
-parseBirthdate :: (Int, Text) -> Either Text Birthdate
-parseBirthdate (line, text) =
- case map T.strip $ T.splitOn "," text of
- [date, lastname, firstname] ->
- case map T.decimal $ T.splitOn "/" date of
- [Right (day, ""), Right (month, ""), Right (year, "")] ->
- Right Birthdate
- { date = Date year month day
- , lastname = lastname
- , firstname = firstname
- }
- _ ->
- Left $ T.concat
- [ lineOutput line
- , " birthdate: "
- , date
- , ". (Required: year/month/day)"
- ]
- _ ->
- Left $ T.concat
- [ lineOutput line
- , " line: "
- , text
- , ". (Required: date, lastname, firstname)"
- ]
-
-lineOutput :: Int -> Text
-lineOutput line =
- T.concat
- [ "[L"
- , T.pack . show $ line
- , "]"
- ]
-
filterBirthday :: Date -> [Birthdate] -> [Birthdate]
filterBirthday d = filter (sameDayAndMonth d . date)
diff --git a/src/BirthdateParser.hs b/src/BirthdateParser.hs
new file mode 100644
index 0000000..1e4051b
--- /dev/null
+++ b/src/BirthdateParser.hs
@@ -0,0 +1,57 @@
+module BirthdateParser
+ ( parseBirthdates
+ ) where
+
+import Control.Arrow (left)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.ParserCombinators.Parsec
+
+import Birthdate
+import Date
+
+parseBirthdates :: Text -> Either Text [Birthdate]
+parseBirthdates input =
+ left
+ (T.pack . show)
+ (parse birthdatesParser "" (T.unpack input))
+
+birthdatesParser :: Parser [Birthdate]
+birthdatesParser = many (many newline >> birthdateParser <* many newline)
+
+birthdateParser :: Parser Birthdate
+birthdateParser =
+ Birthdate <$>
+ dateParser <* spaces <* char ',' <*>
+ valueParser <* char ',' <*>
+ valueParser
+
+valueParser :: Parser Text
+valueParser = T.strip . T.pack <$> many (noneOf ",\n")
+
+dateParser :: Parser Date
+dateParser =
+ Date <$>
+ integerParser <* spaces <*>
+ monthParser <* spaces <*>
+ integerParser
+
+integerParser :: Parser Int
+integerParser = (read :: String -> Int) <$> many1 digit
+
+monthParser :: Parser Int
+monthParser =
+ (try $ string "Janvier" >> return 1)
+ <|> (try $ string "Février" >> return 2)
+ <|> (try $ string "Mars" >> return 3)
+ <|> (try $ string "Avril" >> return 4)
+ <|> (try $ string "Mai" >> return 5)
+ <|> (try $ string "Juin" >> return 6)
+ <|> (try $ string "Juillet" >> return 7)
+ <|> (try $ string "Août" >> return 8)
+ <|> (try $ string "Septembre" >> return 9)
+ <|> (try $ string "Octobre" >> return 10)
+ <|> (try $ string "Novembre" >> return 11)
+ <|> (try $ string "Décembre" >> return 12)
diff --git a/src/Date.hs b/src/Date.hs
index efbef8c..07f0672 100644
--- a/src/Date.hs
+++ b/src/Date.hs
@@ -20,8 +20,8 @@ getCurrentDate = do
now <- getCurrentTime
timezone <- getCurrentTimeZone
let zoneNow = utcToLocalTime timezone now
- let (year, month, day) = toGregorian $ localDay zoneNow
- return $ Date (fromIntegral year) month day
+ let (y, m, d) = toGregorian $ localDay zoneNow
+ return $ Date (fromIntegral y) m d
sameDayAndMonth :: Date -> Date -> Bool
sameDayAndMonth (Date _ m1 d1) (Date _ m2 d2) = m1 == m2 && d1 == d2
diff --git a/src/Mail.hs b/src/Mail.hs
index 7bb6814..dc533ef 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -27,9 +27,9 @@ mailSubject birthdates =
mailBody :: Date -> [Birthdate] -> Text
mailBody currentDate birthdates =
let count = length birthdates
- birthdatesWithLines = map (mapFst getLine) . zip [1..] $ birthdates
- getLine 1 = if count == 1 then SingleLine else FirstLine
- getLine line = if line == count then LastLine else MiddleLine
+ birthdatesWithLines = map (mapFst lineKind) . zip [1..] $ birthdates
+ lineKind 1 = if count == 1 then SingleLine else FirstLine
+ lineKind line = if line == count then LastLine else MiddleLine
in T.concat $ map (mailLine currentDate) birthdatesWithLines
mapFst :: (a -> c) -> (a, b) -> (c, b)
@@ -43,33 +43,33 @@ data Line =
deriving (Eq, Show)
mailLine :: Date -> (Line, Birthdate) -> Text
-mailLine date (SingleLine, birthdate) =
+mailLine currDate (SingleLine, birthdate) =
T.concat
[ fullname birthdate
, " is now "
- , T.pack . show $ age date birthdate
+ , T.pack . show $ age currDate birthdate
, " years old."
]
-mailLine date (FirstLine, birthdate) =
+mailLine currDate (FirstLine, birthdate) =
T.concat
[ fullname birthdate
, " is now "
- , T.pack . show $ age date birthdate
+ , T.pack . show $ age currDate birthdate
, " years old"
]
-mailLine date (MiddleLine, birthdate) =
+mailLine currDate (MiddleLine, birthdate) =
T.concat
[ ", "
, fullname birthdate
, " is "
- , T.pack . show $ age date birthdate
+ , T.pack . show $ age currDate birthdate
, " years old"
]
-mailLine date (LastLine, birthdate) =
+mailLine currDate (LastLine, birthdate) =
T.concat
[ " and "
, fullname birthdate
, " is "
- , T.pack . show $ age date birthdate
+ , T.pack . show $ age currDate birthdate
, " years old."
]
diff --git a/src/Main.hs b/src/Main.hs
index 9debfe1..9b5541c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,7 +10,8 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T
import Date (getCurrentDate)
-import Birthdate (readBirthdates, filterBirthday)
+import Birthdate (filterBirthday)
+import BirthdateParser (parseBirthdates)
import Mail (mailSubject, mailBody)
import SendMail (sendMail)
import Config
@@ -23,24 +24,24 @@ configPath = "config.txt"
main :: IO ()
main = do
- eitherBirthdates <- readBirthdates birthdatePath
+ eitherBirthdates <- parseBirthdates <$> T.readFile birthdatePath
eitherConfig <- getConfig configPath
case (eitherBirthdates, eitherConfig) of
- (Left error, _) ->
+ (Left err, _) ->
T.hPutStr stderr $
T.concat
[ "Error while parsing file "
, T.pack birthdatePath
, ":\n"
- , error
+ , err
]
- (_, Left error) ->
+ (_, Left err) ->
T.hPutStr stderr $
T.concat
[ "Error while parsing config file "
, T.pack birthdatePath
, ":\n"
- , error
+ , err
]
(Right birthdates, Right config) -> do
currentDate <- getCurrentDate