module Data.Dates
(DateTime (..),
Time (..),
WeekDay (..),
parseDate,
pDate, pDateTime, pTime,
pDateInterval,
getCurrentDateTime,
tryRead, tryReadInt,
DateIntervalType (..),
DateInterval (..),
dayToDateTime, dateTimeToDay,
weekdayToInterval,
weekdayNumber,
intToWeekday,
dateWeekDay,
lastMonday, nextMonday,
modifyDate,
datesDifference,
addInterval, negateInterval, minusInterval,
addTime
) where
import Prelude.Unicode
import Data.Char (toUpper)
import Data.List
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.LocalTime
import Text.Parsec
import Data.Generics
import Data.Char (toLower)
import Data.Dates.Types
import Data.Dates.Internal
data DateIntervalType = Day | Week | Month | Year
deriving (Eq,Show,Read,Data,Typeable)
data DateInterval = Days ℤ
| Weeks ℤ
| Months ℤ
| Years ℤ
deriving (Eq,Show,Data,Typeable)
data WeekDay =
Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
| Sunday
deriving (Eq, Show, Read, Ord, Enum, Bounded, Data, Typeable)
weekdayToInterval ∷ WeekDay → DateInterval
weekdayToInterval wd = Days (fromIntegral $ fromEnum wd)
weekdayNumber ∷ WeekDay → Int
weekdayNumber wd = fromEnum wd + 1
intToWeekday ∷ Int → WeekDay
intToWeekday i = toEnum (i 1)
lastMonday ∷ DateTime → DateTime
lastMonday dt = dt `minusInterval` weekdayToInterval (dateWeekDay dt)
nextMonday ∷ DateTime → DateTime
nextMonday dt = lastMonday dt `addInterval` Weeks 1
getCurrentDateTime ∷ IO DateTime
getCurrentDateTime = do
zt ← getZonedTime
let lt = zonedTimeToLocalTime zt
ld = localDay lt
ltod = localTimeOfDay lt
(y,m,d) = toGregorian ld
h = todHour ltod
mins = todMin ltod
s = round $ todSec ltod
return $ DateTime (fromIntegral y) m d h mins s
dateWeekDay ∷ DateTime → WeekDay
dateWeekDay dt =
let (_,_,wd) = toWeekDate (dateTimeToDay dt)
in intToWeekday wd
uppercase ∷ String → String
uppercase = map toUpper
isPrefixOfI ∷ String → String → Bool
p `isPrefixOfI` s = (uppercase p) `isPrefixOf` (uppercase s)
lookupS ∷ String → [(String,a)] → Maybe a
lookupS _ [] = Nothing
lookupS k ((k',v):other) | k `isPrefixOfI` k' = Just v
| otherwise = lookupS k other
monthsN ∷ [(String,Int)]
monthsN = zip months [1..]
lookupMonth ∷ String → Maybe Int
lookupMonth n = lookupS n monthsN
date ∷ Int → Int → Int → DateTime
date y m d = DateTime y m d 0 0 0
addTime ∷ DateTime → Time → DateTime
addTime dt t = dt {
hour = tHour t + hour dt,
minute = tMinute t + minute dt,
second = tSecond t + second dt }
euroNumDate ∷ Stream s m Char => ParsecT s st m DateTime
euroNumDate = do
d ← pDay
char '.'
m ← pMonth
char '.'
y ← pYear
return $ date y m d
americanDate ∷ Stream s m Char => ParsecT s st m DateTime
americanDate = do
y ← pYear
char '/'
m ← pMonth
char '/'
d ← pDay
return $ date y m d
euroNumDate' ∷ Stream s m Char => Int → ParsecT s st m DateTime
euroNumDate' year = do
d ← pDay
char '.'
m ← pMonth
return $ date year m d
americanDate' ∷ Stream s m Char => Int → ParsecT s st m DateTime
americanDate' year = do
m ← pMonth
char '/'
d ← pDay
return $ date year m d
strDate ∷ Stream s m Char => ParsecT s st m DateTime
strDate = do
d ← pDay
space
ms ← many1 letter
case lookupMonth ms of
Nothing → fail $ "unknown month: "++ms
Just m → do
space
y ← pYear
notFollowedBy $ char ':'
return $ date y m d
strDate' ∷ Stream s m Char => Int → ParsecT s st m DateTime
strDate' year = do
d ← pDay
space
ms ← many1 letter
case lookupMonth ms of
Nothing → fail $ "unknown month: "++ms
Just m → return $ date year m d
time24 ∷ Stream s m Char => ParsecT s st m Time
time24 = do
h ← number 2 23
char ':'
m ← number 2 59
x ← optionMaybe $ char ':'
case x of
Nothing → return $ Time h m 0
Just _ → do
s ← number 2 59
notFollowedBy letter
return $ Time h m s
ampm ∷ Stream s m Char => ParsecT s st m Int
ampm = do
s ← many1 letter
case map toUpper s of
"AM" → return 0
"PM" → return 12
_ → fail "AM/PM expected"
time12 ∷ Stream s m Char => ParsecT s st m Time
time12 = do
h ← number 2 12
char ':'
m ← number 2 59
x ← optionMaybe $ char ':'
s ← case x of
Nothing → return 0
Just _ → number 2 59
optional space
hd ← ampm
return $ Time (h+hd) m s
pTime ∷ Stream s m Char => ParsecT s st m Time
pTime = choice $ map try [time12, time24]
pAbsDateTime ∷ Stream s m Char => Int → ParsecT s st m DateTime
pAbsDateTime year = do
date ← choice $ map try $ map ($ year) $ [
const euroNumDate,
const americanDate,
const strDate,
strDate',
euroNumDate',
americanDate']
optional $ char ','
s ← optionMaybe space
case s of
Nothing → return date
Just _ → do
t ← pTime
return $ date `addTime` t
pAbsDate ∷ Stream s m Char => Int → ParsecT s st m DateTime
pAbsDate year =
choice $ map try $ map ($ year) $ [
const euroNumDate,
const americanDate,
const strDate,
strDate',
euroNumDate',
americanDate']
dateTimeToDay ∷ DateTime → Day
dateTimeToDay dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt)
dayToDateTime ∷ Day → DateTime
dayToDateTime dt =
let (y,m,d) = toGregorian dt
in date (fromIntegral y) m d
modifyDate ∷ (t → Day → Day) → t → DateTime → DateTime
modifyDate fn x dt =
let date = dayToDateTime $ fn x $ dateTimeToDay dt
in date {hour = hour dt,
minute = minute dt,
second = second dt}
addInterval ∷ DateTime → DateInterval → DateTime
addInterval dt (Days ds) = modifyDate addDays ds dt
addInterval dt (Weeks ws) = modifyDate addDays (ws*7) dt
addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt
addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt
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
datesDifference ∷ DateTime → DateTime → Integer
datesDifference d1 d2 =
abs $ toModifiedJulianDay (dateTimeToDay d1)
toModifiedJulianDay (dateTimeToDay d2)
maybePlural ∷ Stream s m Char => String → ParsecT s st m String
maybePlural str = do
r ← string str
optional $ char 's'
return (capitalize r)
pDateIntervalType ∷ Stream s m Char => ParsecT s st m DateIntervalType
pDateIntervalType = do
s ← choice $ map maybePlural ["day", "week", "month", "year"]
case toLower (head s) of
'd' → return Day
'w' → return Week
'm' → return Month
'y' → return Year
_ → fail $ "Unknown date interval type: " ++ s
pDateInterval ∷ Stream s m Char => ParsecT s st m DateInterval
pDateInterval = do
n ← many1 digit
spaces
tp ← pDateIntervalType
case tp of
Day → Days `fmap` tryReadInt n
Week → Weeks `fmap` tryReadInt n
Month → Months `fmap` tryReadInt n
Year → Years `fmap` tryReadInt n
pRelDate ∷ Stream s m Char => DateTime → ParsecT s st m DateTime
pRelDate date = do
offs ← try futureDate
<|> try passDate
<|> try today
<|> try tomorrow
<|> yesterday
return $ date `addInterval` offs
lastDate ∷ Stream s m Char => DateTime → ParsecT s st m DateTime
lastDate now = do
string "last"
spaces
try byweek <|> try bymonth <|> byyear
where
byweek = do
wd ← try (string "week" >> return Monday) <|> pWeekDay
let monday = lastMonday now
monday' = if wd > dateWeekDay now
then monday `minusInterval` Weeks 1
else monday
return $ monday' `addInterval` weekdayToInterval wd
bymonth = do
string "month"
return $ now {day = 1}
byyear = do
string "year"
return $ now {month = 1, day = 1}
nextDate ∷ Stream s m Char => DateTime → ParsecT s st m DateTime
nextDate now = do
string "next"
spaces
try byweek <|> try bymonth <|> byyear
where
byweek = do
wd ← try (string "week" >> return Monday) <|> pWeekDay
let monday = nextMonday now
monday' = if wd > dateWeekDay now
then monday `minusInterval` Weeks 1
else monday
return $ monday' `addInterval` weekdayToInterval wd
bymonth = do
string "month"
return (now `addInterval` Months 1) {day = 1}
byyear = do
string "year"
return (now `addInterval` Years 1) {month = 1, day = 1}
pWeekDay ∷ Stream s m Char => ParsecT s st m WeekDay
pWeekDay = do
w ← many1 (oneOf "mondaytueswnhrfi")
case map toLower w of
"monday" → return Monday
"tuesday" → return Tuesday
"wednesday" → return Wednesday
"thursday" → return Thursday
"friday" → return Friday
"saturday" → return Saturday
"sunday" → return Sunday
_ → fail $ "Unknown weekday: " ++ w
futureDate ∷ Stream s m Char => ParsecT s st m DateInterval
futureDate = do
string "in "
n ← many1 digit
char ' '
tp ← pDateIntervalType
case tp of
Day → Days `fmap` tryReadInt n
Week → Weeks `fmap` tryReadInt n
Month → Months `fmap` tryReadInt n
Year → Years `fmap` tryReadInt n
passDate ∷ Stream s m Char => ParsecT s st m DateInterval
passDate = do
n ← many1 digit
char ' '
tp ← pDateIntervalType
string " ago"
case tp of
Day → (Days . negate) `fmap` tryReadInt n
Week → (Weeks . negate) `fmap` tryReadInt n
Month → (Months . negate) `fmap` tryReadInt n
Year → (Years . negate) `fmap` tryReadInt 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 => DateTime → ParsecT s st m DateTime
pByWeek date =
try (lastDate date) <|> nextDate date
pDateTime ∷ Stream s m Char => DateTime
→ ParsecT s st m DateTime
pDateTime date =
(try $ pRelDate date)
<|> (try $ pByWeek date)
<|> (try $ pAbsDateTime $ year date)
pDate ∷ Stream s m Char => DateTime
→ ParsecT s st m DateTime
pDate date =
(try $ pRelDate date)
<|> (try $ pByWeek date)
<|> (try $ pAbsDate $ year date)
parseDate ∷ DateTime
→ String
→ Either ParseError DateTime
parseDate date s = runParser (pDate date) () "" s