diff options
| -rw-r--r-- | README.md | 4 | ||||
| -rw-r--r-- | birthday.cabal | 1 | ||||
| -rw-r--r-- | src/Birthdate.hs | 50 | ||||
| -rw-r--r-- | src/BirthdateParser.hs | 57 | ||||
| -rw-r--r-- | src/Date.hs | 4 | ||||
| -rw-r--r-- | src/Mail.hs | 22 | ||||
| -rw-r--r-- | src/Main.hs | 13 |
7 files changed, 81 insertions, 70 deletions
@@ -5,8 +5,8 @@ Notify by email if there is a birthday today. Birthdates are parsed from birthdates.csv: ``` -23/10/1982 , Dupont , Jean -30/01/1955 , Doe , Anne +23 Octobre 1982, Dupont, Jean +30 Janvier 1955, Doe , Anne … ``` diff --git a/birthday.cabal b/birthday.cabal index 29bafad..cd8393e 100644 --- a/birthday.cabal +++ b/birthday.cabal @@ -15,3 +15,4 @@ executable birthday , time == 1.5.0.1 , ConfigFile == 1.1.4 , transformers == 0.4.3.0 + , parsec == 3.1.9 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 |