lib: fix error triggered by upper-case day in period expression (#847)

This commit is contained in:
Simon Michael 2018-07-24 14:36:45 +01:00
parent da8047d286
commit aab7d2d964

View File

@ -625,10 +625,12 @@ nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d = nthWeekdaySameM
-- | Advance to nth weekday wd after given start day s
advancetonthweekday :: Int -> WeekDay -> Day -> Day
advancetonthweekday n wd s = addWeeks (n-1) . firstMatch (>=s) . iterate (addWeeks 1) $ firstweekday s
where
advancetonthweekday n wd s =
maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s
where
err = error' "advancetonthweekday: should not happen"
addWeeks k = addDays (7 * fromIntegral k)
firstMatch p = head . dropWhile (not . p)
firstMatch p = headMay . dropWhile (not . p)
firstweekday = addDays (fromIntegral wd-1) . startofweek
----------------------------------------------------------------------
@ -827,6 +829,7 @@ md = do
failIfInvalidDay d
return ("",m,d)
-- These are compared case insensitively, and should all be kept lower case.
months = ["january","february","march","april","may","june",
"july","august","september","october","november","december"]
monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
@ -850,9 +853,11 @@ mon = do
weekday :: TextParser m Int
weekday = do
wday <- choice . map string' $ weekdays ++ weekdayabbrevs
let i = head . catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs]
return (i+1)
wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)
case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of
(i:_) -> return (i+1)
[] -> fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
today,yesterday,tomorrow :: TextParser m SmartDate
today = string' "today" >> return ("","","today")