{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Dates.Parsing
(
Config (..)
, DateTime (..)
, DateInterval (..)
, Time (..)
, defaultConfig
, defaultConfigIO
, parseDate
, parseDateTime
, pAbsDateTime
, pAbsDate
, pDate
, pDateTime
, pTime
, pDateInterval
, weekdayToInterval
, dateWeekDay
, getStartOfThisWeek
, getStartOfNextWeek
, lastDate
, nextDate
, addInterval
, negateInterval
, minusInterval
, dateInFormat
, extractDates, extractDatesY, 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 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 => Hours -> ParsecT s st m TimeOfDay
time hMax = do
h <- number 2 hMax
char ':'
m <- number 2 59
x <- optionMaybe $ char ':'
case x of
Nothing -> return $ TimeOfDay h m 0 0
Just _ -> do
s <- number 2 59
notFollowedBy letter
return $ TimeOfDay h m s 0
time24 :: Stream s m Char => ParsecT s st m TimeOfDay
time24 = time 23
time12 :: Stream s m Char => ParsecT s st m TimeOfDay
time12 = time 12
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"
pTime :: Stream s m Char => ParsecT s st m TimeOfDay
pTime = choice $ map try [time12, time24]
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 $ char ','
s <- optionMaybe space
case s of
Nothing -> return $ DateTime date (TimeOfDay 0 0 0 0)
Just _ -> do
t <- pTime
return $ 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
extract :: Stream s m Char => ParsecT s st m a -> ParsecT s st m [a]
extract parser = Text.Parsec.many loop
where
loop = try parser <|> (anyChar >> loop)