dates 0.2.0.2 → 0.2.1.0
raw patch · 2 files changed
+173/−26 lines, 2 filesdep ~basedep ~time
Dependency ranges changed: base, time
Files
- Data/Dates.hs +166/−23
- dates.cabal +7/−3
Data/Dates.hs view
@@ -3,19 +3,31 @@ module Data.Dates (DateTime (..), Time (..),+ WeekDay (..), parseDate, pDate, pDateTime, pTime,+ pDateInterval, getCurrentDateTime, tryRead, DateIntervalType (..), DateInterval (..),- addInterval, addTime+ 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 Text.Parsec.String@@ -24,6 +36,45 @@ 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)++-- | Weekday as interval from Monday, so that+-- weekdayToInterval Monday == 0 and+-- weekdayToInterval Sunday == 6.+weekdayToInterval ∷ WeekDay → DateInterval+weekdayToInterval wd = Days (fromIntegral $ fromEnum wd)++-- | Number of weekday, with Monday == 1 and Sunday == 7.+weekdayNumber ∷ WeekDay → Int+weekdayNumber wd = fromEnum wd + 1++-- | Reverse for weekdayNumber+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+ -- | Get current date and time. getCurrentDateTime ∷ IO DateTime getCurrentDateTime = do@@ -37,6 +88,12 @@ s = round $ todSec ltod return $ DateTime (fromIntegral y) m d h mins s +-- | Get weekday of given date.+dateWeekDay ∷ DateTime → WeekDay+dateWeekDay dt =+ let (_,_,wd) = toWeekDate (dateTimeToDay dt)+ in intToWeekday wd+ uppercase ∷ String → String uppercase = map toUpper @@ -181,54 +238,130 @@ euroNumDate', americanDate'] -data DateIntervalType = Day | Week | Month | Year- deriving (Eq,Show,Read)--data DateInterval = Days ℤ- | Weeks ℤ- | Months ℤ- | Years ℤ- deriving (Eq,Show)--convertTo ∷ DateTime → Day-convertTo dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt)+-- | Convert date from DateTime to Day+dateTimeToDay ∷ DateTime → Day+dateTimeToDay dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt) -convertFrom ∷ Day → DateTime-convertFrom dt = +-- | Convert date from Day to DateTime+dayToDateTime ∷ Day → DateTime+dayToDateTime dt = let (y,m,d) = toGregorian dt in date (fromIntegral y) m d +-- | Modify DateTime with pure function on Day modifyDate ∷ (t → Day → Day) → t → DateTime → DateTime-modifyDate fn x dt = convertFrom $ fn x $ convertTo dt+modifyDate fn x dt = dayToDateTime $ fn x $ dateTimeToDay dt +-- | Add date interval to DateTime 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 +-- | Negate DateInterval value: Days 3 → Days (-3).+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)++-- | Subtract DateInterval from DateTime.+minusInterval ∷ DateTime → DateInterval → DateTime+minusInterval date int = date `addInterval` negateInterval int++-- | Number of days between two dates+datesDifference ∷ DateTime → DateTime → Integer+datesDifference d1 d2 =+ abs $ toModifiedJulianDay (dateTimeToDay d1) -+ toModifiedJulianDay (dateTimeToDay d2)+ maybePlural ∷ String → Parsec String st String maybePlural str = do r ← string str optional $ char 's' return (capitalize r) -pDateInterval ∷ Parsec String st DateIntervalType-pDateInterval = do+pDateIntervalType ∷ Parsec String st DateIntervalType+pDateIntervalType = do s ← choice $ map maybePlural ["day", "week", "month", "year"] tryRead s +pDateInterval ∷ Parsec String st DateInterval+pDateInterval = do+ n ← many1 digit+ spaces+ tp ← pDateIntervalType+ case tp of+ Day → Days `fmap` tryRead n+ Week → Weeks `fmap` tryRead n+ Month → Months `fmap` tryRead n+ Year → Years `fmap` tryRead n+ pRelDate ∷ DateTime → Parsec String st DateTime pRelDate date = do- offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday+ offs ← try futureDate+ <|> try passDate+ <|> try today+ <|> try tomorrow+ <|> yesterday return $ date `addInterval` offs +lastDate ∷ DateTime → Parsec String st 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 ∷ DateTime → Parsec String st 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 ∷ Parsec String st WeekDay+pWeekDay = do+ w ← many1 (oneOf "mondaytueswnhrfi")+ tryRead (capitalize w)+ futureDate ∷ Parsec String st DateInterval futureDate = do string "in " n ← many1 digit char ' '- tp ← pDateInterval+ tp ← pDateIntervalType case tp of Day → Days `fmap` tryRead n Week → Weeks `fmap` tryRead n@@ -239,7 +372,7 @@ passDate = do n ← many1 digit char ' '- tp ← pDateInterval+ tp ← pDateIntervalType string " ago" case tp of Day → (Days . negate) `fmap` tryRead n@@ -249,7 +382,7 @@ today ∷ Parsec String st DateInterval today = do- string "today"+ string "today" <|> string "now" return $ Days 0 tomorrow ∷ Parsec String st DateInterval@@ -262,15 +395,25 @@ string "yesterday" return $ Days (-1) +pByWeek ∷ DateTime → Parsec String st DateTime+pByWeek date =+ try (lastDate date) <|> nextDate date+ -- | Parsec parser for DateTime. pDateTime ∷ DateTime -- ^ Current date / time, to use as base for relative dates → Parsec String st DateTime-pDateTime date = (try $ pRelDate date) <|> (try $ pAbsDateTime $ year date)+pDateTime date =+ (try $ pRelDate date)+ <|> (try $ pByWeek date)+ <|> (try $ pAbsDateTime $ year date) -- | Parsec parser for Date only. pDate ∷ DateTime -- ^ Current date / time, to use as base for relative dates → Parsec String st DateTime-pDate date = (try $ pRelDate date) <|> (try $ pAbsDate $ year date)+pDate date =+ (try $ pRelDate date)+ <|> (try $ pByWeek date)+ <|> (try $ pAbsDate $ year date) -- | Parse date/time parseDate ∷ DateTime -- ^ Current date / time, to use as base for relative dates
dates.cabal view
@@ -1,5 +1,5 @@ name: dates-version: 0.2.0.2+version: 0.2.1.0 synopsis: Small library for parsing different dates formats. description: This package allows to parse many different formats of dates. Both absolute and relative dates are supported.@@ -14,6 +14,10 @@ * `today', `tomorrow', `yesterday' . * `in 2 days', '3 weeks ago'+ .+ * `last monday', 'next friday'+ .+ * `last month' (1th of this month), `next year' (1th of January of next year) . 4-digits years may be abbreviated (such as 12 for 2012). Both 12-hour and 24-hour time formats are supported.@@ -37,9 +41,9 @@ Data.Dates.Formats, Data.Dates.Internal -- other-modules: - build-depends: base ==4.5.*,+ build-depends: base >=4 && < 5, base-unicode-symbols ==0.2.*,- time ==1.4.*,+ time >= 1.4, parsec ==3.1.*, syb ==0.3.*