1 {-| 2 3 Date parsing and utilities for hledger. 4 5 For date and time values, we use the standard Day and UTCTime types. 6 7 A 'SmartDate' is a date which may be partially-specified or relative. 8 Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. 9 We represent these as a triple of strings like (\"2008\",\"12\",\"\"), 10 (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). 11 12 A 'DateSpan' is the span of time between two specific calendar dates, or 13 an open-ended span where one or both dates are unspecified. (A date span 14 with both ends unspecified matches all dates.) 15 16 An 'Interval' is ledger's \"reporting interval\" - weekly, monthly, 17 quarterly, etc. 18 19 -} 20 21 -- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ? 22 23 module Hledger.Data.Dates 24 where 25 26 import Control.Monad 27 import Data.List 28 import Data.Maybe 29 import Data.Time.Format 30 import Data.Time.Calendar 31 import Data.Time.Calendar.OrdinalDate 32 import Data.Time.Clock 33 import Data.Time.LocalTime 34 import Safe (readMay) 35 import System.Locale (defaultTimeLocale) 36 import Test.HUnit 37 import Text.ParserCombinators.Parsec 38 import Text.Printf 39 40 import Hledger.Data.Types 41 import Hledger.Utils 42 43 44 showDate :: Day -> String 45 showDate = formatTime defaultTimeLocale "%C%y/%m/%d" 46 47 -- | Get the current local date. 48 getCurrentDay :: IO Day 49 getCurrentDay = do 50 t <- getZonedTime 51 return $ localDay (zonedTimeToLocalTime t) 52 53 -- | Get the current local month number. 54 getCurrentMonth :: IO Int 55 getCurrentMonth = do 56 (_,m,_) <- toGregorian `fmap` getCurrentDay 57 return m 58 59 -- | Get the current local year. 60 getCurrentYear :: IO Integer 61 getCurrentYear = do 62 (y,_,_) <- toGregorian `fmap` getCurrentDay 63 return y 64 65 elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a 66 elapsedSeconds t1 = realToFrac . diffUTCTime t1 67 68 -- | Split a DateSpan into one or more consecutive spans at the specified interval. 69 splitSpan :: Interval -> DateSpan -> [DateSpan] 70 splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] 71 splitSpan NoInterval s = [s] 72 splitSpan (Days n) s = splitspan startofday (applyN n nextday) s 73 splitSpan (Weeks n) s = splitspan startofweek (applyN n nextweek) s 74 splitSpan (Months n) s = splitspan startofmonth (applyN n nextmonth) s 75 splitSpan (Quarters n) s = splitspan startofquarter (applyN n nextquarter) s 76 splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s 77 splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (applyN (n-1) nextday . nextmonth) s 78 splitSpan (DayOfWeek n) s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s 79 -- splitSpan (WeekOfYear n) s = splitspan startofweek (applyN n nextweek) s 80 -- splitSpan (MonthOfYear n) s = splitspan startofmonth (applyN n nextmonth) s 81 -- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s 82 83 -- Split the given span using the provided helper functions: 84 -- start is applied to the span's start date to get the first sub-span's start date 85 -- next is applied to a sub-span's start date to get the next sub-span's start date 86 splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] 87 splitspan _ _ (DateSpan Nothing Nothing) = [] 88 splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e)) 89 splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s)) 90 splitspan start next span@(DateSpan (Just s) (Just e)) 91 | s == e = [span] 92 | otherwise = splitspan' start next span 93 where 94 splitspan' start next (DateSpan (Just s) (Just e)) 95 | s >= e = [] 96 | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e)) 97 where subs = start s 98 sube = next subs 99 splitspan' _ _ _ = error' "won't happen, avoids warnings" 100 101 -- | Count the days in a DateSpan, or if it is open-ended return Nothing. 102 daysInSpan :: DateSpan -> Maybe Integer 103 daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 104 daysInSpan _ = Nothing 105 106 -- | Does the span include the given date ? 107 spanContainsDate :: DateSpan -> Day -> Bool 108 spanContainsDate (DateSpan Nothing Nothing) _ = True 109 spanContainsDate (DateSpan Nothing (Just e)) d = d < e 110 spanContainsDate (DateSpan (Just b) Nothing) d = d >= b 111 spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e 112 113 -- | Combine two datespans, filling any unspecified dates in the first 114 -- with dates from the second. 115 orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b 116 where a = if isJust a1 then a1 else a2 117 b = if isJust b1 then b1 else b2 118 119 -- | Parse a period expression to an Interval and overall DateSpan using 120 -- the provided reference date, or return a parse error. 121 parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) 122 parsePeriodExpr refdate = parsewith (periodexpr refdate) 123 124 maybePeriod :: Day -> String -> Maybe (Interval,DateSpan) 125 maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate 126 127 -- | Show a DateSpan as a human-readable pseudo-period-expression string. 128 dateSpanAsText :: DateSpan -> String 129 dateSpanAsText (DateSpan Nothing Nothing) = "all" 130 dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e) 131 dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b) 132 dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e) 133 134 -- | Convert a single smart date string to a date span using the provided 135 -- reference date, or raise an error. 136 spanFromSmartDateString :: Day -> String -> DateSpan 137 spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate 138 where 139 sdate = fromparse $ parsewith smartdateonly s 140 141 spanFromSmartDate :: Day -> SmartDate -> DateSpan 142 spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) 143 where 144 (ry,rm,_) = toGregorian refdate 145 (b,e) = span sdate 146 span :: SmartDate -> (Day,Day) 147 span ("","","today") = (refdate, nextday refdate) 148 span ("","this","day") = (refdate, nextday refdate) 149 span ("","","yesterday") = (prevday refdate, refdate) 150 span ("","last","day") = (prevday refdate, refdate) 151 span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) 152 span ("","next","day") = (nextday refdate, addDays 2 refdate) 153 span ("","last","week") = (prevweek refdate, thisweek refdate) 154 span ("","this","week") = (thisweek refdate, nextweek refdate) 155 span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) 156 span ("","last","month") = (prevmonth refdate, thismonth refdate) 157 span ("","this","month") = (thismonth refdate, nextmonth refdate) 158 span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) 159 span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) 160 span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) 161 span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) 162 span ("","last","year") = (prevyear refdate, thisyear refdate) 163 span ("","this","year") = (thisyear refdate, nextyear refdate) 164 span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) 165 span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) 166 span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 167 span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) 168 span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 169 span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 170 span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) 171 172 showDay :: Day -> String 173 showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day 174 175 -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using 176 -- the provided reference date, or raise an error. 177 fixSmartDateStr :: Day -> String -> String 178 fixSmartDateStr d s = either 179 (\e->error' $ printf "could not parse date %s %s" (show s) (show e)) 180 id 181 $ fixSmartDateStrEither d s 182 183 -- | A safe version of fixSmartDateStr. 184 fixSmartDateStrEither :: Day -> String -> Either ParseError String 185 fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d 186 187 fixSmartDateStrEither' :: Day -> String -> Either ParseError Day 188 fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of 189 Right sd -> Right $ fixSmartDate d sd 190 Left e -> Left e 191 192 -- | Convert a SmartDate to an absolute date using the provided reference date. 193 fixSmartDate :: Day -> SmartDate -> Day 194 fixSmartDate refdate sdate = fix sdate 195 where 196 fix :: SmartDate -> Day 197 fix ("","","today") = fromGregorian ry rm rd 198 fix ("","this","day") = fromGregorian ry rm rd 199 fix ("","","yesterday") = prevday refdate 200 fix ("","last","day") = prevday refdate 201 fix ("","","tomorrow") = nextday refdate 202 fix ("","next","day") = nextday refdate 203 fix ("","last","week") = prevweek refdate 204 fix ("","this","week") = thisweek refdate 205 fix ("","next","week") = nextweek refdate 206 fix ("","last","month") = prevmonth refdate 207 fix ("","this","month") = thismonth refdate 208 fix ("","next","month") = nextmonth refdate 209 fix ("","last","quarter") = prevquarter refdate 210 fix ("","this","quarter") = thisquarter refdate 211 fix ("","next","quarter") = nextquarter refdate 212 fix ("","last","year") = prevyear refdate 213 fix ("","this","year") = thisyear refdate 214 fix ("","next","year") = nextyear refdate 215 fix ("","",d) = fromGregorian ry rm (read d) 216 fix ("",m,"") = fromGregorian ry (read m) 1 217 fix ("",m,d) = fromGregorian ry (read m) (read d) 218 fix (y,"","") = fromGregorian (read y) 1 1 219 fix (y,m,"") = fromGregorian (read y) (read m) 1 220 fix (y,m,d) = fromGregorian (read y) (read m) (read d) 221 (ry,rm,rd) = toGregorian refdate 222 223 prevday :: Day -> Day 224 prevday = addDays (-1) 225 nextday = addDays 1 226 startofday = id 227 228 thisweek = startofweek 229 prevweek = startofweek . addDays (-7) 230 nextweek = startofweek . addDays 7 231 startofweek day = fromMondayStartWeek y w 1 232 where 233 (y,_,_) = toGregorian day 234 (w,_) = mondayStartWeek day 235 236 thismonth = startofmonth 237 prevmonth = startofmonth . addGregorianMonthsClip (-1) 238 nextmonth = startofmonth . addGregorianMonthsClip 1 239 startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day 240 241 thisquarter = startofquarter 242 prevquarter = startofquarter . addGregorianMonthsClip (-3) 243 nextquarter = startofquarter . addGregorianMonthsClip 3 244 startofquarter day = fromGregorian y (firstmonthofquarter m) 1 245 where 246 (y,m,_) = toGregorian day 247 firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 248 249 thisyear = startofyear 250 prevyear = startofyear . addGregorianYearsClip (-1) 251 nextyear = startofyear . addGregorianYearsClip 1 252 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day 253 254 nthdayofmonthcontaining n d | d1 >= d = d1 255 | otherwise = d2 256 where d1 = addDays (fromIntegral n-1) s 257 d2 = addDays (fromIntegral n-1) $ nextmonth s 258 s = startofmonth d 259 260 nthdayofweekcontaining n d | d1 >= d = d1 261 | otherwise = d2 262 where d1 = addDays (fromIntegral n-1) s 263 d2 = addDays (fromIntegral n-1) $ nextweek s 264 s = startofweek d 265 266 ---------------------------------------------------------------------- 267 -- parsing 268 269 firstJust ms = case dropWhile (==Nothing) ms of 270 [] -> Nothing 271 (md:_) -> md 272 273 -- | Parse a couple of date-time string formats to a time type. 274 parsedatetimeM :: String -> Maybe LocalTime 275 parsedatetimeM s = firstJust [ 276 parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, 277 parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s 278 ] 279 280 -- | Parse a couple of date string formats to a time type. 281 parsedateM :: String -> Maybe Day 282 parsedateM s = firstJust [ 283 parseTime defaultTimeLocale "%Y/%m/%d" s, 284 parseTime defaultTimeLocale "%Y-%m-%d" s 285 ] 286 287 -- | Parse a date-time string to a time type, or raise an error. 288 parsedatetime :: String -> LocalTime 289 parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"") 290 (parsedatetimeM s) 291 292 -- | Parse a date string to a time type, or raise an error. 293 parsedate :: String -> Day 294 parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"") 295 (parsedateM s) 296 297 -- | Parse a time string to a time type using the provided pattern, or 298 -- return the default. 299 parsetimewith :: ParseTime t => String -> String -> t -> t 300 parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s 301 302 {-| 303 Parse a date in any of the formats allowed in ledger's period expressions, 304 and maybe some others: 305 306 > 2004 307 > 2004/10 308 > 2004/10/1 309 > 10/1 310 > 21 311 > october, oct 312 > yesterday, today, tomorrow 313 > this/next/last week/day/month/quarter/year 314 315 Returns a SmartDate, to be converted to a full date later (see fixSmartDate). 316 Assumes any text in the parse stream has been lowercased. 317 -} 318 smartdate :: GenParser Char st SmartDate 319 smartdate = do 320 -- XXX maybe obscures date errors ? see ledgerdate 321 (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] 322 return (y,m,d) 323 324 -- | Like smartdate, but there must be nothing other than whitespace after the date. 325 smartdateonly :: GenParser Char st SmartDate 326 smartdateonly = do 327 d <- smartdate 328 many spacenonewline 329 eof 330 return d 331 332 datesepchars = "/-." 333 datesepchar = oneOf datesepchars 334 335 validYear, validMonth, validDay :: String -> Bool 336 validYear s = length s >= 4 && isJust (readMay s :: Maybe Int) 337 validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s 338 validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s 339 340 failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m () 341 failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s 342 failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s 343 failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s 344 345 yyyymmdd :: GenParser Char st SmartDate 346 yyyymmdd = do 347 y <- count 4 digit 348 m <- count 2 digit 349 failIfInvalidMonth m 350 d <- count 2 digit 351 failIfInvalidDay d 352 return (y,m,d) 353 354 ymd :: GenParser Char st SmartDate 355 ymd = do 356 y <- many1 digit 357 failIfInvalidYear y 358 datesepchar 359 m <- many1 digit 360 failIfInvalidMonth m 361 datesepchar 362 d <- many1 digit 363 failIfInvalidDay d 364 return $ (y,m,d) 365 366 ym :: GenParser Char st SmartDate 367 ym = do 368 y <- many1 digit 369 failIfInvalidYear y 370 datesepchar 371 m <- many1 digit 372 failIfInvalidMonth m 373 return (y,m,"") 374 375 y :: GenParser Char st SmartDate 376 y = do 377 y <- many1 digit 378 failIfInvalidYear y 379 return (y,"","") 380 381 d :: GenParser Char st SmartDate 382 d = do 383 d <- many1 digit 384 failIfInvalidDay d 385 return ("","",d) 386 387 md :: GenParser Char st SmartDate 388 md = do 389 m <- many1 digit 390 failIfInvalidMonth m 391 datesepchar 392 d <- many1 digit 393 failIfInvalidDay d 394 return ("",m,d) 395 396 months = ["january","february","march","april","may","june", 397 "july","august","september","october","november","december"] 398 monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] 399 weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] 400 weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] 401 402 monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months 403 monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs 404 405 month :: GenParser Char st SmartDate 406 month = do 407 m <- choice $ map (try . string) months 408 let i = monthIndex m 409 return ("",show i,"") 410 411 mon :: GenParser Char st SmartDate 412 mon = do 413 m <- choice $ map (try . string) monthabbrevs 414 let i = monIndex m 415 return ("",show i,"") 416 417 today,yesterday,tomorrow :: GenParser Char st SmartDate 418 today = string "today" >> return ("","","today") 419 yesterday = string "yesterday" >> return ("","","yesterday") 420 tomorrow = string "tomorrow" >> return ("","","tomorrow") 421 422 lastthisnextthing :: GenParser Char st SmartDate 423 lastthisnextthing = do 424 r <- choice [ 425 string "last" 426 ,string "this" 427 ,string "next" 428 ] 429 many spacenonewline -- make the space optional for easier scripting 430 p <- choice [ 431 string "day" 432 ,string "week" 433 ,string "month" 434 ,string "quarter" 435 ,string "year" 436 ] 437 -- XXX support these in fixSmartDate 438 -- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) 439 440 return ("",r,p) 441 442 periodexpr :: Day -> GenParser Char st (Interval, DateSpan) 443 periodexpr rdate = choice $ map try [ 444 intervalanddateperiodexpr rdate, 445 intervalperiodexpr, 446 dateperiodexpr rdate, 447 (return (NoInterval,DateSpan Nothing Nothing)) 448 ] 449 450 intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) 451 intervalanddateperiodexpr rdate = do 452 many spacenonewline 453 i <- reportinginterval 454 many spacenonewline 455 s <- periodexprdatespan rdate 456 return (i,s) 457 458 intervalperiodexpr :: GenParser Char st (Interval, DateSpan) 459 intervalperiodexpr = do 460 many spacenonewline 461 i <- reportinginterval 462 return (i, DateSpan Nothing Nothing) 463 464 dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) 465 dateperiodexpr rdate = do 466 many spacenonewline 467 s <- periodexprdatespan rdate 468 return (NoInterval, s) 469 470 -- Parse a reporting interval. 471 reportinginterval :: GenParser Char st Interval 472 reportinginterval = choice' [ 473 tryinterval "day" "daily" Days, 474 tryinterval "week" "weekly" Weeks, 475 tryinterval "month" "monthly" Months, 476 tryinterval "quarter" "quarterly" Quarters, 477 tryinterval "year" "yearly" Years, 478 do string "biweekly" 479 return $ Weeks 2, 480 do string "bimonthly" 481 return $ Months 2, 482 do string "every" 483 many spacenonewline 484 n <- fmap read $ many1 digit 485 thsuffix 486 many spacenonewline 487 string "day" 488 many spacenonewline 489 string "of" 490 many spacenonewline 491 string "week" 492 return $ DayOfWeek n, 493 do string "every" 494 many spacenonewline 495 n <- fmap read $ many1 digit 496 thsuffix 497 many spacenonewline 498 string "day" 499 optional $ do 500 many spacenonewline 501 string "of" 502 many spacenonewline 503 string "month" 504 return $ DayOfMonth n 505 ] 506 where 507 508 thsuffix = choice' $ map string ["st","nd","rd","th"] 509 510 -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". 511 tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval 512 tryinterval singular compact intcons = 513 choice' [ 514 do string compact 515 return $ intcons 1, 516 do string "every" 517 many spacenonewline 518 string singular 519 return $ intcons 1, 520 do string "every" 521 many spacenonewline 522 n <- fmap read $ many1 digit 523 many spacenonewline 524 string plural 525 return $ intcons n 526 ] 527 where plural = singular ++ "s" 528 529 periodexprdatespan :: Day -> GenParser Char st DateSpan 530 periodexprdatespan rdate = choice $ map try [ 531 doubledatespan rdate, 532 fromdatespan rdate, 533 todatespan rdate, 534 justdatespan rdate 535 ] 536 537 doubledatespan :: Day -> GenParser Char st DateSpan 538 doubledatespan rdate = do 539 optional (string "from" >> many spacenonewline) 540 b <- smartdate 541 many spacenonewline 542 optional (string "to" >> many spacenonewline) 543 e <- smartdate 544 return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) 545 546 fromdatespan :: Day -> GenParser Char st DateSpan 547 fromdatespan rdate = do 548 string "from" >> many spacenonewline 549 b <- smartdate 550 return $ DateSpan (Just $ fixSmartDate rdate b) Nothing 551 552 todatespan :: Day -> GenParser Char st DateSpan 553 todatespan rdate = do 554 string "to" >> many spacenonewline 555 e <- smartdate 556 return $ DateSpan Nothing (Just $ fixSmartDate rdate e) 557 558 justdatespan :: Day -> GenParser Char st DateSpan 559 justdatespan rdate = do 560 optional (string "in" >> many spacenonewline) 561 d <- smartdate 562 return $ spanFromSmartDate rdate d 563 564 -- | Make a datespan from two valid date strings parseable by parsedate 565 -- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\". 566 mkdatespan :: String -> String -> DateSpan 567 mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate 568 569 nulldatespan :: DateSpan 570 nulldatespan = DateSpan Nothing Nothing 571 572 nulldate :: Day 573 nulldate = parsedate "0000/00/00" 574 575 tests_Hledger_Data_Dates = TestList 576 [ 577 578 "parsedate" ~: do 579 let date1 = parsedate "2008/11/26" 580 parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 581 parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 582 583 ,"period expressions" ~: do 584 let todaysdate = parsedate "2008/11/26" 585 let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result) 586 "from aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" 587 "aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" 588 "every 3 days in aug" `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-09-01))" 589 "daily from aug" `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)" 590 "every week to 2009" `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))" 591 592 ,"splitSpan" ~: do 593 let gives (interval, span) = (splitSpan interval span `is`) 594 (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` 595 [mkdatespan "2008/01/01" "2009/01/01"] 596 (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives` 597 [mkdatespan "2008/01/01" "2008/04/01" 598 ,mkdatespan "2008/04/01" "2008/07/01" 599 ,mkdatespan "2008/07/01" "2008/10/01" 600 ,mkdatespan "2008/10/01" "2009/01/01" 601 ] 602 (Quarters 1,nulldatespan) `gives` 603 [nulldatespan] 604 (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives` 605 [mkdatespan "2008/01/01" "2008/01/01"] 606 (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives` 607 [mkdatespan "2008/01/01" "2008/01/01"] 608 (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives` 609 [mkdatespan "2008/01/01" "2008/02/01" 610 ,mkdatespan "2008/02/01" "2008/03/01" 611 ,mkdatespan "2008/03/01" "2008/04/01" 612 ] 613 (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives` 614 [mkdatespan "2008/01/01" "2008/03/01" 615 ,mkdatespan "2008/03/01" "2008/05/01" 616 ] 617 (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives` 618 [mkdatespan "2007/12/31" "2008/01/07" 619 ,mkdatespan "2008/01/07" "2008/01/14" 620 ,mkdatespan "2008/01/14" "2008/01/21" 621 ] 622 (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives` 623 [mkdatespan "2007/12/31" "2008/01/14" 624 ,mkdatespan "2008/01/14" "2008/01/28" 625 ] 626 (DayOfMonth 2,mkdatespan "2008/01/01" "2008/04/01") `gives` 627 [mkdatespan "2008/01/02" "2008/02/02" 628 ,mkdatespan "2008/02/02" "2008/03/02" 629 ,mkdatespan "2008/03/02" "2008/04/02" 630 ] 631 (DayOfWeek 2,mkdatespan "2011/01/01" "2011/01/15") `gives` 632 [mkdatespan "2011/01/04" "2011/01/11" 633 ,mkdatespan "2011/01/11" "2011/01/18" 634 ] 635 636 ,"fixSmartDateStr" ~: do 637 let gives = is . fixSmartDateStr (parsedate "2008/11/26") 638 "1999-12-02" `gives` "1999/12/02" 639 "1999.12.02" `gives` "1999/12/02" 640 "1999/3/2" `gives` "1999/03/02" 641 "19990302" `gives` "1999/03/02" 642 "2008/2" `gives` "2008/02/01" 643 "0020/2" `gives` "0020/02/01" 644 "1000" `gives` "1000/01/01" 645 "4/2" `gives` "2008/04/02" 646 "2" `gives` "2008/11/02" 647 "January" `gives` "2008/01/01" 648 "feb" `gives` "2008/02/01" 649 "today" `gives` "2008/11/26" 650 "yesterday" `gives` "2008/11/25" 651 "tomorrow" `gives` "2008/11/27" 652 "this day" `gives` "2008/11/26" 653 "last day" `gives` "2008/11/25" 654 "next day" `gives` "2008/11/27" 655 "this week" `gives` "2008/11/24" -- last monday 656 "last week" `gives` "2008/11/17" -- previous monday 657 "next week" `gives` "2008/12/01" -- next monday 658 "this month" `gives` "2008/11/01" 659 "last month" `gives` "2008/10/01" 660 "next month" `gives` "2008/12/01" 661 "this quarter" `gives` "2008/10/01" 662 "last quarter" `gives` "2008/07/01" 663 "next quarter" `gives` "2009/01/01" 664 "this year" `gives` "2008/01/01" 665 "last year" `gives` "2007/01/01" 666 "next year" `gives` "2009/01/01" 667 -- "last wed" `gives` "2008/11/19" 668 -- "next friday" `gives` "2008/11/28" 669 -- "next january" `gives` "2009/01/01" 670 671 ]