1 {-| 2 3 For date and time values, we use the standard Day and UTCTime types. 4 5 A 'SmartDate' is a date which may be partially-specified or relative. 6 Eg 2008/12/31, but also 2008/12, 12/31, tomorrow, last week, next year. 7 We represent these as a triple of strings like (\"2008\",\"12\",\"\"), 8 (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). 9 10 A 'DateSpan' is the span of time between two specific calendar dates, or 11 an open-ended span where one or both dates are unspecified. (A date span 12 with both ends unspecified matches all dates.) 13 14 An 'Interval' is ledger's "reporting interval" - weekly, monthly, 15 quarterly, etc. 16 17 -} 18 19 module Ledger.Dates 20 where 21 22 import Data.Time.Clock 23 import Data.Time.Format 24 import Data.Time.Calendar 25 import Data.Time.Calendar.MonthDay 26 import Data.Time.Calendar.OrdinalDate 27 import Data.Time.Calendar.WeekDate 28 import Data.Time.LocalTime 29 import Locale (defaultTimeLocale) 30 import Text.Printf 31 import Data.Maybe 32 import Text.ParserCombinators.Parsec 33 import Text.ParserCombinators.Parsec.Char 34 import Text.ParserCombinators.Parsec.Combinator 35 import Ledger.Types 36 import Ledger.Utils 37 38 39 showDate :: Day -> String 40 showDate d = formatTime defaultTimeLocale "%Y/%m/%d" d 41 42 getCurrentDay :: IO Day 43 getCurrentDay = do 44 t <- getZonedTime 45 return $ localDay (zonedTimeToLocalTime t) 46 47 elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a 48 elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 49 50 -- | Split a DateSpan into one or more consecutive spans at the specified interval. 51 splitSpan :: Interval -> DateSpan -> [DateSpan] 52 splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] 53 splitSpan NoInterval s = [s] 54 splitSpan Daily s = splitspan start next s where (start,next) = (startofday,nextday) 55 splitSpan Weekly s = splitspan start next s where (start,next) = (startofweek,nextweek) 56 splitSpan Monthly s = splitspan start next s where (start,next) = (startofmonth,nextmonth) 57 splitSpan Quarterly s = splitspan start next s where (start,next) = (startofquarter,nextquarter) 58 splitSpan Yearly s = splitspan start next s where (start,next) = (startofyear,nextyear) 59 60 splitspan _ _ (DateSpan Nothing Nothing) = [] 61 splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)] 62 splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)] 63 splitspan startof next s@(DateSpan (Just b) (Just e)) 64 | b == e = [s] 65 | otherwise = splitspan' startof next s 66 where splitspan' startof next (DateSpan (Just b) (Just e)) 67 | b >= e = [] 68 | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] 69 ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e)) 70 71 -- | Count the days in a DateSpan, or if it is open-ended return Nothing. 72 daysInSpan :: DateSpan -> Maybe Integer 73 daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 74 daysInSpan _ = Nothing 75 76 -- | Parse a period expression to an Interval and overall DateSpan using 77 -- the provided reference date. 78 parsePeriodExpr :: Day -> String -> (Interval, DateSpan) 79 parsePeriodExpr refdate expr = (interval,span) 80 where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr 81 82 -- | Convert a single smart date string to a date span using the provided 83 -- reference date. 84 spanFromSmartDateString :: Day -> String -> DateSpan 85 spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate 86 where 87 sdate = fromparse $ parsewith smartdate s 88 89 spanFromSmartDate :: Day -> SmartDate -> DateSpan 90 spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) 91 where 92 (ry,rm,rd) = toGregorian refdate 93 (b,e) = span sdate 94 span :: SmartDate -> (Day,Day) 95 span ("","","today") = (refdate, nextday refdate) 96 span ("","this","day") = (refdate, nextday refdate) 97 span ("","","yesterday") = (prevday refdate, refdate) 98 span ("","last","day") = (prevday refdate, refdate) 99 span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) 100 span ("","next","day") = (nextday refdate, addDays 2 refdate) 101 span ("","last","week") = (prevweek refdate, thisweek refdate) 102 span ("","this","week") = (thisweek refdate, nextweek refdate) 103 span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) 104 span ("","last","month") = (prevmonth refdate, thismonth refdate) 105 span ("","this","month") = (thismonth refdate, nextmonth refdate) 106 span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) 107 span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) 108 span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) 109 span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) 110 span ("","last","year") = (prevyear refdate, thisyear refdate) 111 span ("","this","year") = (thisyear refdate, nextyear refdate) 112 span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) 113 span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) 114 span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 115 span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) 116 span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 117 span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 118 span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) 119 120 -- | Convert a smart date string to an explicit yyyy/mm/dd string using 121 -- the provided reference date. 122 fixSmartDateStr :: Day -> String -> String 123 fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d 124 where 125 (y,m,d) = toGregorian $ fixSmartDate t sdate 126 sdate = fromparse $ parsewith smartdate $ lowercase s 127 128 -- | Convert a SmartDate to an absolute date using the provided reference date. 129 fixSmartDate :: Day -> SmartDate -> Day 130 fixSmartDate refdate sdate = fix sdate 131 where 132 fix :: SmartDate -> Day 133 fix ("","","today") = fromGregorian ry rm rd 134 fix ("","this","day") = fromGregorian ry rm rd 135 fix ("","","yesterday") = prevday refdate 136 fix ("","last","day") = prevday refdate 137 fix ("","","tomorrow") = nextday refdate 138 fix ("","next","day") = nextday refdate 139 fix ("","last","week") = prevweek refdate 140 fix ("","this","week") = thisweek refdate 141 fix ("","next","week") = nextweek refdate 142 fix ("","last","month") = prevmonth refdate 143 fix ("","this","month") = thismonth refdate 144 fix ("","next","month") = nextmonth refdate 145 fix ("","last","quarter") = prevquarter refdate 146 fix ("","this","quarter") = thisquarter refdate 147 fix ("","next","quarter") = nextquarter refdate 148 fix ("","last","year") = prevyear refdate 149 fix ("","this","year") = thisyear refdate 150 fix ("","next","year") = nextyear refdate 151 fix ("","",d) = fromGregorian ry rm (read d) 152 fix ("",m,"") = fromGregorian ry (read m) 1 153 fix ("",m,d) = fromGregorian ry (read m) (read d) 154 fix (y,"","") = fromGregorian (read y) 1 1 155 fix (y,m,"") = fromGregorian (read y) (read m) 1 156 fix (y,m,d) = fromGregorian (read y) (read m) (read d) 157 (ry,rm,rd) = toGregorian refdate 158 159 prevday :: Day -> Day 160 prevday = addDays (-1) 161 nextday = addDays 1 162 startofday = id 163 164 thisweek = startofweek 165 prevweek = startofweek . addDays (-7) 166 nextweek = startofweek . addDays 7 167 startofweek day = fromMondayStartWeek y w 1 168 where 169 (y,_,_) = toGregorian day 170 (w,_) = mondayStartWeek day 171 172 thismonth = startofmonth 173 prevmonth = startofmonth . addGregorianMonthsClip (-1) 174 nextmonth = startofmonth . addGregorianMonthsClip 1 175 startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day 176 177 thisquarter = startofquarter 178 prevquarter = startofquarter . addGregorianMonthsClip (-3) 179 nextquarter = startofquarter . addGregorianMonthsClip 3 180 startofquarter day = fromGregorian y (firstmonthofquarter m) 1 181 where 182 (y,m,_) = toGregorian day 183 firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 184 185 thisyear = startofyear 186 prevyear = startofyear . addGregorianYearsClip (-1) 187 nextyear = startofyear . addGregorianYearsClip 1 188 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day 189 190 ---------------------------------------------------------------------- 191 -- parsing 192 193 firstJust ms = case dropWhile (==Nothing) ms of 194 [] -> Nothing 195 (md:_) -> md 196 197 parsedatetimeM :: String -> Maybe LocalTime 198 parsedatetimeM s = firstJust [ 199 parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, 200 parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s 201 ] 202 203 -- | Parse a date-time string to a time type, or raise an error. 204 parsedatetime :: String -> LocalTime 205 parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"") 206 (parsedatetimeM s) 207 208 -- | Parse a date string to a time type, or raise an error. 209 parsedateM :: String -> Maybe Day 210 parsedateM s = firstJust [ 211 parseTime defaultTimeLocale "%Y/%m/%d" s, 212 parseTime defaultTimeLocale "%Y-%m-%d" s 213 ] 214 215 -- | Parse a date string to a time type, or raise an error. 216 parsedate :: String -> Day 217 parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"") 218 (parsedateM s) 219 220 -- | Parse a time string to a time type using the provided pattern, or 221 -- return the default. 222 parsetimewith :: ParseTime t => String -> String -> t -> t 223 parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s 224 225 {-| 226 Parse a date in any of the formats allowed in ledger's period expressions, 227 and maybe some others: 228 229 > 2004 230 > 2004/10 231 > 2004/10/1 232 > 10/1 233 > 21 234 > october, oct 235 > yesterday, today, tomorrow 236 > (not yet) this/next/last week/day/month/quarter/year 237 238 Returns a SmartDate, to be converted to a full date later (see fixSmartDate). 239 Assumes any text in the parse stream has been lowercased. 240 -} 241 smartdate :: GenParser Char st SmartDate 242 smartdate = do 243 let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, 244 lastthisnextthing 245 ] 246 (y,m,d) <- choice $ map try dateparsers 247 return $ (y,m,d) 248 249 datesepchar = oneOf "/-." 250 251 yyyymmdd :: GenParser Char st SmartDate 252 yyyymmdd = do 253 y <- count 4 digit 254 m <- count 2 digit 255 guard (read m <= 12) 256 d <- count 2 digit 257 guard (read d <= 31) 258 return (y,m,d) 259 260 ymd :: GenParser Char st SmartDate 261 ymd = do 262 y <- many1 digit 263 datesepchar 264 m <- many1 digit 265 guard (read m <= 12) 266 datesepchar 267 d <- many1 digit 268 guard (read d <= 31) 269 return (y,m,d) 270 271 ym :: GenParser Char st SmartDate 272 ym = do 273 y <- many1 digit 274 guard (read y > 12) 275 datesepchar 276 m <- many1 digit 277 guard (read m <= 12) 278 return (y,m,"") 279 280 y :: GenParser Char st SmartDate 281 y = do 282 y <- many1 digit 283 guard (read y >= 1000) 284 return (y,"","") 285 286 d :: GenParser Char st SmartDate 287 d = do 288 d <- many1 digit 289 guard (read d <= 31) 290 return ("","",d) 291 292 md :: GenParser Char st SmartDate 293 md = do 294 m <- many1 digit 295 guard (read m <= 12) 296 datesepchar 297 d <- many1 digit 298 guard (read d <= 31) 299 return ("",m,d) 300 301 months = ["january","february","march","april","may","june", 302 "july","august","september","october","november","december"] 303 monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] 304 weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] 305 weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] 306 307 monthIndex s = maybe 0 (+1) $ (lowercase s) `elemIndex` months 308 monIndex s = maybe 0 (+1) $ (lowercase s) `elemIndex` monthabbrevs 309 310 month :: GenParser Char st SmartDate 311 month = do 312 m <- choice $ map (try . string) months 313 let i = monthIndex m 314 return $ ("",show i,"") 315 316 mon :: GenParser Char st SmartDate 317 mon = do 318 m <- choice $ map (try . string) monthabbrevs 319 let i = monIndex m 320 return ("",show i,"") 321 322 today,yesterday,tomorrow :: GenParser Char st SmartDate 323 today = string "today" >> return ("","","today") 324 yesterday = string "yesterday" >> return ("","","yesterday") 325 tomorrow = string "tomorrow" >> return ("","","tomorrow") 326 327 lastthisnextthing :: GenParser Char st SmartDate 328 lastthisnextthing = do 329 r <- choice [ 330 string "last" 331 ,string "this" 332 ,string "next" 333 ] 334 many spacenonewline -- make the space optional for easier scripting 335 p <- choice $ [ 336 string "day" 337 ,string "week" 338 ,string "month" 339 ,string "quarter" 340 ,string "year" 341 ] 342 -- XXX support these in fixSmartDate 343 -- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) 344 345 return ("",r,p) 346 347 periodexpr :: Day -> GenParser Char st (Interval, DateSpan) 348 periodexpr rdate = choice $ map try [ 349 intervalanddateperiodexpr rdate, 350 intervalperiodexpr, 351 dateperiodexpr rdate, 352 (return $ (NoInterval,DateSpan Nothing Nothing)) 353 ] 354 355 intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) 356 intervalanddateperiodexpr rdate = do 357 many spacenonewline 358 i <- periodexprinterval 359 many spacenonewline 360 s <- periodexprdatespan rdate 361 return (i,s) 362 363 intervalperiodexpr :: GenParser Char st (Interval, DateSpan) 364 intervalperiodexpr = do 365 many spacenonewline 366 i <- periodexprinterval 367 return (i, DateSpan Nothing Nothing) 368 369 dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) 370 dateperiodexpr rdate = do 371 many spacenonewline 372 s <- periodexprdatespan rdate 373 return (NoInterval, s) 374 375 periodexprinterval :: GenParser Char st Interval 376 periodexprinterval = 377 choice $ map try [ 378 tryinterval "day" "daily" Daily, 379 tryinterval "week" "weekly" Weekly, 380 tryinterval "month" "monthly" Monthly, 381 tryinterval "quarter" "quarterly" Quarterly, 382 tryinterval "year" "yearly" Yearly 383 ] 384 where 385 tryinterval s1 s2 v = 386 choice [try (string $ "every "++s1), try (string s2)] >> return v 387 388 periodexprdatespan :: Day -> GenParser Char st DateSpan 389 periodexprdatespan rdate = choice $ map try [ 390 doubledatespan rdate, 391 fromdatespan rdate, 392 todatespan rdate, 393 justdatespan rdate 394 ] 395 396 doubledatespan :: Day -> GenParser Char st DateSpan 397 doubledatespan rdate = do 398 optional (string "from" >> many spacenonewline) 399 b <- smartdate 400 many spacenonewline 401 optional (string "to" >> many spacenonewline) 402 e <- smartdate 403 return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) 404 405 fromdatespan :: Day -> GenParser Char st DateSpan 406 fromdatespan rdate = do 407 string "from" >> many spacenonewline 408 b <- smartdate 409 return $ DateSpan (Just $ fixSmartDate rdate b) Nothing 410 411 todatespan :: Day -> GenParser Char st DateSpan 412 todatespan rdate = do 413 string "to" >> many spacenonewline 414 e <- smartdate 415 return $ DateSpan Nothing (Just $ fixSmartDate rdate e) 416 417 justdatespan :: Day -> GenParser Char st DateSpan 418 justdatespan rdate = do 419 optional (string "in" >> many spacenonewline) 420 d <- smartdate 421 return $ spanFromSmartDate rdate d 422 423 nulldatespan = DateSpan Nothing Nothing 424 425 mkdatespan b e = DateSpan (Just $ parsedate b) (Just $ parsedate e)