{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Data.Dates.Parsing
(
Config (..)
, DateTime (..)
, DateInterval (..)
, Time (..)
, defaultConfig
, defaultConfigIO
, parseDate
, parseDateTime
, pAbsDateTime
, pAbsDate
, pDate
, pDateTime
, time
, pDateInterval
, weekdayToInterval
, dateWeekDay
, getStartOfThisWeek
, getStartOfNextWeek
, lastDate
, nextDate
, addInterval
, negateInterval
, minusInterval
, dateInFormat
, extractDates, extractDatesY
, extractDateTimes, extractDateTimesY
, extract
) where
import Control.Lens
import Control.Monad
import Data.Char (toLower)
import Data.Data (Data, Typeable)
import Data.Hourglass
import Data.List (intercalate, find)
import Data.Maybe (catMaybes)
import Text.Parsec
import Text.Read (readMaybe)
import Time.System (dateCurrent)
import Data.Dates.Parsing.Internal
data DateInterval = Days Int
| Weeks Int
| Months Int
| Years Int
deriving (Eq,Show,Data,Typeable)
data Config = Config
{ _now :: DateTime
, _startOfWeekDay :: WeekDay}
makeLenses ''Config
defaultConfig :: DateTime -> Config
defaultConfig now' = Config
{
_now = now'
, _startOfWeekDay = Monday
}
defaultConfigIO :: IO Config
defaultConfigIO = defaultConfig <$> dateCurrent
weekdayToInterval :: Config -> WeekDay -> DateInterval
weekdayToInterval c wd =
Days (fromIntegral $ fromEnum wd - fromEnum (c^.startOfWeekDay))
getStartOfThisWeek :: Config -> DateTime
getStartOfThisWeek c = (c^.now) `minusInterval` weekdayToInterval c (dateWeekDay (c^.now))
getStartOfNextWeek :: Config -> DateTime
getStartOfNextWeek c = getStartOfThisWeek c `addInterval` Weeks 1
dateWeekDay :: DateTime -> WeekDay
dateWeekDay = getWeekDay . timeGetDate
lookupMonth :: String -> Either [Month] Month
lookupMonth = uniqFuzzyMatch
time :: Stream s m Char => ParsecT s st m TimeOfDay
time = do
h <- fromIntegral <$> number 2 23
minSep <- optionMaybe $ char ':' <|> char '.'
(m, mOffset) <-
case minSep of
Nothing -> (0,) <$> (optional spaces >> optionMaybe ampm)
Just _ -> do
m <- number 2 59
(m,) <$> (optional spaces >> optionMaybe ampm)
sep <- optionMaybe $ char ':' <|> char '.'
(s, offset) <-
case sep of
Nothing -> (0,) <$> (optional spaces >> optionMaybe ampm)
Just _ -> do
s <- number 2 59
(s,) <$> (optional spaces >> optionMaybe ampm)
if h > 12 then
pure $ TimeOfDay (Hours h) (Minutes m) (Seconds s) 0
else
case (mOffset, offset) of
(Just mo, _) -> pure $ TimeOfDay (Hours (h + fromIntegral mo)) (Minutes m) (Seconds s) 0
(Nothing, Just o) -> pure $ TimeOfDay (Hours (h + fromIntegral o)) (Minutes m) (Seconds s) 0
(Nothing, Nothing)-> pure $ TimeOfDay (Hours h) (Minutes m) (Seconds s) 0
ampm :: Stream s m Char => ParsecT s st m Int
ampm = do
s <- many1 letter
case uppercase s of
"AM" -> return 0
"PM" -> return 12
_ -> fail "AM/PM expected"
newtype DateFormat = DateFormat [(DatePart, String)]
data DatePart = D | M | Y
data DatePartVal = DV Int | MV Month | YV Int
datePart :: Stream s m Char => DatePart -> ParsecT s st m DatePartVal
datePart M = MV <$> pMonth
datePart D = DV <$> pDay
datePart Y = YV <$> pYear
isYV (YV _) = True
isYV _ = False
isMV (MV _) = True
isMV _ = False
isDV (DV _) = True
isDV _ = False
monthPart :: [DatePartVal] -> Month
monthPart = maybe January (\(MV m) -> m) . find isMV
dayPart :: [DatePartVal] -> Int
dayPart = maybe 1 (\(DV d) -> d) . find isDV
yearPart :: Int -> [DatePartVal] -> Int
yearPart year = maybe year (\(YV y) -> y) . find isYV
makeFormat :: String -> [DatePart] -> DateFormat
makeFormat sep parts = DateFormat $ zip parts $ repeat sep
dateInFormat year (DateFormat parts) = do
partVals <- zipWithM go [1..] parts
pure $ Date (yearPart year partVals) (monthPart partVals) (dayPart partVals)
where
go i (p, sep)
| i == length parts = datePart p
| otherwise = do
v <- datePart p
string sep
pure v
euroNumDate = makeFormat "." [D, M, Y]
writtenDate = DateFormat [(M, " "), (D, ","), (Y, "")]
americanDate = makeFormat "/" [M, D, Y]
dashDate = makeFormat "-" [Y, M, D]
strDate = makeFormat " " [D, M, Y]
spaceDate = makeFormat " " [D, M]
spaceDateMD = makeFormat " " [M, D]
dotDateMonth = makeFormat "." [D, M]
dashDateMonth = makeFormat "-" [M, D]
slashDateMonth = makeFormat "/" [M, D]
pAbsDateTime :: Stream s m Char => Int -> ParsecT s st m DateTime
pAbsDateTime year = do
date <- pAbsDate year
optional spaces
optional $ string "at"
optional spaces
maybeT <- optionMaybe time
case maybeT of
Nothing -> pure $ DateTime date (TimeOfDay 0 0 0 0)
Just t -> pure $ DateTime date t
pAbsDate :: Stream s m Char => Int -> ParsecT s st m Date
pAbsDate year = choice $ map (try . dateInFormat year)
[euroNumDate, americanDate, strDate, writtenDate, dashDate,
dotDateMonth, dashDateMonth, slashDateMonth, spaceDate, spaceDateMD]
intervalToPeriod :: DateInterval -> Period
intervalToPeriod (Days ds) = mempty { periodDays = ds}
intervalToPeriod (Weeks ws) = mempty { periodDays = ws*7 }
intervalToPeriod (Months ms) = mempty { periodMonths = ms }
intervalToPeriod (Years ys) = mempty { periodYears = ys }
addInterval :: DateTime -> DateInterval -> DateTime
addInterval dt@DateTime {dtDate = date} interval =
dt { dtDate = date `dateAddPeriod` intervalToPeriod interval }
negateInterval :: DateInterval -> DateInterval
negateInterval (Days n) = Days (negate n)
negateInterval (Weeks n) = Weeks (negate n)
negateInterval (Months n) = Months (negate n)
negateInterval (Years n) = Years (negate n)
minusInterval :: DateTime -> DateInterval -> DateTime
minusInterval date int = date `addInterval` negateInterval int
maybePlural :: Stream s m Char => String -> ParsecT s st m String
maybePlural str = do
r <- string str
optional $ char 's'
return r
pDateIntervalType :: Stream s m Char => ParsecT s st m (Int -> DateInterval)
pDateIntervalType = do
s <- choice $ map maybePlural ["day", "week", "month", "year"]
case toLower (head s) of
'd' -> return Days
'w' -> return Weeks
'm' -> return Months
'y' -> return Years
_ -> fail $ "Unknown date interval type: " ++ s
pDateInterval :: Stream s m Char => ParsecT s st m DateInterval
pDateInterval = do
maybeN <- readMaybe <$> many1 digit
case maybeN of
Nothing -> fail "Noperino."
Just n -> do
spaces
tp <- pDateIntervalType
pure $ tp n
pRelDate :: Stream s m Char => Config -> ParsecT s st m DateTime
pRelDate c = do
offs <- try futureDate
<|> try passDate
<|> try today
<|> try tomorrow
<|> yesterday
return $ (c^.now) `addInterval` offs
lastDate :: Stream s m Char => Config -> ParsecT s st m DateTime
lastDate c = do
string "last"
spaces
try byweek <|> try bymonth <|> byyear
where
startOfWeekDay' = c^.startOfWeekDay
now' = c^.now
byweek = do
wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay
let lastWeekStart = getStartOfThisWeek c `minusInterval` Weeks 1
return $ lastWeekStart `addInterval` weekdayToInterval c wd
bymonth = do
string "month"
let lastMonth = now' `minusInterval` Months 1
return $ lastMonth { dtDate = (dtDate lastMonth) { dateDay = 1 } }
byyear = do
string "year"
let lastYear = now' `minusInterval` Years 1
return $ lastYear { dtDate = (dtDate lastYear) { dateMonth = January, dateDay = 1 } }
nextDate :: Stream s m Char => Config -> ParsecT s st m DateTime
nextDate c = do
string "next"
spaces
try byweek <|> try bymonth <|> byyear
where
startOfWeekDay' = c^.startOfWeekDay
now' = c^.now
byweek = do
wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay
let nextWeekStart = getStartOfNextWeek c
return $ nextWeekStart `addInterval` weekdayToInterval c wd
bymonth = do
string "month"
let nextMonth = now' `addInterval` Months 1
return nextMonth { dtDate = (dtDate nextMonth) { dateDay = 1 } }
byyear = do
string "year"
let nextYear = now' `addInterval` Years 1
return nextYear { dtDate = (dtDate nextYear) { dateMonth = January, dateDay = 1 } }
pWeekDay :: Stream s m Char => ParsecT s st m WeekDay
pWeekDay = do
w <- many1 (oneOf "mondaytueswnhrfi")
case uniqFuzzyMatch w :: Either [WeekDay] WeekDay of
Left ds -> fail $ if null ds
then "unknown weekday: " ++ w
else "ambiguous weekday '" ++ w ++ "' could mean: " ++ intercalate " or " (map show ds)
Right d -> return d
futureDate :: Stream s m Char => ParsecT s st m DateInterval
futureDate = do
string "in "
maybeN <- readMaybe <$> many1 digit
case maybeN of
Nothing -> fail "Noperino."
Just n -> do
char ' '
tp <- pDateIntervalType
pure $ tp n
passDate :: Stream s m Char => ParsecT s st m DateInterval
passDate = do
maybeN <- readMaybe <$> many1 digit
case maybeN of
Nothing -> fail "Noperino."
Just n -> do
char ' '
tp <- pDateIntervalType
string " ago"
pure $ tp $ negate n
today :: Stream s m Char => ParsecT s st m DateInterval
today = do
string "today" <|> string "now"
return $ Days 0
tomorrow :: Stream s m Char => ParsecT s st m DateInterval
tomorrow = do
string "tomorrow"
return $ Days 1
yesterday :: Stream s m Char => ParsecT s st m DateInterval
yesterday = do
string "yesterday"
return $ Days (-1)
pByWeek :: Stream s m Char => Config -> ParsecT s st m DateTime
pByWeek c =
try (lastDate c) <|> nextDate c
pDateTime :: Stream s m Char
=> Config
-> ParsecT s st m DateTime
pDateTime c =
try (pRelDate c)
<|> try (pByWeek c)
<|> try (pAbsDateTime (dateYear (timeGetDate (c^.now))))
pDate :: Stream s m Char
=> Config
-> ParsecT s st m Date
pDate c =
try (timeGetDate <$> pRelDate c)
<|> try (timeGetDate <$> pByWeek c)
<|> try (pAbsDate $ dateYear (timeGetDate (c^.now)))
parseDate :: Config
-> String
-> Either ParseError Date
parseDate c = runParser (pDate c) () ""
parseDateTime :: Config
-> String
-> Either ParseError DateTime
parseDateTime c = runParser (pDateTime c) () ""
extractDates :: String -> IO [Date]
extractDates str = do
c <- defaultConfigIO
pure $ extractDatesY (dateYear (timeGetDate (c ^. now))) str
extractDatesY :: Int -> String -> [Date]
extractDatesY y str =
case parse (extract (pAbsDate y)) "" str of
Left err -> error $ show err
Right dates -> dates
extractDateTimes :: String -> IO [DateTime]
extractDateTimes str = do
c <- defaultConfigIO
pure $ extractDateTimesY (dateYear (timeGetDate (c ^. now))) str
extractDateTimesY :: Int -> String -> [DateTime]
extractDateTimesY y str =
case parse (extract (pAbsDateTime y)) "" str of
Left err -> error $ show err
Right dates -> dates
extract :: Stream s m Char => ParsecT s st m a -> ParsecT s st m [a]
extract parser = catMaybes <$> Text.Parsec.manyTill (try (Just <$> loop) <|> (anyChar >> pure Nothing)) eof
where
loop = try parser <|> do
anyChar
notFollowedBy eof
loop